aksdb/CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity

- Initial import from internal repository

Browse Source
This commit is contained in:
Andreas Schneider
2007-12-21 21:31:58 +01:00
commit c0a125042b
194 changed files with 86503 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3406
Imaging/Imaging.pas Normal file
View File

File diff suppressed because it is too large Load Diff

853
Imaging/ImagingBitmap.pas Normal file
View File

@@ -0,0 +1,853 @@
{
$Id: ImagingBitmap.pas 94 2007-06-21 19:29:49Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for Windows Bitmap images.}
unit ImagingBitmap;
{$I ImagingOptions.inc}
interface
uses
ImagingTypes, Imaging, ImagingUtility, ImagingFormats, ImagingIO;
type
{ Class for loading and saving Windows Bitmap images.
It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB
images with or without RLE compression. It can also load 1/4 bit
indexed images and OS2 bitmaps.}
TBitmapFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
ImagingBitmapRLE option.}
property UseRLE: LongBool read FUseRLE write FUseRLE;
end;
implementation
const
SBitmapFormatName = 'Windows Bitmap Image';
SBitmapMasks = '*.bmp,*.dib';
BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4,
ifR5G6B5, ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8];
BitmapDefaultRLE = True;
const
{ Bitmap file identifier 'BM'.}
BMMagic: Word = 19778;
{ Constants for the TBitmapInfoHeader.Compression field.}
BI_RGB = 0;
BI_RLE8 = 1;
BI_RLE4 = 2;
BI_BITFIELDS = 3;
V3InfoHeaderSize = 40;
V4InfoHeaderSize = 108;
type
{ File Header for Windows/OS2 bitmap file.}
TBitmapFileHeader = packed record
ID: Word; // Is always 19778 : 'BM'
Size: LongWord; // Filesize
Reserved1: Word;
Reserved2: Word;
Offset: LongWord; // Offset from start pos to beginning of image bits
end;
{ Info Header for Windows bitmap file version 4.}
TBitmapInfoHeader = packed record
Size: LongWord;
Width: LongInt;
Height: LongInt;
Planes: Word;
BitCount: Word;
Compression: LongWord;
SizeImage: LongWord;
XPelsPerMeter: LongInt;
YPelsPerMeter: LongInt;
ClrUsed: LongInt;
ClrImportant: LongInt;
RedMask: LongWord;
GreenMask: LongWord;
BlueMask: LongWord;
AlphaMask: LongWord;
CSType: LongWord;
EndPoints: array[0..8] of LongWord;
GammaRed: LongWord;
GammaGreen: LongWord;
GammaBlue: LongWord;
end;
{ Info Header for OS2 bitmaps.}
TBitmapCoreHeader = packed record
Size: LongWord;
Width: Word;
Height: Word;
Planes: Word;
BitCount: Word;
end;
{ Used in RLE encoding and decoding.}
TRLEOpcode = packed record
Count: Byte;
Command: Byte;
end;
PRLEOpcode = ^TRLEOpcode;
{ TBitmapFileFormat class implementation }
constructor TBitmapFileFormat.Create;
begin
inherited Create;
FName := SBitmapFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := BitmapSupportedFormats;
FUseRLE := BitmapDefaultRLE;
AddMasks(SBitmapMasks);
RegisterOption(ImagingBitmapRLE, @FUseRLE);
end;
function TBitmapFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
BF: TBitmapFileHeader;
BI: TBitmapInfoHeader;
BC: TBitmapCoreHeader;
IsOS2: Boolean;
PalRGB: PPalette24;
I, FPalSize, AlignedSize, StartPos, HeaderSize, AlignedWidthBytes, WidthBytes: LongInt;
Info: TImageFormatInfo;
Data: Pointer;
procedure LoadRGB;
var
I: LongInt;
LineBuffer: PByte;
begin
with Images[0], GetIO do
begin
// If BI.Height is < 0 then image data are stored non-flipped
// but default in windows is flipped so if Height is positive we must
// flip it
if BI.BitCount < 8 then
begin
// For 1 and 4 bit images load aligned data, they will be converted to
// 8 bit and unaligned later
GetMem(Data, AlignedSize);
if BI.Height < 0 then
Read(Handle, Data, AlignedSize)
else
for I := Height - 1 downto 0 do
Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes);
end
else
begin
// Images with pixels of size >= 1 Byte are read line by line and
// copied to image bits without padding bytes
GetMem(LineBuffer, AlignedWidthBytes);
try
if BI.Height < 0 then
for I := 0 to Height - 1 do
begin
Read(Handle, LineBuffer, AlignedWidthBytes);
Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
end
else
for I := Height - 1 downto 0 do
begin
Read(Handle, LineBuffer, AlignedWidthBytes);
Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
end;
finally
FreeMemNil(LineBuffer);
end;
end;
end;
end;
procedure LoadRLE4;
var
RLESrc: PByteArray;
Row, Col, WriteRow, I: LongInt;
SrcPos: LongWord;
DeltaX, DeltaY, Low, High: Byte;
Pixels: PByteArray;
OpCode: TRLEOpcode;
NegHeightBitmap: Boolean;
begin
GetMem(RLESrc, BI.SizeImage);
GetIO.Read(Handle, RLESrc, BI.SizeImage);
with Images[0] do
try
Low := 0;
Pixels := Bits;
SrcPos := 0;
NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image
Col := 0; // Current column in dest image
// Row in dest image where actuall writting will be done
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do
begin
// Read RLE op-code
OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
Inc(SrcPos, SizeOf(OpCode));
if OpCode.Count = 0 then
begin
// A byte Count of zero means that this is a special
// instruction.
case OpCode.Command of
0:
begin
// Move to next row
Inc(Row);
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
Col := 0;
end ;
1: Break; // Image is finished
2:
begin
// Move to a new relative position
DeltaX := RLESrc[SrcPos];
DeltaY := RLESrc[SrcPos + 1];
Inc(SrcPos, 2);
Inc(Col, DeltaX);
Inc(Row, DeltaY);
end
else
// Do not read data after EOF
if SrcPos + OpCode.Command > BI.SizeImage then
OpCode.Command := BI.SizeImage - SrcPos;
// Take padding bytes and nibbles into account
if Col + OpCode.Command > Width then
OpCode.Command := Width - Col;
// Store absolute data. Command code is the
// number of absolute bytes to store
for I := 0 to OpCode.Command - 1 do
begin
if (I and 1) = 0 then
begin
High := RLESrc[SrcPos] shr 4;
Low := RLESrc[SrcPos] and $F;
Pixels[WriteRow * Width + Col] := High;
Inc(SrcPos);
end
else
Pixels[WriteRow * Width + Col] := Low;
Inc(Col);
end;
// Odd number of bytes is followed by a pad byte
if (OpCode.Command mod 4) in [1, 2] then
Inc(SrcPos);
end;
end
else
begin
// Take padding bytes and nibbles into account
if Col + OpCode.Count > Width then
OpCode.Count := Width - Col;
// Store a run of the same color value
for I := 0 to OpCode.Count - 1 do
begin
if (I and 1) = 0 then
Pixels[WriteRow * Width + Col] := OpCode.Command shr 4
else
Pixels[WriteRow * Width + Col] := OpCode.Command and $F;
Inc(Col);
end;
end;
end;
finally
FreeMem(RLESrc);
end;
end;
procedure LoadRLE8;
var
RLESrc: PByteArray;
SrcCount, Row, Col, WriteRow: LongInt;
SrcPos: LongWord;
DeltaX, DeltaY: Byte;
Pixels: PByteArray;
OpCode: TRLEOpcode;
NegHeightBitmap: Boolean;
begin
GetMem(RLESrc, BI.SizeImage);
GetIO.Read(Handle, RLESrc, BI.SizeImage);
with Images[0] do
try
Pixels := Bits;
SrcPos := 0;
NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image
Col := 0; // Current column in dest image
// Row in dest image where actuall writting will be done
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do
begin
// Read RLE op-code
OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
Inc(SrcPos, SizeOf(OpCode));
if OpCode.Count = 0 then
begin
// A byte Count of zero means that this is a special
// instruction.
case OpCode.Command of
0:
begin
// Move to next row
Inc(Row);
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
Col := 0;
end ;
1: Break; // Image is finished
2:
begin
// Move to a new relative position
DeltaX := RLESrc[SrcPos];
DeltaY := RLESrc[SrcPos + 1];
Inc(SrcPos, 2);
Inc(Col, DeltaX);
Inc(Row, DeltaY);
end
else
SrcCount := OpCode.Command;
// Do not read data after EOF
if SrcPos + OpCode.Command > BI.SizeImage then
OpCode.Command := BI.SizeImage - SrcPos;
// Take padding bytes into account
if Col + OpCode.Command > Width then
OpCode.Command := Width - Col;
// Store absolute data. Command code is the
// number of absolute bytes to store
Move(RLESrc[SrcPos], Pixels[WriteRow * Width + Col], OpCode.Command);
Inc(SrcPos, SrcCount);
Inc(Col, OpCode.Command);
// Odd number of bytes is followed by a pad byte
if (SrcCount mod 2) = 1 then
Inc(SrcPos);
end;
end
else
begin
// Take padding bytes into account
if Col + OpCode.Count > Width then
OpCode.Count := Width - Col;
// Store a run of the same color value. Count is number of bytes to store
FillChar(Pixels [WriteRow * Width + Col], OpCode.Count, OpCode.Command);
Inc(Col, OpCode.Count);
end;
end;
finally
FreeMem(RLESrc);
end;
end;
begin
Data := nil;
SetLength(Images, 1);
with GetIO, Images[0] do
try
FillChar(BI, SizeOf(BI), 0);
StartPos := Tell(Handle);
Read(Handle, @BF, SizeOf(BF));
Read(Handle, @BI.Size, SizeOf(BI.Size));
IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader);
// Bitmap Info reading
if IsOS2 then
begin
// OS/2 type bitmap, reads info header without 4 already read bytes
Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)],
SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size));
with BI do
begin
ClrUsed := 0;
Compression := BI_RGB;
BitCount := BC.BitCount;
Height := BC.Height;
Width := BC.Width;
end;
end
else
begin
// Windows type bitmap
HeaderSize := Min(BI.Size - SizeOf(BI.Size), SizeOf(BI) - SizeOf(BI.Size)); // do not read more than size of BI!
Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)], HeaderSize);
// SizeImage can be 0 for BI_RGB images, but it is here because of:
// I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed.
// It wrote strange 64 Byte Info header with SizeImage set to 0
// Some progs were able to open it, some were not.
if BI.SizeImage = 0 then
BI.SizeImage := BF.Size - BF.Offset;
end;
// Bit mask reading. Only read it if there is V3 header, V4 header has
// masks laoded already (only masks for RGB in V3).
if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then
Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
case BI.BitCount of
1, 4, 8: Format := ifIndex8;
16:
if BI.RedMask = $0F00 then
// Set XRGB4 or ARGB4 according to value of alpha mask
Format := IffFormat(BI.AlphaMask = 0, ifX4R4G4B4, ifA4R4G4B4)
else if BI.RedMask = $F800 then
Format := ifR5G6B5
else
// R5G5B5 is default 16bit format (with Compression = BI_RGB or masks).
// We set it to A1.. and later there is a check if there are any alpha values
// and if not it is changed to X1R5G5B5
Format := ifA1R5G5B5;
24: Format := ifR8G8B8;
32: Format := ifA8R8G8B8; // As with R5G5B5 there is alpha check later
end;
NewImage(BI.Width, Abs(BI.Height), Format, Images[0]);
Info := GetFormatInfo(Format);
WidthBytes := Width * Info.BytesPerPixel;
AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4;
AlignedSize := Height * LongInt(AlignedWidthBytes);
// Palette settings and reading
if BI.BitCount <= 8 then
begin
// Seek to the begining of palette
Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
smFromBeginning);
if IsOS2 then
begin
// OS/2 type
FPalSize := 1 shl BI.BitCount;
GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec));
try
Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec));
for I := 0 to FPalSize - 1 do
with PalRGB[I] do
begin
Palette[I].R := R;
Palette[I].G := G;
Palette[I].B := B;
end;
finally
FreeMemNil(PalRGB);
end;
end
else
begin
// Windows type
FPalSize := BI.ClrUsed;
if FPalSize = 0 then
FPalSize := 1 shl BI.BitCount;
Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
end;
for I := 0 to FPalSize - 1 do
Palette[I].A := $FF;
end;
// Seek to the beginning of image bits
Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning);
case BI.Compression of
BI_RGB: LoadRGB;
BI_RLE4: LoadRLE4;
BI_RLE8: LoadRLE8;
BI_BITFIELDS: LoadRGB;
end;
if BI.AlphaMask = 0 then
begin
// Alpha mask is not stored in file (V3) or not defined.
// Check alpha channels of loaded images if they might contain them.
if Format = ifA1R5G5B5 then
begin
// Check if there is alpha channel present in A1R5GB5 images, if it is not
// change format to X1R5G5B5
if not Has16BitImageAlpha(Width * Height, Bits) then
Format := ifX1R5G5B5;
end
else if Format = ifA8R8G8B8 then
begin
// Check if there is alpha channel present in A8R8G8B8 images, if it is not
// change format to X8R8G8B8
if not Has32BitImageAlpha(Width * Height, Bits) then
Format := ifX8R8G8B8;
end;
end;
if BI.BitCount < 8 then
begin
// 1 and 4 bpp images are supported only for loading which is now
// so we now convert them to 8bpp (and unalign scanlines).
case BI.BitCount of
1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
4:
begin
// RLE4 bitmaps are translated to 8bit during RLE decoding
if BI.Compression <> BI_RLE4 then
Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
end;
end;
// Enlarge palette
ReallocMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
end;
Result := True;
finally
FreeMemNil(Data);
end;
end;
function TBitmapFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
StartPos, EndPos, I, Pad, PadSize, WidthBytes: LongInt;
BF: TBitmapFileHeader;
BI: TBitmapInfoHeader;
Info: TImageFormatInfo;
ImageToSave: TImageData;
MustBeFreed: Boolean;
procedure SaveRLE8;
const
BufferSize = 8 * 1024;
var
X, Y, I, SrcPos: LongInt;
DiffCount, SameCount: Byte;
Pixels: PByteArray;
Buffer: array[0..BufferSize - 1] of Byte;
BufferPos: LongInt;
procedure WriteByte(ByteToWrite: Byte);
begin
if BufferPos = BufferSize then
begin
// Flush buffer if necessary
GetIO.Write(Handle, @Buffer, BufferPos);
BufferPos := 0;
end;
Buffer[BufferPos] := ByteToWrite;
Inc(BufferPos);
end;
begin
BufferPos := 0;
with GetIO, ImageToSave do
begin
for Y := Height - 1 downto 0 do
begin
X := 0;
SrcPos := 0;
Pixels := @PByteArray(Bits)[Y * Width];
while X < Width do
begin
SameCount := 1;
DiffCount := 0;
// Determine run length
while X + SameCount < Width do
begin
// If we reach max run length or byte with different value
// we end this run
if (SameCount = 255) or (Pixels[SrcPos + SameCount] <> Pixels[SrcPos]) then
Break;
Inc(SameCount);
end;
if SameCount = 1 then
begin
// If there are not some bytes with the same value we
// compute how many different bytes are there
while X + DiffCount < Width do
begin
// Stop diff byte counting if there two bytes with the same value
// or DiffCount is too big
if (DiffCount = 255) or (Pixels[SrcPos + DiffCount + 1] =
Pixels[SrcPos + DiffCount]) then
Break;
Inc(DiffCount);
end;
end;
// Now store absolute data (direct copy image->file) or
// store RLE code only (number of repeats + byte to be repeated)
if DiffCount > 2 then
begin
// Save 'Absolute Data' (0 + number of bytes) but only
// if number is >2 because (0+1) and (0+2) are other special commands
WriteByte(0);
WriteByte(DiffCount);
// Write absolute data to buffer
for I := 0 to DiffCount - 1 do
WriteByte(Pixels[SrcPos + I]);
Inc(X, DiffCount);
Inc(SrcPos, DiffCount);
// Odd number of bytes must be padded
if (DiffCount mod 2) = 1 then
WriteByte(0);
end
else
begin
// Save number of repeats and byte that should be repeated
WriteByte(SameCount);
WriteByte(Pixels[SrcPos]);
Inc(X, SameCount);
Inc(SrcPos, SameCount);
end;
end;
// Save 'End Of Line' command
WriteByte(0);
WriteByte(0);
end;
// Save 'End Of Bitmap' command
WriteByte(0);
WriteByte(1);
// Flush buffer
GetIO.Write(Handle, @Buffer, BufferPos);
end;
end;
begin
Result := False;
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with GetIO, ImageToSave do
try
Info := GetFormatInfo(Format);
StartPos := Tell(Handle);
FillChar(BF, SizeOf(BF), 0);
FillChar(BI, SizeOf(BI), 0);
// Other fields will be filled later - we don't know all values now
BF.ID := BMMagic;
Write(Handle, @BF, SizeOf(BF));
if Info.HasAlphaChannel and (Info.BytesPerPixel = 2){V4 temp hack} then
// Save images with alpha in V4 format
BI.Size := V4InfoHeaderSize
else
// Save images without alpha in V3 format - for better compatibility
BI.Size := V3InfoHeaderSize;
BI.Width := Width;
BI.Height := Height;
BI.Planes := 1;
BI.BitCount := Info.BytesPerPixel * 8;
BI.XPelsPerMeter := 2835; // 72 dpi
BI.YPelsPerMeter := 2835; // 72 dpi
// Set compression
if (Info.BytesPerPixel = 1) and FUseRLE then
BI.Compression := BI_RLE8
else if (Info.HasAlphaChannel or
((BI.BitCount = 16) and (Format <> ifX1R5G5B5))) and (Info.BytesPerPixel = 2){V4 temp hack} then
BI.Compression := BI_BITFIELDS
else
BI.Compression := BI_RGB;
// Write header (first time)
Write(Handle, @BI, BI.Size);
// Write mask info
if BI.Compression = BI_BITFIELDS then
begin
if BI.BitCount = 16 then
with Info.PixelFormat^ do
begin
BI.RedMask := RBitMask;
BI.GreenMask := GBitMask;
BI.BlueMask := BBitMask;
BI.AlphaMask := ABitMask;
end
else
begin
// Set masks for A8R8G8B8
BI.RedMask := $00FF0000;
BI.GreenMask := $0000FF00;
BI.BlueMask := $000000FF;
BI.AlphaMask := $FF000000;
end;
// If V3 header is used RGB masks must be written to file separately.
// V4 header has embedded masks (V4 is default for formats with alpha).
if BI.Size = V3InfoHeaderSize then
Write(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
end;
// Write palette
if Palette <> nil then
Write(Handle, Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
BF.Offset := Tell(Handle) - StartPos;
if BI.Compression <> BI_RLE8 then
begin
// Save uncompressed data, scanlines must be filled with pad bytes
// to be multiples of 4, save as bottom-up (Windows native) bitmap
Pad := 0;
WidthBytes := Width * Info.BytesPerPixel;
PadSize := ((Width * BI.BitCount + 31) div 32) * 4 - WidthBytes;
for I := Height - 1 downto 0 do
begin
Write(Handle, @PByteArray(Bits)[I * WidthBytes], WidthBytes);
if PadSize > 0 then
Write(Handle, @Pad, PadSize);
end;
end
else
begin
// Save data with RLE8 compression
SaveRLE8;
end;
EndPos := Tell(Handle);
Seek(Handle, StartPos, smFromBeginning);
// Rewrite header with new values
BF.Size := EndPos - StartPos;
BI.SizeImage := BF.Size - BF.Offset;
Write(Handle, @BF, SizeOf(BF));
Write(Handle, @BI, BI.Size);
Seek(Handle, EndPos, smFromBeginning);
Result := True;
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
procedure TBitmapFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
// Convert FP image to RGB/ARGB according to presence of alpha channel
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
else if Info.HasGrayChannel or Info.IsIndexed then
// Convert all grayscale and indexed images to Index8 unless they have alpha
// (preserve it)
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifIndex8)
else if Info.HasAlphaChannel then
// Convert images with alpha channel to A8R8G8B8
ConvFormat := ifA8R8G8B8
else if Info.UsePixelFormat then
// Convert 16bit RGB images (no alpha) to X1R5G5B5
ConvFormat := ifX1R5G5B5
else
// Convert all other formats to R8G8B8
ConvFormat := ifR8G8B8;
ConvertImage(Image, ConvFormat);
end;
function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Hdr: TBitmapFileHeader;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr));
end;
end;
initialization
RegisterImageFileFormat(TBitmapFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
- Add option to choose to save V3 or V4 headers.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Now saves bitmaps as bottom-up for better compatibility
(mainly Lazarus' TImage!).
- Fixed crash when loading bitmaps with headers larger than V4.
- Temp hacks to disable V4 headers for 32bit images (compatibility with
other soft).
-- 0.21 Changes/Bug Fixes -----------------------------------
- Removed temporary data allocation for image with aligned scanlines.
They are now directly written to output so memory requirements are
much lower now.
- Now uses and recognizes BITMAPINFOHEADERV4 when loading/saving.
Mainly for formats with alpha channels.
- Added ifR5G6B5 to supported formats, changed converting to supported
formats little bit.
- Rewritten SaveRLE8 nested procedure. Old code was long and
mysterious - new is short and much more readable.
- MakeCompatible method moved to base class, put ConvertToSupported here.
GetSupportedFormats removed, it is now set in constructor.
- Rewritten LoadRLE4 and LoadRLE8 nested procedures.
Should be less buggy an more readable (load inspired by Colosseum Builders' code).
- Made public properties for options registered to SetOption/GetOption
functions.
- Addded alpha check to 32b bitmap loading too (teh same as in 16b
bitmap loading).
- Moved Convert1To8 and Convert4To8 to ImagingFormats
- Changed extensions to filename masks.
- Changed SaveData, LoadData, and MakeCompatible methods according
to changes in base class in Imaging unit.
-- 0.19 Changes/Bug Fixes -----------------------------------
- fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5
- fixed the bug that caused 8bit RLE compressed bitmaps to load as
whole black
-- 0.17 Changes/Bug Fixes -----------------------------------
- 16 bit images are usually without alpha but some has alpha
channel and there is no indication of it - so I have added
a check: if all pixels of image are with alpha = 0 image is treated
as X1R5G5B5 otherwise as A1R5G5B5
-- 0.13 Changes/Bug Fixes -----------------------------------
- when loading 1/4 bit images with dword aligned dimensions
there was ugly memory rewritting bug causing image corruption
}
end.

1054
Imaging/ImagingCanvases.pas Normal file
View File

File diff suppressed because it is too large Load Diff

984
Imaging/ImagingClasses.pas Normal file
View File

@@ -0,0 +1,984 @@
{
$Id: ImagingClasses.pas 94 2007-06-21 19:29:49Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains class based wrapper to Imaging library.}
unit ImagingClasses;
{$I ImagingOptions.inc}
interface
uses
Types, Classes, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
type
{ Base abstract high level class wrapper to low level Imaging structures and
functions.}
TBaseImage = class(TPersistent)
protected
FPData: PImageData;
FOnDataSizeChanged: TNotifyEvent;
FOnPixelsChanged: TNotifyEvent;
function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBoundsRect: TRect;
procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; virtual; abstract;
procedure DoDataSizeChanged; virtual;
procedure DoPixelsChanged; virtual;
published
public
constructor Create; virtual;
constructor CreateFromImage(AImage: TBaseImage);
destructor Destroy; override;
{ Returns info about current image.}
function ToString: string;
{ Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.}
procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
{ Resizes current image with optional resampling.}
procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
{ Flips current image. Reverses the image along its horizontal axis the top
becomes the bottom and vice versa.}
procedure Flip;
{ Mirrors current image. Reverses the image along its vertical axis the left
side becomes the right and vice versa.}
procedure Mirror;
{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.}
procedure Rotate(Angle: LongInt);
{ Copies rectangular part of SrcImage to DstImage. No blending is performed -
alpha is simply copied to destination image. Operates also with
negative X and Y coordinates.
Note that copying is fastest for images in the same data format
(and slowest for images in special formats).}
procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt);
{ Stretches the contents of the source rectangle to the destination rectangle
with optional resampling. No blending is performed - alpha is
simply copied/resampled to destination image. Note that stretching is
fastest for images in the same data format (and slowest for
images in special formats).}
procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
{ Replaces pixels with OldPixel in the given rectangle by NewPixel.
OldPixel and NewPixel should point to the pixels in the same format
as the given image is in.}
procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer);
{ Swaps SrcChannel and DstChannel color or alpha channels of image.
Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
identify channels.}
procedure SwapChannels(SrcChannel, DstChannel: LongInt);
{ Loads current image data from file.}
procedure LoadFromFile(const FileName: string); virtual;
{ Loads current image data from stream.}
procedure LoadFromStream(Stream: TStream); virtual;
{ Saves current image data to file.}
procedure SaveToFile(const FileName: string);
{ Saves current image data to stream. Ext identifies desired image file
format (jpg, png, dds, ...)}
procedure SaveToStream(const Ext: string; Stream: TStream);
{ Width of current image in pixels.}
property Width: LongInt read GetWidth write SetWidth;
{ Height of current image in pixels.}
property Height: LongInt read GetHeight write SetHeight;
{ Image data format of current image.}
property Format: TImageFormat read GetFormat write SetFormat;
{ Size in bytes of current image's data.}
property Size: LongInt read GetSize;
{ Pointer to memory containing image bits.}
property Bits: Pointer read GetBits;
{ Pointer to palette for indexed format images. It is nil for others.
Max palette entry is at index [PaletteEntries - 1].}
property Palette: PPalette32 read GetPalette;
{ Number of entries in image's palette}
property PaletteEntries: LongInt read GetPaletteEntries;
{ Provides indexed access to each line of pixels. Does not work with special
format images (like DXT).}
property ScanLine[Index: LongInt]: Pointer read GetScanLine;
{ Returns pointer to image pixel at [X, Y] coordinates.}
property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer;
{ Extended image format information.}
property FormatInfo: TImageFormatInfo read GetFormatInfo;
{ This gives complete access to underlying TImageData record.
It can be used in functions that take TImageData as parameter
(for example: ReduceColors(SingleImageInstance.ImageData^, 64)).}
property ImageDataPointer: PImageData read FPData;
{ Indicates whether the current image is valid (proper format,
allowed dimensions, right size, ...).}
property Valid: Boolean read GetValid;
{{ Specifies the bounding rectangle of the image.}
property BoundsRect: TRect read GetBoundsRect;
{ This event occurs when the image data size has just changed. That means
image width, height, or format has been changed.}
property OnDataSizeChanged: TNotifyEvent read FOnDataSizeChanged write FOnDataSizeChanged;
{ This event occurs when some pixels of the image have just changed.}
property OnPixelsChanged: TNotifyEvent read FOnPixelsChanged write FOnPixelsChanged;
end;
{ Extension of TBaseImage which uses single TImageData record to
store image. All methods inherited from TBaseImage work with this record.}
TSingleImage = class(TBaseImage)
protected
FImageData: TImageData;
procedure SetPointer; override;
public
constructor Create; override;
constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault);
constructor CreateFromData(const AData: TImageData);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns single image from another single image or multi image.}
procedure Assign(Source: TPersistent); override;
end;
{ Extension of TBaseImage which uses array of TImageData records to
store multiple images. Images are independent on each other and they don't
share any common characteristic. Each can have different size, format, and
palette. All methods inherited from TBaseImage work only with
active image (it could represent mipmap level, animation frame, or whatever).
Methods whose names contain word 'Multi' work with all images in array
(as well as other methods with obvious names).}
TMultiImage = class(TBaseImage)
protected
FDataArray: TDynImageDataArray;
FActiveImage: LongInt;
procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImageCount(Value: LongInt);
function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; override;
function PrepareInsert(Index, Count: LongInt): Boolean;
procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat);
public
constructor Create; override;
constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt);
constructor CreateFromArray(ADataArray: TDynImageDataArray);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns multi image from another multi image or single image.}
procedure Assign(Source: TPersistent); override;
{ Adds new image at the end of the image array. }
procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
{ Adds existing image at the end of the image array. }
procedure AddImage(const Image: TImageData); overload;
{ Adds existing image (Active image of a TmultiImage)
at the end of the image array. }
procedure AddImage(Image: TBaseImage); overload;
{ Adds existing image array ((all images of a multi image))
at the end of the image array. }
procedure AddImages(const Images: TDynImageDataArray); overload;
{ Adds existing MultiImage images at the end of the image array. }
procedure AddImages(Images: TMultiImage); overload;
{ Inserts new image image at the given position in the image array. }
procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
{ Inserts existing image at the given position in the image array. }
procedure InsertImage(Index: LongInt; const Image: TImageData); overload;
{ Inserts existing image (Active image of a TmultiImage)
at the given position in the image array. }
procedure InsertImage(Index: LongInt; Image: TBaseImage); overload;
{ Inserts existing image at the given position in the image array. }
procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload;
{ Inserts existing images (all images of a TmultiImage) at
the given position in the image array. }
procedure InsertImages(Index: LongInt; Images: TMultiImage); overload;
{ Exchanges two images at the given positions in the image array. }
procedure ExchangeImages(Index1, Index2: LongInt);
{ Deletes image at the given position in the image array.}
procedure DeleteImage(Index: LongInt);
{ Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat);
{ Resizes all images.}
procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
{ Overloaded loading method that will add new image to multiimage if
image array is empty bero loading. }
procedure LoadFromFile(const FileName: string); override;
{ Overloaded loading method that will add new image to multiimage if
image array is empty bero loading. }
procedure LoadFromStream(Stream: TStream); override;
{ Loads whole multi image from file.}
procedure LoadMultiFromFile(const FileName: string);
{ Loads whole multi image from stream.}
procedure LoadMultiFromStream(Stream: TStream);
{ Saves whole multi image to file.}
procedure SaveMultiToFile(const FileName: string);
{ Saves whole multi image to stream. Ext identifies desired
image file format (jpg, png, dds, ...).}
procedure SaveMultiToStream(const Ext: string; Stream: TStream);
{ Indicates active image of this multi image. All methods inherited
from TBaseImage operate on this image only.}
property ActiveImage: LongInt read FActiveImage write SetActiveImage;
{ Number of images of this multi image.}
property ImageCount: LongInt read GetImageCount write SetImageCount;
{ This value is True if all images of this TMultiImage are valid.}
property AllImagesValid: Boolean read GetAllImagesValid;
{ This gives complete access to underlying TDynImageDataArray.
It can be used in functions that take TDynImageDataArray
as parameter.}
property DataArray: TDynImageDataArray read FDataArray;
{ Array property for accessing individual images of TMultiImage. When you
set image at given index the old image is freed and the source is cloned.}
property Images[Index: LongInt]: TImageData read GetImage write SetImage; default;
end;
implementation
const
DefaultWidth = 16;
DefaultHeight = 16;
DefaultImages = 1;
function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
begin
SetLength(Result, 1);
Result[0] := ImageData;
end;
{ TBaseImage class implementation }
constructor TBaseImage.Create;
begin
SetPointer;
end;
constructor TBaseImage.CreateFromImage(AImage: TBaseImage);
begin
Create;
Assign(AImage);
end;
destructor TBaseImage.Destroy;
begin
inherited Destroy;
end;
function TBaseImage.GetWidth: LongInt;
begin
if Valid then
Result := FPData.Width
else
Result := 0;
end;
function TBaseImage.GetHeight: LongInt;
begin
if Valid then
Result := FPData.Height
else
Result := 0;
end;
function TBaseImage.GetFormat: TImageFormat;
begin
if Valid then
Result := FPData.Format
else
Result := ifUnknown;
end;
function TBaseImage.GetScanLine(Index: LongInt): Pointer;
var
Info: TImageFormatInfo;
begin
if Valid then
begin
Info := GetFormatInfo;
if not Info.IsSpecial then
Result := ImagingFormats.GetScanLine(FPData.Bits, Info, FPData.Width, Index)
else
Result := FPData.Bits;
end
else
Result := nil;
end;
function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer;
begin
if Valid then
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
else
Result := nil;
end;
function TBaseImage.GetSize: LongInt;
begin
if Valid then
Result := FPData.Size
else
Result := 0;
end;
function TBaseImage.GetBits: Pointer;
begin
if Valid then
Result := FPData.Bits
else
Result := nil;
end;
function TBaseImage.GetPalette: PPalette32;
begin
if Valid then
Result := FPData.Palette
else
Result := nil;
end;
function TBaseImage.GetPaletteEntries: LongInt;
begin
Result := GetFormatInfo.PaletteEntries;
end;
function TBaseImage.GetFormatInfo: TImageFormatInfo;
begin
if Valid then
Imaging.GetImageFormatInfo(FPData.Format, Result)
else
FillChar(Result, SizeOf(Result), 0);
end;
function TBaseImage.GetValid: Boolean;
begin
Result := Assigned(FPData) and Imaging.TestImage(FPData^);
end;
function TBaseImage.GetBoundsRect: TRect;
begin
Result := Rect(0, 0, GetWidth, GetHeight);
end;
procedure TBaseImage.SetWidth(const Value: LongInt);
begin
Resize(Value, GetHeight, rfNearest);
end;
procedure TBaseImage.SetHeight(const Value: LongInt);
begin
Resize(GetWidth, Value, rfNearest);
end;
procedure TBaseImage.SetFormat(const Value: TImageFormat);
begin
if Valid and Imaging.ConvertImage(FPData^, Value) then
DoDataSizeChanged;
end;
procedure TBaseImage.DoDataSizeChanged;
begin
if Assigned(FOnDataSizeChanged) then
FOnDataSizeChanged(Self);
DoPixelsChanged;
end;
procedure TBaseImage.DoPixelsChanged;
begin
if Assigned(FOnPixelsChanged) then
FOnPixelsChanged(Self);
end;
procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
begin
if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
DoDataSizeChanged;
end;
procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
begin
if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
DoDataSizeChanged;
end;
procedure TBaseImage.Flip;
begin
if Valid and Imaging.FlipImage(FPData^) then
DoPixelsChanged;
end;
procedure TBaseImage.Mirror;
begin
if Valid and Imaging.MirrorImage(FPData^) then
DoPixelsChanged;
end;
procedure TBaseImage.Rotate(Angle: LongInt);
begin
if Valid and Imaging.RotateImage(FPData^, Angle) then
DoPixelsChanged;
end;
procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt;
DstImage: TBaseImage; DstX, DstY: LongInt);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
Imaging.CopyRect(FPData^, SrcX, SrcY, Width, Height, DstImage.FPData^, DstX, DstY);
DstImage.DoPixelsChanged;
end;
end;
procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
Imaging.StretchRect(FPData^, SrcX, SrcY, SrcWidth, SrcHeight,
DstImage.FPData^, DstX, DstY, DstWidth, DstHeight, Filter);
DstImage.DoPixelsChanged;
end;
end;
procedure TBaseImage.ReplaceColor(X, Y, Width, Height: Integer; OldColor,
NewColor: Pointer);
begin
if Valid then
begin
Imaging.ReplaceColor(FPData^, X, Y, Width, Height, OldColor, NewColor);
DoPixelsChanged;
end;
end;
procedure TBaseImage.SwapChannels(SrcChannel, DstChannel: Integer);
begin
if Valid then
begin
Imaging.SwapChannels(FPData^, SrcChannel, DstChannel);
DoPixelsChanged;
end;
end;
function TBaseImage.ToString: string;
begin
Result := Iff(Valid, Imaging.ImageToStr(FPData^), 'empty image');
end;
procedure TBaseImage.LoadFromFile(const FileName: string);
begin
if Assigned(FPData) and Imaging.LoadImageFromFile(FileName, FPData^) then
DoDataSizeChanged;
end;
procedure TBaseImage.LoadFromStream(Stream: TStream);
begin
if Assigned(FPData) and Imaging.LoadImageFromStream(Stream, FPData^) then
DoDataSizeChanged;
end;
procedure TBaseImage.SaveToFile(const FileName: string);
begin
if Valid then
Imaging.SaveImageToFile(FileName, FPData^);
end;
procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream);
begin
if Valid then
Imaging.SaveImageToStream(Ext, Stream, FPData^);
end;
{ TSingleImage class implementation }
constructor TSingleImage.Create;
begin
inherited Create;
RecreateImageData(DefaultWidth, DefaultHeight, ifDefault);
end;
constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat);
begin
inherited Create;
RecreateImageData(AWidth, AHeight, AFormat);
end;
constructor TSingleImage.CreateFromData(const AData: TImageData);
begin
inherited Create;
if Imaging.TestImage(AData) then
begin
Imaging.CloneImage(AData, FImageData);
DoDataSizeChanged;
end
else
Create;
end;
constructor TSingleImage.CreateFromFile(const FileName: string);
begin
inherited Create;
LoadFromFile(FileName);
end;
constructor TSingleImage.CreateFromStream(Stream: TStream);
begin
inherited Create;
LoadFromStream(Stream);
end;
destructor TSingleImage.Destroy;
begin
Imaging.FreeImage(FImageData);
inherited Destroy;
end;
procedure TSingleImage.SetPointer;
begin
FPData := @FImageData;
end;
procedure TSingleImage.Assign(Source: TPersistent);
begin
if Source = nil then
begin
Create;
end
else if Source is TSingleImage then
begin
CreateFromData(TSingleImage(Source).FImageData);
end
else if Source is TMultiImage then
begin
if TMultiImage(Source).Valid then
CreateFromData(TMultiImage(Source).FPData^)
else
Assign(nil);
end
else
inherited Assign(Source);
end;
{ TMultiImage class implementation }
constructor TMultiImage.Create;
begin
SetImageCount(DefaultImages);
SetActiveImage(0);
end;
constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt;
AFormat: TImageFormat; Images: LongInt);
var
I: LongInt;
begin
Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Images);
for I := 0 to GetImageCount - 1 do
Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
SetActiveImage(0);
end;
constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray);
var
I: LongInt;
begin
Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Length(ADataArray));
for I := 0 to GetImageCount - 1 do
begin
// Clone only valid images
if Imaging.TestImage(ADataArray[I]) then
Imaging.CloneImage(ADataArray[I], FDataArray[I])
else
Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
end;
SetActiveImage(0);
end;
constructor TMultiImage.CreateFromFile(const FileName: string);
begin
LoadMultiFromFile(FileName);
end;
constructor TMultiImage.CreateFromStream(Stream: TStream);
begin
LoadMultiFromStream(Stream);
end;
destructor TMultiImage.Destroy;
begin
Imaging.FreeImagesInArray(FDataArray);
inherited Destroy;
end;
procedure TMultiImage.SetActiveImage(Value: LongInt);
begin
FActiveImage := Value;
SetPointer;
end;
function TMultiImage.GetImageCount: LongInt;
begin
Result := Length(FDataArray);
end;
procedure TMultiImage.SetImageCount(Value: LongInt);
var
I, OldCount: LongInt;
begin
if Value > GetImageCount then
begin
// Create new empty images if array will be enlarged
OldCount := GetImageCount;
SetLength(FDataArray, Value);
for I := OldCount to Value - 1 do
Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
end
else
begin
// Free images that exceed desired count and shrink array
for I := Value to GetImageCount - 1 do
Imaging.FreeImage(FDataArray[I]);
SetLength(FDataArray, Value);
end;
SetPointer;
end;
function TMultiImage.GetAllImagesValid: Boolean;
begin
Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
end;
function TMultiImage.GetImage(Index: LongInt): TImageData;
begin
if (Index >= 0) and (Index < GetImageCount) then
Result := FDataArray[Index];
end;
procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData);
begin
if (Index >= 0) and (Index < GetImageCount) then
Imaging.CloneImage(Value, FDataArray[Index]);
end;
procedure TMultiImage.SetPointer;
begin
if GetImageCount > 0 then
begin
FActiveImage := ClampInt(FActiveImage, 0, GetImageCount - 1);
FPData := @FDataArray[FActiveImage];
end
else
begin
FActiveImage := -1;
FPData := nil
end;
end;
function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean;
var
I: LongInt;
begin
// Inserting to empty image will add image at index 0
if GetImageCount = 0 then
Index := 0;
if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then
begin
SetLength(FDataArray, GetImageCount + Count);
if Index < GetImageCount - 1 then
begin
// Move imges to new position
System.Move(FDataArray[Index], FDataArray[Index + Count],
(GetImageCount - Count - Index) * SizeOf(TImageData));
// Null old images, not free them!
for I := Index to Index + Count - 1 do
InitImage(FDataArray[I]);
end;
Result := True;
end
else
Result := False;
end;
procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
var
I, Len: LongInt;
begin
Len := Length(Images);
if PrepareInsert(Index, Len) then
begin
for I := 0 to Len - 1 do
Imaging.CloneImage(Images[I], FDataArray[Index + I]);
end;
end;
procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt;
AFormat: TImageFormat);
begin
if PrepareInsert(Index, 1) then
Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[Index]);
end;
procedure TMultiImage.Assign(Source: TPersistent);
var
Arr: TDynImageDataArray;
begin
if Source = nil then
begin
Create;
end
else if Source is TMultiImage then
begin
CreateFromArray(TMultiImage(Source).FDataArray);
SetActiveImage(TMultiImage(Source).ActiveImage);
end
else if Source is TSingleImage then
begin
SetLength(Arr, 1);
Arr[0] := TSingleImage(Source).FImageData;
CreateFromArray(Arr);
Arr := nil;
end
else
inherited Assign(Source);
end;
procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat);
begin
DoInsertNew(GetImageCount, AWidth, AHeight, AFormat);
end;
procedure TMultiImage.AddImage(const Image: TImageData);
begin
DoInsertImages(GetImageCount, GetArrayFromImageData(Image));
end;
procedure TMultiImage.AddImage(Image: TBaseImage);
begin
if Assigned(Image) and Image.Valid then
DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^));
end;
procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
begin
DoInsertImages(GetImageCount, Images);
end;
procedure TMultiImage.AddImages(Images: TMultiImage);
begin
DoInsertImages(GetImageCount, Images.FDataArray);
end;
procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt;
AFormat: TImageFormat);
begin
DoInsertNew(Index, AWidth, AHeight, AFormat);
end;
procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData);
begin
DoInsertImages(Index, GetArrayFromImageData(Image));
end;
procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage);
begin
if Assigned(Image) and Image.Valid then
DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
end;
procedure TMultiImage.InsertImages(Index: LongInt;
const Images: TDynImageDataArray);
begin
DoInsertImages(Index, FDataArray);
end;
procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage);
begin
DoInsertImages(Index, Images.FDataArray);
end;
procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt);
var
TempData: TImageData;
begin
if (Index1 >= 0) and (Index1 < GetImageCount) and
(Index2 >= 0) and (Index2 < GetImageCount) then
begin
TempData := FDataArray[Index1];
FDataArray[Index1] := FDataArray[Index2];
FDataArray[Index2] := TempData;
end;
end;
procedure TMultiImage.DeleteImage(Index: LongInt);
var
I: LongInt;
begin
if (Index >= 0) and (Index < GetImageCount) then
begin
// Free image at index to be deleted
Imaging.FreeImage(FDataArray[Index]);
if Index < GetImageCount - 1 then
begin
// Move images to new indices if necessary
for I := Index to GetImageCount - 2 do
FDataArray[I] := FDataArray[I + 1];
end;
// Set new array length and update pointer to active image
SetLength(FDataArray, GetImageCount - 1);
SetPointer;
end;
end;
procedure TMultiImage.ConvertImages(Format: TImageFormat);
var
I: LongInt;
begin
for I := 0 to GetImageCount - 1 do
Imaging.ConvertImage(FDataArray[I], Format);
end;
procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt;
Filter: TResizeFilter);
var
I: LongInt;
begin
for I := 0 to GetImageCount do
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end;
procedure TMultiImage.LoadFromFile(const FileName: string);
begin
if GetImageCount = 0 then
ImageCount := 1;
inherited LoadFromFile(FileName);
end;
procedure TMultiImage.LoadFromStream(Stream: TStream);
begin
if GetImageCount = 0 then
ImageCount := 1;
inherited LoadFromStream(Stream);
end;
procedure TMultiImage.LoadMultiFromFile(const FileName: string);
begin
Imaging.LoadMultiImageFromFile(FileName, FDataArray);
SetActiveImage(0);
end;
procedure TMultiImage.LoadMultiFromStream(Stream: TStream);
begin
Imaging.LoadMultiImageFromStream(Stream, FDataArray);
SetActiveImage(0);
end;
procedure TMultiImage.SaveMultiToFile(const FileName: string);
begin
Imaging.SaveMultiImageToFile(FileName, FDataArray);
end;
procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream);
begin
Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
end;
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
- add SetPalette, create some pal wrapper first
- put all low level stuff here like ReplaceColor etc, change
CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added SwapChannels method to TBaseImage.
- Added ReplaceColor method to TBaseImage.
- Added ToString method to TBaseImage.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Inserting images to empty MultiImage will act as Add method.
- MultiImages with empty arrays will now create one image when
LoadFromFile or LoadFromStream is called.
- Fixed bug that caused AVs when getting props like Width, Height, asn Size
and when inlining was off. There was call to Iff but with inlining disabled
params like FPData.Size were evaluated and when FPData was nil => AV.
- Added many FPData validity checks to many methods. There were AVs
when calling most methods on empty TMultiImage.
- Added AllImagesValid property to TMultiImage.
- Fixed memory leak in TMultiImage.CreateFromParams.
-- 0.19 Changes/Bug Fixes -----------------------------------
- added ResizeImages method to TMultiImage
- removed Ext parameter from various LoadFromStream methods, no
longer needed
- fixed various issues concerning ActiveImage of TMultiImage
(it pointed to invalid location after some operations)
- most of property set/get methods are now inline
- added PixelPointers property to TBaseImage
- added Images default array property to TMultiImage
- renamed methods in TMultiImage to contain 'Image' instead of 'Level'
- added canvas support
- added OnDataSizeChanged and OnPixelsChanged event to TBaseImage
- renamed TSingleImage.NewImage to RecreateImageData, made public, and
moved to TBaseImage
-- 0.17 Changes/Bug Fixes -----------------------------------
- added props PaletteEntries and ScanLine to TBaseImage
- aded new constructor to TBaseImage that take TBaseImage source
- TMultiImage levels adding and inserting rewritten internally
- added some new functions to TMultiImage: AddLevels, InsertLevels
- added some new functions to TBaseImage: Flip, Mirror, Rotate,
CopyRect, StretchRect
- TBasicImage.Resize has now filter parameter
- new stuff added to TMultiImage (DataArray prop, ConvertLevels)
-- 0.13 Changes/Bug Fixes -----------------------------------
- added AddLevel, InsertLevel, ExchangeLevels and DeleteLevel
methods to TMultiImage
- added TBaseImage, TSingleImage and TMultiImage with initial
members
}
end.

204
Imaging/ImagingColors.pas Normal file
View File

@@ -0,0 +1,204 @@
{
$Id: ImagingColors.pas 74 2007-03-12 15:04:04Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains functions for manipulating and converting color values.}
unit ImagingColors;
interface
{$I ImagingOptions.inc}
uses
SysUtils, ImagingTypes, ImagingUtility;
{ Converts RGB color to YUV.}
procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
{ Converts YIV to RGB color.}
procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
{ Converts RGB color to YCbCr as used in JPEG.}
procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
{ Converts YCbCr as used in JPEG to RGB color.}
procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
{ Converts RGB color to YCbCr as used in JPEG.}
procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
{ Converts YCbCr as used in JPEG to RGB color.}
procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
{ Converts RGB color to CMY.}
procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
{ Converts CMY to RGB color.}
procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
{ Converts RGB color to CMY.}
procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
{ Converts CMY to RGB color.}
procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
{ Converts RGB color to CMYK.}
procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
{ Converts CMYK to RGB color.}
procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
{ Converts RGB color to CMYK.}
procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
{ Converts CMYK to RGB color.}
procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
implementation
procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
begin
Y := ClampToByte(Round( 0.257 * R + 0.504 * G + 0.098 * B) + 16);
V := ClampToByte(Round( 0.439 * R - 0.368 * G - 0.071 * B) + 128);
U := ClampToByte(Round(-0.148 * R - 0.291 * G + 0.439 * B) + 128);
end;
procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
var
CY, CU, CV: LongInt;
begin
CY := Y - 16;
CU := U - 128;
CV := V - 128;
R := ClampToByte(Round(1.164 * CY - 0.002 * CU + 1.596 * CV));
G := ClampToByte(Round(1.164 * CY - 0.391 * CU - 0.813 * CV));
B := ClampToByte(Round(1.164 * CY + 2.018 * CU - 0.001 * CV));
end;
procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
begin
Y := ClampToByte(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
Cb := ClampToByte(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 128));
Cr := ClampToByte(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 128));
end;
procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
begin
R := ClampToByte(Round(Y + 1.40200 * (Cr - 128)));
G := ClampToByte(Round(Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128)));
B := ClampToByte(Round(Y + 1.77200 * (Cb - 128)));
end;
procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
begin
Y := ClampToWord(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
Cb := ClampToWord(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 32768));
Cr := ClampToWord(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 32768));
end;
procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
begin
R := ClampToWord(Round(Y + 1.40200 * (Cr - 32768)));
G := ClampToWord(Round(Y - 0.34414 * (Cb - 32768) - 0.71414 * (Cr - 32768)));
B := ClampToWord(Round(Y + 1.77200 * (Cb - 32768)));
end;
procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
begin
C := 255 - R;
M := 255 - G;
Y := 255 - B;
end;
procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
begin
R := 255 - C;
G := 255 - M;
B := 255 - Y;
end;
procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
begin
C := 65535 - R;
M := 65535 - G;
Y := 65535 - B;
end;
procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
begin
R := 65535 - C;
G := 65535 - M;
B := 65535 - Y;
end;
procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
begin
RGBToCMY(R, G, B, C, M, Y);
K := Min(C, Min(M, Y));
if K > 0 then
begin
C := C - K;
M := M - K;
Y := Y - K;
end;
end;
procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
begin
R := (255 - (C - MulDiv(C, K, 255) + K));
G := (255 - (M - MulDiv(M, K, 255) + K));
B := (255 - (Y - MulDiv(Y, K, 255) + K));
end;
procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
begin
RGBToCMY16(R, G, B, C, M, Y);
K := Min(C, Min(M, Y));
if K > 0 then
begin
C := C - K;
M := M - K;
Y := Y - K;
end;
end;
procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
begin
R := 65535 - (C - MulDiv(C, K, 65535) + K);
G := 65535 - (M - MulDiv(M, K, 65535) + K);
B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
end;
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added RGB<>CMY(K) converion functions for 16 bit channels
(needed by PSD loading code).
-- 0.21 Changes/Bug Fixes -----------------------------------
- Added some color space conversion functions and LUTs
(RGB/YUV/YCrCb/CMY/CMYK).
-- 0.17 Changes/Bug Fixes -----------------------------------
- unit created (empty!)
}
end.

1293
Imaging/ImagingComponents.pas Normal file
View File

File diff suppressed because it is too large Load Diff

853
Imaging/ImagingDds.pas Normal file
View File

@@ -0,0 +1,853 @@
{
$Id: ImagingDds.pas 100 2007-06-28 21:09:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for DirectDraw Surface images.}
unit ImagingDds;
{$I ImagingOptions.inc}
interface
uses
ImagingTypes, Imaging, ImagingUtility, ImagingFormats;
type
{ Class for loading and saving Microsoft DirectDraw surfaces.
It can load/save all D3D formats which have coresponding
TImageFormat. It supports plain textures, cube textures and
volume textures, all of these can have mipmaps. It can also
load some formats which have no exact TImageFormat, but can be easily
converted to one (bump map formats).
You can get some information about last loaded DDS file by calling
GetOption with ImagingDDSLoadedXXX options and you can set some
saving options by calling SetOption with ImagingDDSSaveXXX or you can
simply use properties of this class.
Note that when saving cube maps and volumes input image array must contain
at least number of images to build cube/volume based on current
Depth and MipMapCount settings.}
TDDSFileFormat = class(TImageFileFormat)
protected
FLoadedCubeMap: LongBool;
FLoadedVolume: LongBool;
FLoadedMipMapCount: LongInt;
FLoadedDepth: LongInt;
FSaveCubeMap: LongBool;
FSaveVolume: LongBool;
FSaveMipMapCount: LongInt;
FSaveDepth: LongInt;
procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
{ True if last loaded DDS file was cube map.}
property LoadedCubeMap: LongBool read FLoadedCubeMap write FLoadedCubeMap;
{ True if last loaded DDS file was volume texture.}
property LoadedVolume: LongBool read FLoadedVolume write FLoadedVolume;
{ Number of mipmap levels of last loaded DDS image.}
property LoadedMipMapCount: LongInt read FLoadedMipMapCount write FLoadedMipMapCount;
{ Depth (slices of volume texture or faces of cube map) of last loaded DDS image.}
property LoadedDepth: LongInt read FLoadedDepth write FLoadedDepth;
{ True if next DDS file to be saved should be stored as cube map.}
property SaveCubeMap: LongBool read FSaveCubeMap write FSaveCubeMap;
{ True if next DDS file to be saved should be stored as volume texture.}
property SaveVolume: LongBool read FSaveVolume write FSaveVolume;
{ Sets the number of mipmaps which should be stored in the next saved DDS file.
Only applies to cube maps and volumes, ordinary 2D textures save all
levels present in input.}
property SaveMipMapCount: LongInt read FSaveMipMapCount write FSaveMipMapCount;
{ Sets the depth (slices of volume texture or faces of cube map)
of the next saved DDS file.}
property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
end;
implementation
const
SDDSFormatName = 'DirectDraw Surface';
SDDSMasks = '*.dds';
DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8,
ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16,
ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8,
ifGray16, ifDXT1, ifDXT3, ifDXT5];
const
{ Four character codes.}
DDSMagic = LongWord(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or
(Byte(' ') shl 24));
FOURCC_DXT1 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('1') shl 24));
FOURCC_DXT3 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('3') shl 24));
FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('5') shl 24));
{ Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36;
D3DFMT_R32F = 114;
D3DFMT_A32B32G32R32F = 116;
D3DFMT_R16F = 111;
D3DFMT_A16B16G16R16F = 113;
{ Constans used by TDDSurfaceDesc2.Flags.}
DDSD_CAPS = $00000001;
DDSD_HEIGHT = $00000002;
DDSD_WIDTH = $00000004;
DDSD_PITCH = $00000008;
DDSD_PIXELFORMAT = $00001000;
DDSD_MIPMAPCOUNT = $00020000;
DDSD_LINEARSIZE = $00080000;
DDSD_DEPTH = $00800000;
{ Constans used by TDDSPixelFormat.Flags.}
DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha
DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats
DDPF_RGB = $00000040; // used by RGB formats
DDPF_LUMINANCE = $00020000; // used by formats like D3DFMT_L16
DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats
DDPF_BUMPDUDV = $00080000; // used by signed formats
{ Constans used by TDDSCaps.Caps1.}
DDSCAPS_COMPLEX = $00000008;
DDSCAPS_TEXTURE = $00001000;
DDSCAPS_MIPMAP = $00400000;
{ Constans used by TDDSCaps.Caps2.}
DDSCAPS2_CUBEMAP = $00000200;
DDSCAPS2_POSITIVEX = $00000400;
DDSCAPS2_NEGATIVEX = $00000800;
DDSCAPS2_POSITIVEY = $00001000;
DDSCAPS2_NEGATIVEY = $00002000;
DDSCAPS2_POSITIVEZ = $00004000;
DDSCAPS2_NEGATIVEZ = $00008000;
DDSCAPS2_VOLUME = $00200000;
{ Flags for TDDSurfaceDesc2.Flags used when saving DDS file.}
DDS_SAVE_FLAGS = DDSD_CAPS or DDSD_PIXELFORMAT or DDSD_WIDTH or
DDSD_HEIGHT or DDSD_LINEARSIZE;
type
{ Stores the pixel format information.}
TDDPixelFormat = packed record
Size: LongWord; // Size of the structure = 32 bytes
Flags: LongWord; // Flags to indicate valid fields
FourCC: LongWord; // Four-char code for compressed textures (DXT)
BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32
RedMask: LongWord; // Bit mask for the Red component
GreenMask: LongWord; // Bit mask for the Green component
BlueMask: LongWord; // Bit mask for the Blue component
AlphaMask: LongWord; // Bit mask for the Alpha component
end;
{ Specifies capabilities of surface.}
TDDSCaps = packed record
Caps1: LongWord; // Should always include DDSCAPS_TEXTURE
Caps2: LongWord; // For cubic environment maps
Reserved: array[0..1] of LongWord; // Reserved
end;
{ Record describing DDS file contents.}
TDDSurfaceDesc2 = packed record
Size: LongWord; // Size of the structure = 124 Bytes
Flags: LongWord; // Flags to indicate valid fields
Height: LongWord; // Height of the main image in pixels
Width: LongWord; // Width of the main image in pixels
PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per
// scanline. For comp it is the size in
// bytes of the main image
Depth: LongWord; // Only for volume text depth of the volume
MipMaps: LongInt; // Total number of levels in the mipmap chain
Reserved1: array[0..10] of LongWord; // Reserved
PixelFormat: TDDPixelFormat; // Format of the pixel data
Caps: TDDSCaps; // Capabilities
Reserved2: LongWord; // Reserved
end;
{ DDS file header.}
TDDSFileHeader = packed record
Magic: LongWord; // File format magic
Desc: TDDSurfaceDesc2; // Surface description
end;
{ TDDSFileFormat class implementation }
constructor TDDSFileFormat.Create;
begin
inherited Create;
FName := SDDSFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := True;
FSupportedFormats := DDSSupportedFormats;
FSaveCubeMap := False;
FSaveVolume := False;
FSaveMipMapCount := 1;
FSaveDepth := 1;
AddMasks(SDDSMasks);
RegisterOption(ImagingDDSLoadedCubeMap, @FLoadedCubeMap);
RegisterOption(ImagingDDSLoadedVolume, @FLoadedVolume);
RegisterOption(ImagingDDSLoadedMipMapCount, @FLoadedMipMapCount);
RegisterOption(ImagingDDSLoadedDepth, @FLoadedDepth);
RegisterOption(ImagingDDSSaveCubeMap, @FSaveCubeMap);
RegisterOption(ImagingDDSSaveVolume, @FSaveVolume);
RegisterOption(ImagingDDSSaveMipMapCount, @FSaveMipMapCount);
RegisterOption(ImagingDDSSaveDepth, @FSaveDepth);
end;
procedure TDDSFileFormat.CheckOptionsValidity;
begin
if FSaveCubeMap then
FSaveVolume := False;
if FSaveVolume then
FSaveCubeMap := False;
if FSaveDepth < 1 then
FSaveDepth := 1;
if FSaveMipMapCount < 1 then
FSaveMipMapCount := 1;
end;
procedure TDDSFileFormat.ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
var
I, Last, Shift: LongInt;
begin
CurWidth := Width;
CurHeight := Height;
if MipMaps > 1 then
begin
if not IsVolume then
begin
if IsCubeMap then
begin
// Cube maps are stored like this
// Face 0 mimap 0
// Face 0 mipmap 1
// ...
// Face 1 mipmap 0
// Face 1 mipmap 1
// ...
// Modify index so later in for loop we iterate less times
Idx := Idx - ((Idx div MipMaps) * MipMaps);
end;
for I := 0 to Idx - 1 do
begin
CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
end;
end
else
begin
// Volume textures are stored in DDS files like this:
// Slice 0 mipmap 0
// Slice 1 mipmap 0
// Slice 2 mipmap 0
// Slice 3 mipmap 0
// Slice 0 mipmap 1
// Slice 1 mipmap 1
// Slice 0 mipmap 2
// Slice 0 mipmap 3 ...
Shift := 0;
Last := Depth;
while Idx > Last - 1 do
begin
CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
if (CurWidth = 1) and (CurHeight = 1) then
Break;
Inc(Shift);
Inc(Last, ClampInt(Depth shr Shift, 1, Depth));
end;
end;
end;
end;
function TDDSFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Hdr: TDDSFileHeader;
SrcFormat: TImageFormat;
FmtInfo: TImageFormatInfo;
NeedsSwapChannels: Boolean;
CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt;
Data: PByte;
UseAsPitch: Boolean;
UseAsLinear: Boolean;
function MasksEqual(const DDPF: TDDPixelFormat; PF: PPixelFormatInfo): Boolean;
begin
Result := (DDPF.AlphaMask = PF.ABitMask) and
(DDPF.RedMask = PF.RBitMask) and (DDPF.GreenMask = PF.GBitMask) and
(DDPF.BlueMask = PF.BBitMask);
end;
begin
Result := False;
ImageCount := 1;
FLoadedMipMapCount := 1;
FLoadedDepth := 1;
FLoadedVolume := False;
FLoadedCubeMap := False;
with GetIO, Hdr, Hdr.Desc.PixelFormat do
begin
Read(Handle, @Hdr, SizeOF(Hdr));
{
// Set position to the end of the header (for possible future versions
// ith larger header)
Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
smFromCurrent);
}
SrcFormat := ifUnknown;
NeedsSwapChannels := False;
// Get image data format
if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
begin
// Handle FourCC and large ARGB formats
case FourCC of
D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16;
D3DFMT_R32F: SrcFormat := ifR32F;
D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F;
D3DFMT_R16F: SrcFormat := ifR16F;
D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F;
FOURCC_DXT1: SrcFormat := ifDXT1;
FOURCC_DXT3: SrcFormat := ifDXT3;
FOURCC_DXT5: SrcFormat := ifDXT5;
end;
end
else if (Flags and DDPF_RGB) = DDPF_RGB then
begin
// Handle RGB formats
if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
begin
// Handle RGB with alpha formats
case BitCount of
16:
begin
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifA4R4G4B4).PixelFormat) then
SrcFormat := ifA4R4G4B4;
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifA1R5G5B5).PixelFormat) then
SrcFormat := ifA1R5G5B5;
end;
32:
begin
SrcFormat := ifA8R8G8B8;
if BlueMask = $00FF0000 then
NeedsSwapChannels := True;
end;
end;
end
else
begin
// Handle RGB without alpha formats
case BitCount of
8:
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifR3G3B2).PixelFormat) then
SrcFormat := ifR3G3B2;
16:
begin
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifX4R4G4B4).PixelFormat) then
SrcFormat := ifX4R4G4B4;
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifX1R5G5B5).PixelFormat) then
SrcFormat := ifX1R5G5B5;
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifR5G6B5).PixelFormat) then
SrcFormat := ifR5G6B5;
end;
24: SrcFormat := ifR8G8B8;
32:
begin
SrcFormat := ifX8R8G8B8;
if BlueMask = $00FF0000 then
NeedsSwapChannels := True;
end;
end;
end;
end
else if (Flags and DDPF_LUMINANCE) = DDPF_LUMINANCE then
begin
// Handle luminance formats
if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
begin
// Handle luminance with alpha formats
if BitCount = 16 then
SrcFormat := ifA8Gray8;
end
else
begin
// Handle luminance without alpha formats
case BitCount of
8: SrcFormat := ifGray8;
16: SrcFormat := ifGray16;
end;
end;
end
else if (Flags and DDPF_BUMPLUMINANCE) = DDPF_BUMPLUMINANCE then
begin
// Handle mixed bump-luminance formats like D3DFMT_X8L8V8U8
case BitCount of
32:
if BlueMask = $00FF0000 then
begin
SrcFormat := ifX8R8G8B8; // D3DFMT_X8L8V8U8
NeedsSwapChannels := True;
end;
end;
end
else if (Flags and DDPF_BUMPDUDV) = DDPF_BUMPDUDV then
begin
// Handle bumpmap formats like D3DFMT_Q8W8V8U8
case BitCount of
16: SrcFormat := ifA8Gray8; // D3DFMT_V8U8
32:
if AlphaMask = $FF000000 then
begin
SrcFormat := ifA8R8G8B8; // D3DFMT_Q8W8V8U8
NeedsSwapChannels := True;
end;
64: SrcFormat := ifA16B16G16R16; // D3DFMT_Q16W16V16U16
end;
end;
// If DDS format is not supported we will exit
if SrcFormat = ifUnknown then Exit;
// File contains mipmaps for each subimage.
{ Some DDS writers ignore setting proper Caps and Flags so
this check is not usable:
if ((Desc.Caps.Caps1 and DDSCAPS_MIPMAP) = DDSCAPS_MIPMAP) and
((Desc.Flags and DDSD_MIPMAPCOUNT) = DDSD_MIPMAPCOUNT) then}
if Desc.MipMaps > 1 then
begin
FLoadedMipMapCount := Desc.MipMaps;
ImageCount := Desc.MipMaps;
end;
// File stores volume texture
if ((Desc.Caps.Caps2 and DDSCAPS2_VOLUME) = DDSCAPS2_VOLUME) and
((Desc.Flags and DDSD_DEPTH) = DDSD_DEPTH) then
begin
FLoadedVolume := True;
FLoadedDepth := Desc.Depth;
ImageCount := GetVolumeLevelCount(Desc.Depth, ImageCount);
end;
// File stores cube texture
if (Desc.Caps.Caps2 and DDSCAPS2_CUBEMAP) = DDSCAPS2_CUBEMAP then
begin
FLoadedCubeMap := True;
I := 0;
if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEX) = DDSCAPS2_POSITIVEX then Inc(I);
if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEY) = DDSCAPS2_POSITIVEY then Inc(I);
if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEZ) = DDSCAPS2_POSITIVEZ then Inc(I);
if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEX) = DDSCAPS2_NEGATIVEX then Inc(I);
if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEY) = DDSCAPS2_NEGATIVEY then Inc(I);
if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEZ) = DDSCAPS2_NEGATIVEZ then Inc(I);
FLoadedDepth := I;
ImageCount := ImageCount * I;
end;
// Allocate and load all images in file
FmtInfo := GetFormatInfo(SrcFormat);
SetLength(Images, ImageCount);
// Compute the pitch or get if from file if present
UseAsPitch := (Desc.Flags and DDSD_PITCH) = DDSD_PITCH;
UseAsLinear := (Desc.Flags and DDSD_LINEARSIZE) = DDSD_LINEARSIZE;
// Use linear as default if none is set
if not UseAsPitch and not UseAsLinear then
UseAsLinear := True;
// Main image pitch or linear size
PitchOrLinear := Desc.PitchOrLinearSize;
for I := 0 to ImageCount - 1 do
begin
// Compute dimensions of surrent subimage based on texture type and
// number of mipmaps
ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
if (I > 0) or (PitchOrLinear = 0) then
begin
// Compute pitch or linear size for mipmap levels, or even for main image
// since some formats do not fill pitch nor size
if UseAsLinear then
PitchOrLinear := FmtInfo.GetPixelsSize(SrcFormat, CurrentWidth, CurrentHeight)
else
PitchOrLinear := (CurrentWidth * FmtInfo.BytesPerPixel + 3) div 4 * 4; // must be DWORD aligned
end;
if UseAsLinear then
LoadSize := PitchOrLinear
else
LoadSize := CurrentHeight * PitchOrLinear;
if UseAsLinear or (LoadSize = Images[I].Size) then
begin
// If DDS does not use Pitch we can simply copy data
Read(Handle, Images[I].Bits, LoadSize)
end
else
begin
// If DDS uses Pitch we must load aligned scanlines
// and then remove padding
GetMem(Data, LoadSize);
try
Read(Handle, Data, LoadSize);
RemovePadBytes(Data, Images[I].Bits, CurrentWidth, CurrentHeight,
FmtInfo.BytesPerPixel, PitchOrLinear);
finally
FreeMem(Data);
end;
end;
if NeedsSwapChannels then
SwapChannels(Images[I], ChannelRed, ChannelBlue);
end;
Result := True;
end;
end;
function TDDSFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
Hdr: TDDSFileHeader;
MainImage, ImageToSave: TImageData;
I, MainIdx, Len, ImageCount: LongInt;
J: LongWord;
FmtInfo: TImageFormatInfo;
MustBeFreed: Boolean;
Is2DTexture, IsCubeMap, IsVolume: Boolean;
MipMapCount, CurrentWidth, CurrentHeight: LongInt;
NeedsResize: Boolean;
NeedsConvert: Boolean;
begin
Result := False;
FillChar(Hdr, Sizeof(Hdr), 0);
MainIdx := FFirstIdx;
Len := FLastIdx - MainIdx + 1;
// Some DDS saving rules:
// 2D textures: Len is used as mipmap count (FSaveMipMapCount not used!).
// Cube maps: FSaveDepth * FSaveMipMapCount images are used, if Len is
// smaller than this file is saved as regular 2D texture.
// Volume maps: GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) images are
// used, if Len is smaller than this file is
// saved as regular 2D texture.
IsCubeMap := FSaveCubeMap;
IsVolume := FSaveVolume;
MipMapCount := FSaveMipMapCount;
if IsCubeMap then
begin
// Check if we have enough images on Input to save cube map
if Len < FSaveDepth * FSaveMipMapCount then
IsCubeMap := False;
end
else if IsVolume then
begin
// Check if we have enough images on Input to save volume texture
if Len < GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) then
IsVolume := False;
end;
Is2DTexture := not IsCubeMap and not IsVolume;
if Is2DTexture then
begin
// Get number of mipmaps used with 2D texture
MipMapCount := Min(Len, GetNumMipMapLevels(Images[MainIdx].Width, Images[MainIdx].Height));
end;
// we create compatible main image and fill headers
if MakeCompatible(Images[MainIdx], MainImage, MustBeFreed) then
with GetIO, MainImage, Hdr do
try
FmtInfo := GetFormatInfo(Format);
Magic := DDSMagic;
Desc.Size := SizeOf(Desc);
Desc.Width := Width;
Desc.Height := Height;
Desc.Flags := DDS_SAVE_FLAGS;
Desc.Caps.Caps1 := DDSCAPS_TEXTURE;
Desc.PixelFormat.Size := SizeOf(Desc.PixelFormat);
Desc.PitchOrLinearSize := MainImage.Size;
ImageCount := MipMapCount;
if MipMapCount > 1 then
begin
// Set proper flags if we have some mipmaps to be saved
Desc.Flags := Desc.Flags or DDSD_MIPMAPCOUNT;
Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
Desc.MipMaps := MipMapCount;
end;
if IsCubeMap then
begin
// Set proper cube map flags - number of stored faces is taken
// from FSaveDepth
Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_CUBEMAP;
J := DDSCAPS2_POSITIVEX;
for I := 0 to FSaveDepth - 1 do
begin
Desc.Caps.Caps2 := Desc.Caps.Caps2 or J;
J := J shl 1;
end;
ImageCount := FSaveDepth * FSaveMipMapCount;
end
else if IsVolume then
begin
// Set proper flags for volume texture
Desc.Flags := Desc.Flags or DDSD_DEPTH;
Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_VOLUME;
Desc.Depth := FSaveDepth;
ImageCount := GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount);
end;
// Now we set DDS pixel format for main image
if FmtInfo.IsSpecial or FmtInfo.IsFloatingPoint or
(FmtInfo.BytesPerPixel > 4) then
begin
Desc.PixelFormat.Flags := DDPF_FOURCC;
case Format of
ifA16B16G16R16: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16;
ifR32F: Desc.PixelFormat.FourCC := D3DFMT_R32F;
ifA32B32G32R32F: Desc.PixelFormat.FourCC := D3DFMT_A32B32G32R32F;
ifR16F: Desc.PixelFormat.FourCC := D3DFMT_R16F;
ifA16B16G16R16F: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16F;
ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1;
ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3;
ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5;
end;
end
else if FmtInfo.HasGrayChannel then
begin
Desc.PixelFormat.Flags := DDPF_LUMINANCE;
Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
case Format of
ifGray8: Desc.PixelFormat.RedMask := 255;
ifGray16: Desc.PixelFormat.RedMask := 65535;
ifA8Gray8:
begin
Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
Desc.PixelFormat.RedMask := 255;
Desc.PixelFormat.AlphaMask := 65280;
end;
end;
end
else
begin
Desc.PixelFormat.Flags := DDPF_RGB;
Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
if FmtInfo.HasAlphaChannel then
begin
Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
Desc.PixelFormat.AlphaMask := $FF000000;
end;
if FmtInfo.BytesPerPixel > 2 then
begin
Desc.PixelFormat.RedMask := $00FF0000;
Desc.PixelFormat.GreenMask := $0000FF00;
Desc.PixelFormat.BlueMask := $000000FF;
end
else
begin
Desc.PixelFormat.AlphaMask := FmtInfo.PixelFormat.ABitMask;
Desc.PixelFormat.RedMask := FmtInfo.PixelFormat.RBitMask;
Desc.PixelFormat.GreenMask := FmtInfo.PixelFormat.GBitMask;
Desc.PixelFormat.BlueMask := FmtInfo.PixelFormat.BBitMask;
end;
end;
// Header and main image are written to output
Write(Handle, @Hdr, SizeOf(Hdr));
Write(Handle, MainImage.Bits, MainImage.Size);
// Write the rest of the images and convert them to
// the same format as main image if necessary and ensure proper mipmap
// simensions too.
for I := MainIdx + 1 to MainIdx + ImageCount - 1 do
begin
// Get proper dimensions for this level
ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
IsCubeMap, IsVolume, CurrentWidth, CurrentHeight);
// Check if input image for this level has the right size and format
NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight));
NeedsConvert := not (Images[I].Format = Format);
if NeedsResize or NeedsConvert then
begin
// Input image must be resized or converted to different format
// to become valid mipmap level
InitImage(ImageToSave);
CloneImage(Images[I], ImageToSave);
if NeedsConvert then
ConvertImage(ImageToSave, Format);
if NeedsResize then
ResizeImage(ImageToSave, CurrentWidth, CurrentHeight, rfBilinear);
end
else
// Input image can be used without any changes
ImageToSave := Images[I];
// Write level data and release temp image if necessary
Write(Handle, ImageToSave.Bits, ImageToSave.Size);
if Images[I].Bits <> ImageToSave.Bits then
FreeImage(ImageToSave);
end;
Result := True;
finally
if MustBeFreed then
FreeImage(MainImage);
end;
end;
procedure TDDSFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsIndexed or Info.IsSpecial then
// convert indexed and unsupported special formatd to A8R8G8B8
ConvFormat := ifA8R8G8B8
else if Info.IsFloatingPoint then
begin
if Info.Format = ifA16R16G16B16F then
// only swap channels here
ConvFormat := ifA16B16G16R16F
else
// convert other floating point formats to A32B32G32R32F
ConvFormat := ifA32B32G32R32F
end
else if Info.HasGrayChannel then
begin
if Info.HasAlphaChannel then
// convert grayscale with alpha to A8Gray8
ConvFormat := ifA8Gray8
else if Info.BytesPerPixel = 1 then
// convert 8bit grayscale to Gray8
ConvFormat := ifGray8
else
// convert 16-64bit grayscales to Gray16
ConvFormat := ifGray16;
end
else if Info.BytesPerPixel > 4 then
ConvFormat := ifA16B16G16R16
else if Info.HasAlphaChannel then
// convert the other images with alpha channel to A8R8G8B8
ConvFormat := ifA8R8G8B8
else
// convert the other formats to X8R8G8B8
ConvFormat := ifX8R8G8B8;
ConvertImage(Image, ConvFormat);
end;
function TDDSFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Hdr: TDDSFileHeader;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (Hdr.Magic = DDSMagic) and (ReadCount = SizeOf(Hdr)) and
((Hdr.Desc.Caps.Caps1 and DDSCAPS_TEXTURE) = DDSCAPS_TEXTURE);
end;
end;
initialization
RegisterImageFileFormat(TDDSFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.23 Changes/Bug Fixes -----------------------------------
- Saved DDS with mipmaps now correctly defineds COMPLEX flag.
- Fixed loading of RGB DDS files that use pitch and have mipmaps -
mipmaps were loaded wrongly.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Changed saving behaviour a bit: mipmaps are inlcuded automatically for
2D textures if input image array has more than 1 image (no need to
set SaveMipMapCount manually).
- Mipmap levels are now saved with proper dimensions when saving DDS files.
- Made some changes to not be so strict when loading DDS files.
Many programs seem to save them in non-standard format
(by MS DDS File Reference).
- Added missing ifX8R8G8B8 to SupportedFormats, MakeCompatible failed
when image was converted to this format (inside).
- MakeCompatible method moved to base class, put ConvertToSupported here.
GetSupportedFormats removed, it is now set in constructor.
- Fixed bug that sometimes saved non-standard DDS files and another
one that caused crash when these files were loaded.
- Changed extensions to filename masks.
- Changed SaveData, LoadData, and MakeCompatible methods according
to changes in base class in Imaging unit.
-- 0.19 Changes/Bug Fixes -----------------------------------
- added support for half-float image formats
- change in LoadData to allow support for more images
in one stream loading
-- 0.17 Changes/Bug Fixes -----------------------------------
- fixed bug in TestFormat which does not recognize many DDS files
- changed pitch/linearsize handling in DDS loading code to
load DDS files produced by NVidia's Photoshop plugin
}
end.

887
Imaging/ImagingExport.pas Normal file
View File

@@ -0,0 +1,887 @@
{
$Id: ImagingExport.pas 71 2007-03-08 00:10:10Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This function contains functions exported from Imaging dynamic link library.
All string are exported as PChars and all var parameters are exported
as pointers. All posible exceptions getting out of dll are catched.}
unit ImagingExport;
{$I ImagingOptions.inc}
interface
uses
ImagingTypes,
Imaging;
{ Returns version of Imaging library. }
procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl;
{ Look at InitImage for details.}
procedure ImInitImage(var Image: TImageData); cdecl;
{ Look at NewImage for details.}
function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
var Image: TImageData): Boolean; cdecl;
{ Look at TestImage for details.}
function ImTestImage(var Image: TImageData): Boolean; cdecl;
{ Look at FreeImage for details.}
function ImFreeImage(var Image: TImageData): Boolean; cdecl;
{ Look at DetermineFileFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineFileFormat(FileName, Ext: PChar): Boolean; cdecl;
{ Look at DetermineMemoryFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; cdecl;
{ Look at IsFileFormatSupported for details.}
function ImIsFileFormatSupported(FileName: PChar): Boolean; cdecl;
{ Look at EnumFileFormats for details.}
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
{ Inits image list.}
function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl;
{ Returns size of image list.}
function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl;
{ Returns image list's element at given index. Output image is not cloned it's
Bits point to Bits in list => do not free OutImage.}
function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
var OutImage: TImageData): Boolean; cdecl;
{ Sets size of image list.}
function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl;
{ Sets image list element at given index. Input image is not cloned - image in
list will point to InImage's Bits.}
function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
const InImage: TImageData): Boolean; cdecl;
{ Returns True if all images in list pass ImTestImage test. }
function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
{ Frees image list and all images in it.}
function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadImageFromFile for details.}
function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean; cdecl;
{ Look at LoadImageFromMemory for details.}
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
{ Look at LoadMultiImageFromFile for details.}
function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadMultiImageFromMemory for details.}
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveImageToFile for details.}
function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean; cdecl;
{ Look at SaveImageToMemory for details.}
function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean; cdecl;
{ Look at SaveMultiImageToFile for details.}
function ImSaveMultiImageToFile(FileName: PChar; ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveMultiImageToMemory for details.}
function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean; cdecl;
{ Look at CloneImage for details.}
function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl;
{ Look at ConvertImage for details.}
function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl;
{ Look at FlipImage for details.}
function ImFlipImage(var Image: TImageData): Boolean; cdecl;
{ Look at MirrorImage for details.}
function ImMirrorImage(var Image: TImageData): Boolean; cdecl;
{ Look at ResizeImage for details.}
function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
Filter: TResizeFilter): Boolean; cdecl;
{ Look at SwapChannels for details.}
function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl;
{ Look at ReduceColors for details.}
function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl;
{ Look at GenerateMipMaps for details.}
function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TImageDataList): Boolean; cdecl;
{ Look at MapImageToPalette for details.}
function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
Entries: LongInt): Boolean; cdecl;
{ Look at SplitImage for details.}
function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl;
{ Look at MakePaletteForImages for details.}
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
{ Look at RotateImage for details.}
function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean; cdecl;
{ Look at CopyRect for details.}
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
{ Look at FillRect for details.}
function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
Fill: Pointer): Boolean; cdecl;
{ Look at ReplaceColor for details.}
function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
OldPixel, NewPixel: Pointer): Boolean; cdecl;
{ Look at StretchRect for details.}
function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
{ Look at GetPixelDirect for details.}
procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
{ Look at SetPixelDirect for details.}
procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
{ Look at GetPixel32 for details.}
function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
{ Look at SetPixel32 for details.}
procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl;
{ Look at GetPixelFP for details.}
function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
{ Look at SetPixelFP for details.}
procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl;
{ Look at NewPalette for details.}
function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl;
{ Look at FreePalette for details.}
function ImFreePalette(var Pal: PPalette32): Boolean; cdecl;
{ Look at CopyPalette for details.}
function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl;
{ Look at FindColor for details.}
function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl;
{ Look at FillGrayscalePalette for details.}
function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl;
{ Look at FillCustomPalette for details.}
function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
BBits: Byte; Alpha: Byte): Boolean; cdecl;
{ Look at SwapChannelsOfPalette for details.}
function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
DstChannel: LongInt): Boolean; cdecl;
{ Look at SetOption for details.}
function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl;
{ Look at GetOption for details.}
function ImGetOption(OptionId: LongInt): LongInt; cdecl;
{ Look at PushOptions for details.}
function ImPushOptions: Boolean; cdecl;
{ Look at PopOptions for details.}
function ImPopOptions: Boolean; cdecl;
{ Look at GetImageFormatInfo for details.}
function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl;
{ Look at GetPixelsSize for details.}
function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl;
{ Look at SetUserFileIO for details.}
procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl;
{ Look at ResetFileIO for details.}
procedure ImResetFileIO; cdecl;
{ These are only for documentation generation reasons.}
{ Loads Imaging functions from dll/so library.}
function ImLoadLibrary: Boolean;
{ Frees Imaging functions loaded from dll/so and releases library.}
function ImFreeLibrary: Boolean;
implementation
uses
SysUtils,
ImagingUtility;
function ImLoadLibrary: Boolean; begin Result := True; end;
function ImFreeLibrary: Boolean; begin Result := True; end;
type
TInternalList = record
List: TDynImageDataArray;
end;
PInternalList = ^TInternalList;
procedure ImGetVersion(var Major, Minor, Patch: LongInt);
begin
Major := ImagingVersionMajor;
Minor := ImagingVersionMinor;
Patch := ImagingVersionPatch;
end;
procedure ImInitImage(var Image: TImageData);
begin
try
Imaging.InitImage(Image);
except
end;
end;
function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
var Image: TImageData): Boolean;
begin
try
Result := Imaging.NewImage(Width, Height, Format, Image);
except
Result := False;
end;
end;
function ImTestImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.TestImage(Image);
except
Result := False;
end;
end;
function ImFreeImage(var Image: TImageData): Boolean;
begin
try
Imaging.FreeImage(Image);
Result := True;
except
Result := False;
end;
end;
function ImDetermineFileFormat(FileName, Ext: PChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineFileFormat(FileName);
Result := S <> '';
StrCopy(Ext, PChar(S));
except
Result := False;
end;
end;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineMemoryFormat(Data, Size);
Result := S <> '';
StrCopy(Ext, PChar(S));
except
Result := False;
end;
end;
function ImIsFileFormatSupported(FileName: PChar): Boolean;
begin
try
Result := Imaging.IsFileFormatSupported(FileName);
except
Result := False;
end;
end;
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean;
var
StrName, StrDefaultExt, StrMasks: string;
begin
try
Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
IsMultiImageFormat);
StrCopy(Name, PChar(StrName));
StrCopy(DefaultExt, PChar(StrDefaultExt));
StrCopy(Masks, PChar(StrMasks));
except
Result := False;
end;
end;
function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean;
var
Int: PInternalList;
begin
try
try
ImFreeImageList(ImageList);
except
end;
New(Int);
SetLength(Int.List, Size);
ImageList := TImageDataList(Int);
Result := True;
except
Result := False;
ImageList := nil;
end;
end;
function ImGetImageListSize(ImageList: TImageDataList): LongInt;
begin
try
Result := Length(PInternalList(ImageList).List);
except
Result := -1;
end;
end;
function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
var OutImage: TImageData): Boolean;
begin
try
Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
ImCloneImage(PInternalList(ImageList).List[Index], OutImage);
Result := True;
except
Result := False;
end;
end;
function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt):
Boolean;
var
I, OldSize: LongInt;
begin
try
OldSize := Length(PInternalList(ImageList).List);
if NewSize < OldSize then
for I := NewSize to OldSize - 1 do
Imaging.FreeImage(PInternalList(ImageList).List[I]);
SetLength(PInternalList(ImageList).List, NewSize);
Result := True;
except
Result := False;
end;
end;
function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
const InImage: TImageData): Boolean;
begin
try
Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
ImCloneImage(InImage, PInternalList(ImageList).List[Index]);
Result := True;
except
Result := False;
end;
end;
function ImTestImagesInList(ImageList: TImageDataList): Boolean;
var
I: LongInt;
Arr: TDynImageDataArray;
begin
Arr := nil;
try
Arr := PInternalList(ImageList).List;
Result := True;
for I := 0 to Length(Arr) - 1 do
begin
Result := Result and Imaging.TestImage(Arr[I]);
if not Result then Break;
end;
except
Result := False;
end;
end;
function ImFreeImageList(var ImageList: TImageDataList): Boolean;
var
Int: PInternalList;
begin
try
if ImageList <> nil then
begin
Int := PInternalList(ImageList);
FreeImagesInArray(Int.List);
Dispose(Int);
ImageList := nil;
end;
Result := True;
except
Result := False;
end;
end;
function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean;
begin
try
Result := Imaging.LoadImageFromFile(FileName, Image);
except
Result := False;
end;
end;
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
begin
try
Result := Imaging.LoadImageFromMemory(Data, Size, Image);
except
Result := False;
end;
end;
function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList):
Boolean;
begin
try
ImInitImageList(0, ImageList);
Result := Imaging.LoadMultiImageFromFile(FileName,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean;
begin
try
ImInitImageList(0, ImageList);
Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean;
begin
try
Result := Imaging.SaveImageToFile(FileName, Image);
except
Result := False;
end;
end;
function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean;
begin
try
Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image);
except
Result := False;
end;
end;
function ImSaveMultiImageToFile(FileName: PChar;
ImageList: TImageDataList): Boolean;
begin
try
Result := Imaging.SaveMultiImageToFile(FileName,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean;
begin
try
Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
begin
try
Result := Imaging.CloneImage(Image, Clone);
except
Result := False;
end;
end;
function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
begin
try
Result := Imaging.ConvertImage(Image, DestFormat);
except
Result := False;
end;
end;
function ImFlipImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.FlipImage(Image);
except
Result := False;
end;
end;
function ImMirrorImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.MirrorImage(Image);
except
Result := False;
end;
end;
function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
Filter: TResizeFilter): Boolean;
begin
try
Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter);
except
Result := False;
end;
end;
function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt):
Boolean;
begin
try
Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel);
except
Result := False;
end;
end;
function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
begin
try
Result := Imaging.ReduceColors(Image, MaxColors);
except
Result := False;
end;
end;
function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TImageDataList): Boolean;
begin
try
ImInitImageList(0, MipMaps);
Result := Imaging.GenerateMipMaps(Image, Levels,
PInternalList(MipMaps).List);
except
Result := False;
end;
end;
function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
Entries: LongInt): Boolean;
begin
try
Result := Imaging.MapImageToPalette(Image, Pal, Entries);
except
Result := False;
end;
end;
function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
PreserveSize: Boolean; Fill: Pointer): Boolean;
begin
try
ImInitImageList(0, Chunks);
Result := Imaging.SplitImage(Image, PInternalList(Chunks).List,
ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill);
except
Result := False;
end;
end;
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean;
begin
try
Result := Imaging.MakePaletteForImages(PInternalList(Images).List,
Pal, MaxColors, ConvertImages);
except
Result := False;
end;
end;
function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean;
begin
try
Result := Imaging.RotateImage(Image, Angle);
except
Result := False;
end;
end;
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
begin
try
Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height,
DstImage, DstX, DstY);
except
Result := False;
end;
end;
function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
Fill: Pointer): Boolean;
begin
try
Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill);
except
Result := False;
end;
end;
function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
OldPixel, NewPixel: Pointer): Boolean;
begin
try
Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel);
except
Result := False;
end;
end;
function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
begin
try
Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight,
DstImage, DstX, DstY, DstWidth, DstHeight, Filter);
except
Result := False;
end;
end;
procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
begin
try
Imaging.GetPixelDirect(Image, X, Y, Pixel);
except
end;
end;
procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
begin
try
Imaging.SetPixelDirect(Image, X, Y, Pixel);
except
end;
end;
function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
begin
try
Result := Imaging.GetPixel32(Image, X, Y);
except
Result.Color := 0;
end;
end;
procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
begin
try
Imaging.SetPixel32(Image, X, Y, Color);
except
end;
end;
function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
begin
try
Result := Imaging.GetPixelFP(Image, X, Y);
except
FillChar(Result, SizeOf(Result), 0);
end;
end;
procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
begin
try
Imaging.SetPixelFP(Image, X, Y, Color);
except
end;
end;
function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
begin
try
Imaging.NewPalette(Entries, Pal);
Result := True;
except
Result := False;
end;
end;
function ImFreePalette(var Pal: PPalette32): Boolean;
begin
try
Imaging.FreePalette(Pal);
Result := True;
except
Result := False;
end;
end;
function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
begin
try
Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count);
Result := True;
except
Result := False;
end;
end;
function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
begin
try
Result := Imaging.FindColor(Pal, Entries, Color);
except
Result := 0;
end;
end;
function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
begin
try
Imaging.FillGrayscalePalette(Pal, Entries);
Result := True;
except
Result := False;
end;
end;
function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
BBits: Byte; Alpha: Byte): Boolean;
begin
try
Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha);
Result := True;
except
Result := False;
end;
end;
function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
DstChannel: LongInt): Boolean;
begin
try
Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel);
Result := True;
except
Result := False;
end;
end;
function ImSetOption(OptionId, Value: LongInt): Boolean;
begin
try
Result := Imaging.SetOption(OptionId, Value);
except
Result := False;
end;
end;
function ImGetOption(OptionId: LongInt): LongInt;
begin
try
Result := GetOption(OptionId);
except
Result := InvalidOption;
end;
end;
function ImPushOptions: Boolean;
begin
try
Result := Imaging.PushOptions;
except
Result := False;
end;
end;
function ImPopOptions: Boolean;
begin
try
Result := Imaging.PopOptions;
except
Result := False;
end;
end;
function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
begin
try
Result := Imaging.GetImageFormatInfo(Format, Info);
except
Result := False;
end;
end;
function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
begin
try
Result := Imaging.GetPixelsSize(Format, Width, Height);
except
Result := 0;
end;
end;
procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
begin
try
Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc,
SeekProc, TellProc, ReadProc, WriteProc);
except
end;
end;
procedure ImResetFileIO;
begin
try
Imaging.ResetFileIO;
except
end;
end;
{
Changes/Bug Fixes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.19 -----------------------------------------------------
- updated to reflect changes in low level interface (added pixel set/get, ...)
- changed ImInitImage to procedure to reflect change in Imaging.pas
- added ImIsFileFormatSupported
-- 0.15 -----------------------------------------------------
- behaviour of ImGetImageListElement and ImSetImageListElement
has changed - list items are now cloned rather than referenced,
because of this ImFreeImageListKeepImages was no longer needed
and was removed
- many function headers were changed - mainly pointers were
replaced with var and const parameters
-- 0.13 -----------------------------------------------------
- added TestImagesInList function and new 0.13 functions
- images were not freed when image list was resized in ImSetImageListSize
- ImSaveMultiImageTo* recreated the input image list with size = 0
}
end.

3967
Imaging/ImagingFormats.pas Normal file
View File

File diff suppressed because it is too large Load Diff

988
Imaging/ImagingGif.pas Normal file
View File

@@ -0,0 +1,988 @@
{
$Id: ImagingGif.pas 111 2007-12-02 23:25:44Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for GIF images.}
unit ImagingGif;
{$I ImagingOptions.inc}
interface
uses
SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility;
type
{ GIF (Graphics Interchange Format) loader/saver class. GIF was
(and is still used) popular format for storing images supporting
multiple images per file and single color transparency.
Pixel format is 8 bit indexed where each image frame can have
its own color palette. GIF uses lossless LZW compression
(patent expired few years ago).
Imaging can load and save all GIFs with all frames and supports
transparency.}
TGIFFileFormat = class(TImageFileFormat)
private
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
procedure LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
protected
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
end;
implementation
const
SGIFFormatName = 'Graphics Interchange Format';
SGIFMasks = '*.gif';
GIFSupportedFormats: TImageFormats = [ifIndex8];
type
TGIFVersion = (gv87, gv89);
TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,
dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
const
GIFSignature: TChar3 = 'GIF';
GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
// Masks for accessing fields in PackedFields of TGIFHeader
GIFGlobalColorTable = $80;
GIFColorResolution = $70;
GIFColorTableSorted = $08;
GIFColorTableSize = $07;
// Masks for accessing fields in PackedFields of TImageDescriptor
GIFLocalColorTable = $80;
GIFInterlaced = $40;
GIFLocalTableSorted = $20;
// Block identifiers
GIFPlainText: Byte = $01;
GIFGraphicControlExtension: Byte = $F9;
GIFCommentExtension: Byte = $FE;
GIFApplicationExtension: Byte = $FF;
GIFImageDescriptor: Byte = Ord(',');
GIFExtensionIntroducer: Byte = Ord('!');
GIFTrailer: Byte = Ord(';');
GIFBlockTerminator: Byte = $00;
// Masks for accessing fields in PackedFields of TGraphicControlExtension
GIFTransparent = $01;
GIFUserInput = $02;
GIFDisposalMethod = $1C;
type
TGIFHeader = packed record
// File header part
Signature: TChar3; // Header Signature (always "GIF")
Version: TChar3; // GIF format version("87a" or "89a")
// Logical Screen Descriptor part
ScreenWidth: Word; // Width of Display Screen in Pixels
ScreenHeight: Word; // Height of Display Screen in Pixels
PackedFields: Byte; // Screen and color map information
BackgroundColorIndex: Byte; // Background color index (in global color table)
AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
end;
TImageDescriptor = packed record
//Separator: Byte; // leave that out since we always read one bye ahead
Left: Word; // X position of image with respect to logical screen
Top: Word; // Y position
Width: Word;
Height: Word;
PackedFields: Byte;
end;
const
// GIF extension labels
GIFExtTypeGraphic = $F9;
GIFExtTypePlainText = $01;
GIFExtTypeApplication = $FF;
GIFExtTypeComment = $FE;
type
TGraphicControlExtension = packed record
BlockSize: Byte;
PackedFields: Byte;
DelayTime: Word;
TransparentColorIndex: Byte;
Terminator: Byte;
end;
const
CodeTableSize = 4096;
HashTableSize = 17777;
type
TReadContext = record
Inx: Integer;
Size: Integer;
Buf: array [0..255 + 4] of Byte;
CodeSize: Integer;
ReadMask: Integer;
end;
PReadContext = ^TReadContext;
TWriteContext = record
Inx: Integer;
CodeSize: Integer;
Buf: array [0..255 + 4] of Byte;
end;
PWriteContext = ^TWriteContext;
TOutputContext = record
W: Integer;
H: Integer;
X: Integer;
Y: Integer;
BitsPerPixel: Integer;
Pass: Integer;
Interlace: Boolean;
LineIdent: Integer;
Data: Pointer;
CurrLineData: Pointer;
end;
TImageDict = record
Tail: Word;
Index: Word;
Col: Byte;
end;
PImageDict = ^TImageDict;
PIntCodeTable = ^TIntCodeTable;
TIntCodeTable = array [0..CodeTableSize - 1] of Word;
TDictTable = array [0..CodeTableSize - 1] of TImageDict;
PDictTable = ^TDictTable;
resourcestring
SGIFDecodingError = 'Error when decoding GIF LZW data';
{
TGIFFileFormat implementation
}
constructor TGIFFileFormat.Create;
begin
inherited Create;
FName := SGIFFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := True;
FSupportedFormats := GIFSupportedFormats;
AddMasks(SGIFMasks);
end;
function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
begin
Result := Y;
case Pass of
0, 1:
Inc(Result, 8);
2:
Inc(Result, 4);
3:
Inc(Result, 2);
end;
if Result >= Height then
begin
if Pass = 0 then
begin
Pass := 1;
Result := 4;
if Result < Height then
Exit;
end;
if Pass = 1 then
begin
Pass := 2;
Result := 2;
if Result < Height then
Exit;
end;
if Pass = 2 then
begin
Pass := 3;
Result := 1;
end;
end;
end;
{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height: Integer;
Interlaced: Boolean; Data: Pointer);
var
MinCodeSize: Byte;
MaxCode, BitMask, InitCodeSize: Integer;
ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
I, OutCount, Code: Integer;
CurCode, OldCode, InCode, FinalChar: Word;
Prefix, Suffix, OutCode: PIntCodeTable;
ReadCtxt: TReadContext;
OutCtxt: TOutputContext;
TableFull: Boolean;
function ReadCode(var Context: TReadContext): Integer;
var
RawCode: Integer;
ByteIndex: Integer;
Bytes: Byte;
BytesToLose: Integer;
begin
while Context.Inx + Context.CodeSize > Context.Size do
begin
// Not enough bits in buffer - refill it - Not very efficient, but infrequently called
BytesToLose := Context.Inx shr 3;
// Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
Context.Inx := Context.Inx and 7;
Context.Size := Context.Size - (BytesToLose shl 3);
IO.Read(Handle, @Bytes, 1);
if Bytes > 0 then
IO.Read(Handle, @Context.Buf[Word(Context.Size shr 3)], Bytes);
Context.Size := Context.Size + (Bytes shl 3);
end;
ByteIndex := Context.Inx shr 3;
RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then
RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask;
end;
procedure Output(Value: Byte; var Context: TOutputContext);
var
P: PByte;
begin
if Context.Y >= Context.H then
Exit;
// Only ifIndex8 supported
P := @PByteArray(Context.CurrLineData)[Context.X];
P^ := Value;
{case Context.BitsPerPixel of
1:
begin
P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
if (Context.X and $07) <> 0 then
P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
else
P^ := Byte(Value shl 7);
end;
4:
begin
P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
if (Context.X and 1) <> 0 then
P^ := P^ or Value
else
P^ := Byte(Value shl 4);
end;
8:
begin
P := @PByteArray(Context.CurrLineData)[Context.X];
P^ := Value;
end;
end;}
Inc(Context.X);
if Context.X < Context.W then
Exit;
Context.X := 0;
if Context.Interlace then
Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
else
Inc(Context.Y);
Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
end;
begin
OutCount := 0;
OldCode := 0;
FinalChar := 0;
TableFull := False;
GetMem(Prefix, SizeOf(TIntCodeTable));
GetMem(Suffix, SizeOf(TIntCodeTable));
GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
try
IO.Read(Handle, @MinCodeSize, 1);
if (MinCodeSize < 2) or (MinCodeSize > 9) then
RaiseImaging(SGIFDecodingError, []);
// Initial read context
ReadCtxt.Inx := 0;
ReadCtxt.Size := 0;
ReadCtxt.CodeSize := MinCodeSize + 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
// Initialise pixel-output context
OutCtxt.X := 0;
OutCtxt.Y := 0;
OutCtxt.Pass := 0;
OutCtxt.W := Width;
OutCtxt.H := Height;
OutCtxt.BitsPerPixel := MinCodeSize;
OutCtxt.Interlace := Interlaced;
OutCtxt.LineIdent := Width;
OutCtxt.Data := Data;
OutCtxt.CurrLineData := Data;
BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
// 2 ^ MinCodeSize accounts for all colours in file
ClearCode := 1 shl MinCodeSize;
EndingCode := ClearCode + 1;
FreeCode := ClearCode + 2;
FirstFreeCode := FreeCode;
// 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
InitCodeSize := ReadCtxt.CodeSize;
MaxCode := 1 shl ReadCtxt.CodeSize;
Code := ReadCode(ReadCtxt);
while (Code <> EndingCode) and (Code <> $FFFF) and
(OutCtxt.Y < OutCtxt.H) do
begin
if Code = ClearCode then
begin
ReadCtxt.CodeSize := InitCodeSize;
MaxCode := 1 shl ReadCtxt.CodeSize;
ReadCtxt.ReadMask := MaxCode - 1;
FreeCode := FirstFreeCode;
Code := ReadCode(ReadCtxt);
CurCode := Code;
OldCode := Code;
if Code = $FFFF then
Break;
FinalChar := (CurCode and BitMask);
Output(Byte(FinalChar), OutCtxt);
TableFull := False;
end
else
begin
CurCode := Code;
InCode := Code;
if CurCode >= FreeCode then
begin
CurCode := OldCode;
OutCode^[OutCount] := FinalChar;
Inc(OutCount);
end;
while CurCode > BitMask do
begin
if OutCount > CodeTableSize then
RaiseImaging(SGIFDecodingError, []);
OutCode^[OutCount] := Suffix^[CurCode];
Inc(OutCount);
CurCode := Prefix^[CurCode];
end;
FinalChar := CurCode and BitMask;
OutCode^[OutCount] := FinalChar;
Inc(OutCount);
for I := OutCount - 1 downto 0 do
Output(Byte(OutCode^[I]), OutCtxt);
OutCount := 0;
// Update dictionary
if not TableFull then
begin
Prefix^[FreeCode] := OldCode;
Suffix^[FreeCode] := FinalChar;
// Advance to next free slot
Inc(FreeCode);
if FreeCode >= MaxCode then
begin
if ReadCtxt.CodeSize < 12 then
begin
Inc(ReadCtxt.CodeSize);
MaxCode := MaxCode shl 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
end
else
TableFull := True;
end;
end;
OldCode := InCode;
end;
Code := ReadCode(ReadCtxt);
end;
if Code = $FFFF then
RaiseImaging(SGIFDecodingError, []);
finally
FreeMem(Prefix);
FreeMem(OutCode);
FreeMem(Suffix);
end;
end;
{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
Interlaced: Boolean; Data: Pointer);
var
LineIdent: Integer;
MinCodeSize, Col: Byte;
InitCodeSize, X, Y: Integer;
Pass: Integer;
MaxCode: Integer; { 1 shl CodeSize }
ClearCode, EndingCode, LastCode, Tail: Integer;
I, HashValue: Integer;
LenString: Word;
Dict: PDictTable;
HashTable: TList;
PData: PByte;
WriteCtxt: TWriteContext;
function InitHash(P: Integer): Integer;
begin
Result := (P + 3) * 301;
end;
procedure WriteCode(Code: Integer; var Context: TWriteContext);
var
BufIndex: Integer;
Bytes: Byte;
begin
BufIndex := Context.Inx shr 3;
Code := Code shl (Context.Inx and 7);
Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
Context.Buf[BufIndex + 1] := Byte(Code shr 8);
Context.Buf[BufIndex + 2] := Byte(Code shr 16);
Context.Inx := Context.Inx + Context.CodeSize;
if Context.Inx >= 255 * 8 then
begin
// Flush out full buffer
Bytes := 255;
IO.Write(Handle, @Bytes, 1);
IO.Write(Handle, @Context.Buf, Bytes);
Move(Context.Buf[255], Context.Buf[0], 2);
FillChar(Context.Buf[2], 255, 0);
Context.Inx := Context.Inx - (255 * 8);
end;
end;
procedure FlushCode(var Context: TWriteContext);
var
Bytes: Byte;
begin
Bytes := (Context.Inx + 7) shr 3;
if Bytes > 0 then
begin
IO.Write(Handle, @Bytes, 1);
IO.Write(Handle, @Context.Buf, Bytes);
end;
// Data block terminator - a block of zero Size
Bytes := 0;
IO.Write(Handle, @Bytes, 1);
end;
begin
LineIdent := Width;
Tail := 0;
HashValue := 0;
Col := 0;
HashTable := TList.Create;
GetMem(Dict, SizeOf(TDictTable));
try
for I := 0 to HashTableSize - 1 do
HashTable.Add(nil);
// Initialise encoder variables
InitCodeSize := BitCount + 1;
if InitCodeSize = 2 then
Inc(InitCodeSize);
MinCodeSize := InitCodeSize - 1;
IO.Write(Handle, @MinCodeSize, 1);
ClearCode := 1 shl MinCodeSize;
EndingCode := ClearCode + 1;
LastCode := EndingCode;
MaxCode := 1 shl InitCodeSize;
LenString := 0;
// Setup write context
WriteCtxt.Inx := 0;
WriteCtxt.CodeSize := InitCodeSize;
FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
WriteCode(ClearCode, WriteCtxt);
Y := 0;
Pass := 0;
while Y < Height do
begin
PData := @PByteArray(Data)[Y * LineIdent];
for X := 0 to Width - 1 do
begin
// Only ifIndex8 support
case BitCount of
8:
begin
Col := PData^;
PData := @PByteArray(PData)[1];
end;
{4:
begin
if X and 1 <> 0 then
begin
Col := PData^ and $0F;
PData := @PByteArray(PData)[1];
end
else
Col := PData^ shr 4;
end;
1:
begin
if X and 7 = 7 then
begin
Col := PData^ and 1;
PData := @PByteArray(PData)[1];
end
else
Col := (PData^ shr (7 - (X and $07))) and $01;
end;}
end;
Inc(LenString);
if LenString = 1 then
begin
Tail := Col;
HashValue := InitHash(Col);
end
else
begin
HashValue := HashValue * (Col + LenString + 4);
I := HashValue mod HashTableSize;
HashValue := HashValue mod HashTableSize;
while (HashTable[I] <> nil) and
((PImageDict(HashTable[I])^.Tail <> Tail) or
(PImageDict(HashTable[I])^.Col <> Col)) do
begin
Inc(I);
if I >= HashTableSize then
I := 0;
end;
if HashTable[I] <> nil then // Found in the strings table
Tail := PImageDict(HashTable[I])^.Index
else
begin
// Not found
WriteCode(Tail, WriteCtxt);
Inc(LastCode);
HashTable[I] := @Dict^[LastCode];
PImageDict(HashTable[I])^.Index := LastCode;
PImageDict(HashTable[I])^.Tail := Tail;
PImageDict(HashTable[I])^.Col := Col;
Tail := Col;
HashValue := InitHash(Col);
LenString := 1;
if LastCode >= MaxCode then
begin
// Next Code will be written longer
MaxCode := MaxCode shl 1;
Inc(WriteCtxt.CodeSize);
end
else
if LastCode >= CodeTableSize - 2 then
begin
// Reset tables
WriteCode(Tail, WriteCtxt);
WriteCode(ClearCode, WriteCtxt);
LenString := 0;
LastCode := EndingCode;
WriteCtxt.CodeSize := InitCodeSize;
MaxCode := 1 shl InitCodeSize;
for I := 0 to HashTableSize - 1 do
HashTable[I] := nil;
end;
end;
end;
end;
if Interlaced then
Y := InterlaceStep(Y, Height, Pass)
else
Inc(Y);
end;
WriteCode(Tail, WriteCtxt);
WriteCode(EndingCode, WriteCtxt);
FlushCode(WriteCtxt);
finally
HashTable.Free;
FreeMem(Dict);
end;
end;
function TGIFFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Header: TGIFHeader;
HasGlobalPal: Boolean;
GlobalPalLength: Integer;
GlobalPal: TPalette32Size256;
I: Integer;
BlockID: Byte;
HasGraphicExt: Boolean;
GraphicExt: TGraphicControlExtension;
Disposals: array of TDisposalMethod;
function ReadBlockID: Byte;
begin
Result := GIFTrailer;
GetIO.Read(Handle, @Result, SizeOf(Result));
end;
procedure ReadExtensions;
var
BlockSize, ExtType: Byte;
begin
HasGraphicExt := False;
// Read extensions until image descriptor is found. Only graphic extension
// is stored now (for transparency), others are skipped.
while BlockID = GIFExtensionIntroducer do
with GetIO do
begin
Read(Handle, @ExtType, SizeOf(ExtType));
if ExtType = GIFGraphicControlExtension then
begin
HasGraphicExt := True;
Read(Handle, @GraphicExt, SizeOf(GraphicExt));
end
else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
repeat
// Read block sizes and skip them
Read(Handle, @BlockSize, SizeOf(BlockSize));
Seek(Handle, BlockSize, smFromCurrent);
until BlockSize = 0;
// Read ID of following block
BlockID := ReadBlockID;
end;
end;
procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, TransIndex: Integer);
var
X, Y: Integer;
Src, Dst: PByte;
begin
Src := Frame.Bits;
// Copy all pixels from frame to log screen but ignore the transparent ones
for Y := 0 to Frame.Height - 1 do
begin
Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];
for X := 0 to Frame.Width - 1 do
begin
if Src^ <> TransIndex then
Dst^ := Src^;
Inc(Src);
Inc(Dst);
end;
end;
end;
procedure ReadFrame;
var
ImageDesc: TImageDescriptor;
HasLocalPal, Interlaced, HasTransparency: Boolean;
I, Idx, LocalPalLength, TransIndex: Integer;
LocalPal: TPalette32Size256;
BlockTerm: Byte;
Frame: TImageData;
begin
Idx := Length(Images);
SetLength(Images, Idx + 1);
FillChar(LocalPal, SizeOf(LocalPal), 0);
with GetIO do
begin
// Read and parse image descriptor
Read(Handle, @ImageDesc, SizeOf(ImageDesc));
HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
// Create new logical screen
NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]);
// Create new image for this frame which would be later pasted onto logical screen
InitImage(Frame);
NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame);
// Load local palette if there is any
if HasLocalPal then
for I := 0 to LocalPalLength - 1 do
begin
LocalPal[I].A := 255;
Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
end;
// Use local pal if present or global pal if present or create
// default pal if neither of them is present
if HasLocalPal then
Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
else if HasGlobalPal then
Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
else
FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
// Add default disposal method for this frame
SetLength(Disposals, Length(Disposals) + 1);
Disposals[High(Disposals)] := dmUndefined;
// If Grahic Control Extension is present make use of it
if HasGraphicExt then
begin
HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
if HasTransparency then
Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0;
end
else
HasTransparency := False;
if Idx >= 1 then
begin
// If previous frame had some special disposal method we take it into
// account now
case Disposals[Idx - 1] of
dmUndefined: ; // Do nothing
dmLeave:
begin
// Leave previous frame on log screen
CopyRect(Images[Idx - 1], 0, 0, Images[Idx].Width,
Images[Idx].Height, Images[Idx], 0, 0);
end;
dmRestoreBackground:
begin
// Clear log screen with background color
FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
@Header.BackgroundColorIndex);
end;
dmRestorePrevious:
if Idx >= 2 then
begin
// Set log screen to "previous of previous" frame
CopyRect(Images[Idx - 2], 0, 0, Images[Idx].Width,
Images[Idx].Height, Images[Idx], 0, 0);
end;
end;
end
else
begin
// First frame - just fill with background color
FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
@Header.BackgroundColorIndex);
end;
try
// Data decompression finally
LZWDecompress(GetIO, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
Read(Handle, @BlockTerm, SizeOf(BlockTerm));
// Now copy frame to logical screen with skipping of transparent pixels (if enabled)
TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt);
CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, TransIndex);
finally
FreeImage(Frame);
end;
end;
end;
begin
SetLength(Images, 0);
FillChar(GlobalPal, SizeOf(GlobalPal), 0);
with GetIO do
begin
// Read GIF header
Read(Handle, @Header, SizeOf(Header));
HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1)
// Read global palette from file if present
if HasGlobalPal then
begin
for I := 0 to GlobalPalLength - 1 do
begin
GlobalPal[I].A := 255;
Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
end;
GlobalPal[Header.BackgroundColorIndex].A := 0;
end;
// Read ID of the first block
BlockID := ReadBlockID;
// Now read all data blocks in the file until file trailer is reached
while BlockID <> GIFTrailer do
begin
// Read supported and skip unsupported extensions
ReadExtensions;
// If image frame is found read it
if BlockID = GIFImageDescriptor then
ReadFrame;
// Read next block's ID
BlockID := ReadBlockID;
// If block ID is unknown set it to end-of-GIF marker
if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
BlockID := GIFTrailer;
end;
Result := True;
end;
end;
function TGIFFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
Header: TGIFHeader;
ImageDesc: TImageDescriptor;
ImageToSave: TImageData;
MustBeFreed: Boolean;
I, J: Integer;
GraphicExt: TGraphicControlExtension;
procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
var
I: Integer;
begin
MaxWidth := Images[FFirstIdx].Width;
MaxHeight := Images[FFirstIdx].Height;
for I := FFirstIdx + 1 to FLastIdx do
begin
MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
end;
end;
begin
// Fill header with data, select size of largest image in array as
// logical screen size
FillChar(Header, Sizeof(Header), 0);
Header.Signature := GIFSignature;
Header.Version := GIFVersions[gv89];
FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
Header.PackedFields := GIFColorResolution; // Color resolution is 256
GetIO.Write(Handle, @Header, SizeOf(Header));
// Prepare default GC extension with delay
FillChar(GraphicExt, Sizeof(GraphicExt), 0);
GraphicExt.DelayTime := 65;
GraphicExt.BlockSize := 4;
for I := FFirstIdx to FLastIdx do
begin
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
with GetIO, ImageToSave do
try
// Write Graphic Control Extension with default delay
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
Write(Handle, @GraphicExt, SizeOf(GraphicExt));
// Write frame marker and fill and write image descriptor for this frame
Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
FillChar(ImageDesc, Sizeof(ImageDesc), 0);
ImageDesc.Width := Width;
ImageDesc.Height := Height;
ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
Write(Handle, @ImageDesc, SizeOf(ImageDesc));
// Write local color table for each frame
for J := 0 to 255 do
begin
Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
end;
// Fonally compress image data
LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
Result := True;
end;
procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
ConvertImage(Image, ifIndex8);
end;
function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Header: TGIFHeader;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
begin
ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
GetIO.Seek(Handle, -ReadCount, smFromCurrent);
Result := (ReadCount >= SizeOf(Header)) and
(Header.Signature = GIFSignature) and
((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
end;
end;
initialization
RegisterImageFileFormat(TGIFFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Made backround color transparent by default (alpha = 0).
-- 0.23 Changes/Bug Fixes -----------------------------------
- Fixed other loading bugs (local pal size, transparency).
- Added GIF saving.
- Fixed bug when loading multiframe GIFs and implemented few animation
features (disposal methods, ...).
- Loading of GIFs working.
- Unit created with initial stuff!
}
end.

574
Imaging/ImagingIO.pas Normal file
View File

@@ -0,0 +1,574 @@
{
$Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains default IO functions for reading from/writting to
files, streams and memory.}
unit ImagingIO;
{$I ImagingOptions.inc}
interface
uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility;
type
TMemoryIORec = record
Data: ImagingUtility.PByteArray;
Position: LongInt;
Size: LongInt;
end;
PMemoryIORec = ^TMemoryIORec;
var
OriginalFileIO: TIOFunctions;
FileIO: TIOFunctions;
StreamIO: TIOFunctions;
MemoryIO: TIOFunctions;
{ Helper function that returns size of input (from current position to the end)
represented by Handle (and opened and operated on by members of IOFunctions).}
function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
{ Helper function that initializes TMemoryIORec with given params.}
function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
implementation
const
DefaultBufferSize = 16 * 1024;
type
{ Based on TaaBufferedStream
Copyright (c) Julian M Bucknall 1997, 1999 }
TBufferedStream = class(TObject)
private
FBuffer: PByteArray;
FBufSize: Integer;
FBufStart: Integer;
FBufPos: Integer;
FBytesInBuf: Integer;
FSize: Integer;
FDirty: Boolean;
FStream: TStream;
function GetPosition: Integer;
function GetSize: Integer;
procedure ReadBuffer;
procedure WriteBuffer;
procedure SetPosition(const Value: Integer);
public
constructor Create(AStream: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: Integer): Integer;
function Write(const Buffer; Count: Integer): Integer;
function Seek(Offset: Integer; Origin: Word): Integer;
procedure Commit;
property Stream: TStream read FStream;
property Position: Integer read GetPosition write SetPosition;
property Size: Integer read GetSize;
end;
constructor TBufferedStream.Create(AStream: TStream);
begin
inherited Create;
FStream := AStream;
FBufSize := DefaultBufferSize;
GetMem(FBuffer, FBufSize);
FBufPos := 0;
FBytesInBuf := 0;
FBufStart := 0;
FDirty := False;
FSize := AStream.Size;
end;
destructor TBufferedStream.Destroy;
begin
if FBuffer <> nil then
begin
Commit;
FreeMem(FBuffer);
end;
FStream.Position := Position; // Make sure source stream has right position
inherited Destroy;
end;
function TBufferedStream.GetPosition: Integer;
begin
Result := FBufStart + FBufPos;
end;
procedure TBufferedStream.SetPosition(const Value: Integer);
begin
Seek(Value, soFromCurrent);
end;
function TBufferedStream.GetSize: Integer;
begin
Result := FSize;
end;
procedure TBufferedStream.ReadBuffer;
var
SeekResult: Integer;
begin
SeekResult := FStream.Seek(FBufStart, 0);
if SeekResult = -1 then
raise Exception.Create('TBufferedStream.ReadBuffer: seek failed');
FBytesInBuf := FStream.Read(FBuffer^, FBufSize);
if FBytesInBuf <= 0 then
raise Exception.Create('TBufferedStream.ReadBuffer: read failed');
end;
procedure TBufferedStream.WriteBuffer;
var
SeekResult: Integer;
BytesWritten: Integer;
begin
SeekResult := FStream.Seek(FBufStart, 0);
if SeekResult = -1 then
raise Exception.Create('TBufferedStream.WriteBuffer: seek failed');
BytesWritten := FStream.Write(FBuffer^, FBytesInBuf);
if BytesWritten <> FBytesInBuf then
raise Exception.Create('TBufferedStream.WriteBuffer: write failed');
end;
procedure TBufferedStream.Commit;
begin
if FDirty then
begin
WriteBuffer;
FDirty := False;
end;
end;
function TBufferedStream.Read(var Buffer; Count: Integer): Integer;
var
BufAsBytes : TByteArray absolute Buffer;
BufIdx, BytesToGo, BytesToRead: Integer;
begin
// Calculate the actual number of bytes we can read - this depends on
// the current position and size of the stream as well as the number
// of bytes requested.
BytesToGo := Count;
if FSize < (FBufStart + FBufPos + Count) then
BytesToGo := FSize - (FBufStart + FBufPos);
if BytesToGo <= 0 then
begin
Result := 0;
Exit;
end;
// Remember to return the result of our calculation
Result := BytesToGo;
BufIdx := 0;
if FBytesInBuf = 0 then
ReadBuffer;
// Calculate the number of bytes we can read prior to the loop
BytesToRead := FBytesInBuf - FBufPos;
if BytesToRead > BytesToGo then
BytesToRead := BytesToGo;
// Copy from the stream buffer to the caller's buffer
Move(FBuffer^[FBufPos], BufAsBytes[BufIdx], BytesToRead);
// Calculate the number of bytes still to read}
Dec(BytesToGo, BytesToRead);
// while we have bytes to read, read them
while BytesToGo > 0 do
begin
Inc(BufIdx, BytesToRead);
// As we've exhausted this buffer-full, advance to the next, check
// to see whether we need to write the buffer out first
if FDirty then
begin
WriteBuffer;
FDirty := false;
end;
Inc(FBufStart, FBufSize);
FBufPos := 0;
ReadBuffer;
// Calculate the number of bytes we can read in this cycle
BytesToRead := FBytesInBuf;
if BytesToRead > BytesToGo then
BytesToRead := BytesToGo;
// Ccopy from the stream buffer to the caller's buffer
Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead);
// Calculate the number of bytes still to read
Dec(BytesToGo, BytesToRead);
end;
// Remember our new position
Inc(FBufPos, BytesToRead);
if FBufPos = FBufSize then
begin
Inc(FBufStart, FBufSize);
FBufPos := 0;
FBytesInBuf := 0;
end;
end;
function TBufferedStream.Seek(Offset: Integer; Origin: Word): Integer;
var
NewBufStart, NewPos: Integer;
begin
// Calculate the new position
case Origin of
soFromBeginning : NewPos := Offset;
soFromCurrent : NewPos := FBufStart + FBufPos + Offset;
soFromEnd : NewPos := FSize + Offset;
else
raise Exception.Create('TBufferedStream.Seek: invalid origin');
end;
if (NewPos < 0) or (NewPos > FSize) then
begin
//NewPos := ClampInt(NewPos, 0, FSize); don't do this - for writing
end;
// Calculate which page of the file we need to be at
NewBufStart := NewPos and not Pred(FBufSize);
// If the new page is different than the old, mark the buffer as being
// ready to be replenished, and if need be write out any dirty data
if NewBufStart <> FBufStart then
begin
if FDirty then
begin
WriteBuffer;
FDirty := False;
end;
FBufStart := NewBufStart;
FBytesInBuf := 0;
end;
// Save the new position
FBufPos := NewPos - NewBufStart;
Result := NewPos;
end;
function TBufferedStream.Write(const Buffer; Count: Integer): Integer;
var
BufAsBytes: TByteArray absolute Buffer;
BufIdx, BytesToGo, BytesToWrite: Integer;
begin
// When we write to this stream we always assume that we can write the
// requested number of bytes: if we can't (eg, the disk is full) we'll
// get an exception somewhere eventually.
BytesToGo := Count;
// Remember to return the result of our calculation
Result := BytesToGo;
BufIdx := 0;
if (FBytesInBuf = 0) and (FSize > FBufStart) then
ReadBuffer;
// Calculate the number of bytes we can write prior to the loop
BytesToWrite := FBufSize - FBufPos;
if BytesToWrite > BytesToGo then
BytesToWrite := BytesToGo;
// Copy from the caller's buffer to the stream buffer
Move(BufAsBytes[BufIdx], FBuffer^[FBufPos], BytesToWrite);
// Mark our stream buffer as requiring a save to the actual stream,
// note that this will suffice for the rest of the routine as well: no
// inner routine will turn off the dirty flag.
FDirty := True;
// Calculate the number of bytes still to write
Dec(BytesToGo, BytesToWrite);
// While we have bytes to write, write them
while BytesToGo > 0 do
begin
Inc(BufIdx, BytesToWrite);
// As we've filled this buffer, write it out to the actual stream
// and advance to the next buffer, reading it if required
FBytesInBuf := FBufSize;
WriteBuffer;
Inc(FBufStart, FBufSize);
FBufPos := 0;
FBytesInBuf := 0;
if FSize > FBufStart then
ReadBuffer;
// Calculate the number of bytes we can write in this cycle
BytesToWrite := FBufSize;
if BytesToWrite > BytesToGo then
BytesToWrite := BytesToGo;
// Copy from the caller's buffer to our buffer
Move(BufAsBytes[BufIdx], FBuffer^, BytesToWrite);
// Calculate the number of bytes still to write
Dec(BytesToGo, BytesToWrite);
end;
// Remember our new position
Inc(FBufPos, BytesToWrite);
// Make sure the count of valid bytes is correct
if FBytesInBuf < FBufPos then
FBytesInBuf := FBufPos;
// Make sure the stream size is correct
if FSize < (FBufStart + FBytesInBuf) then
FSize := FBufStart + FBytesInBuf;
// If we're at the end of the buffer, write it out and advance to the
// start of the next page
if FBufPos = FBufSize then
begin
WriteBuffer;
FDirty := False;
Inc(FBufStart, FBufSize);
FBufPos := 0;
FBytesInBuf := 0;
end;
end;
{ File IO functions }
function FileOpenRead(FileName: PChar): TImagingHandle; cdecl;
begin
Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite));
end;
function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl;
begin
Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite));
end;
procedure FileClose(Handle: TImagingHandle); cdecl;
var
Stream: TStream;
begin
Stream := TBufferedStream(Handle).Stream;
TBufferedStream(Handle).Free;
Stream.Free;
end;
function FileEof(Handle: TImagingHandle): Boolean; cdecl;
begin
Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size;
end;
function FileSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode));
end;
function FileTell(Handle: TImagingHandle): LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Position;
end;
function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Read(Buffer^, Count);
end;
function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Write(Buffer^, Count);
end;
{ Stream IO functions }
function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
procedure StreamClose(Handle: TImagingHandle); cdecl;
begin
end;
function StreamEof(Handle: TImagingHandle): Boolean; cdecl;
begin
Result := TStream(Handle).Position = TStream(Handle).Size;
end;
function StreamSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
begin
Result := TStream(Handle).Seek(Offset, LongInt(Mode));
end;
function StreamTell(Handle: TImagingHandle): LongInt; cdecl;
begin
Result := TStream(Handle).Position;
end;
function StreamRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
begin
Result := TStream(Handle).Read(Buffer^, Count);
end;
function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
begin
Result := TStream(Handle).Write(Buffer^, Count);
end;
{ Memory IO functions }
function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
procedure MemoryClose(Handle: TImagingHandle); cdecl;
begin
end;
function MemoryEof(Handle: TImagingHandle): Boolean; cdecl;
begin
Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size;
end;
function MemorySeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
begin
Result := PMemoryIORec(Handle).Position;
case Mode of
smFromBeginning: Result := Offset;
smFromCurrent: Result := PMemoryIORec(Handle).Position + Offset;
smFromEnd: Result := PMemoryIORec(Handle).Size + Offset;
end;
//Result := ClampInt(Result, 0, PMemoryIORec(Handle).Size); don't do this - some file formats use it
PMemoryIORec(Handle).Position := Result;
end;
function MemoryTell(Handle: TImagingHandle): LongInt; cdecl;
begin
Result := PMemoryIORec(Handle).Position;
end;
function MemoryRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
var
Rec: PMemoryIORec;
begin
Rec := PMemoryIORec(Handle);
Result := Count;
if Rec.Position + Count > Rec.Size then
Result := Rec.Size - Rec.Position;
Move(Rec.Data[Rec.Position], Buffer^, Result);
Rec.Position := Rec.Position + Result;
end;
function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
var
Rec: PMemoryIORec;
begin
Rec := PMemoryIORec(Handle);
Result := Count;
if Rec.Position + Count > Rec.Size then
Result := Rec.Size - Rec.Position;
Move(Buffer^, Rec.Data[Rec.Position], Result);
Rec.Position := Rec.Position + Result;
end;
{ Helper IO functions }
function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
var
OldPos: Int64;
begin
OldPos := IOFunctions.Tell(Handle);
IOFunctions.Seek(Handle, 0, smFromEnd);
Result := IOFunctions.Tell(Handle);
IOFunctions.Seek(Handle, OldPos, smFromBeginning);
end;
function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
begin
Result.Data := Data;
Result.Position := 0;
Result.Size := Size;
end;
initialization
OriginalFileIO.OpenRead := FileOpenRead;
OriginalFileIO.OpenWrite := FileOpenWrite;
OriginalFileIO.Close := FileClose;
OriginalFileIO.Eof := FileEof;
OriginalFileIO.Seek := FileSeek;
OriginalFileIO.Tell := FileTell;
OriginalFileIO.Read := FileRead;
OriginalFileIO.Write := FileWrite;
StreamIO.OpenRead := StreamOpenRead;
StreamIO.OpenWrite := StreamOpenWrite;
StreamIO.Close := StreamClose;
StreamIO.Eof := StreamEof;
StreamIO.Seek := StreamSeek;
StreamIO.Tell := StreamTell;
StreamIO.Read := StreamRead;
StreamIO.Write := StreamWrite;
MemoryIO.OpenRead := MemoryOpenRead;
MemoryIO.OpenWrite := MemoryOpenWrite;
MemoryIO.Close := MemoryClose;
MemoryIO.Eof := MemoryEof;
MemoryIO.Seek := MemorySeek;
MemoryIO.Tell := MemoryTell;
MemoryIO.Read := MemoryRead;
MemoryIO.Write := MemoryWrite;
ResetFileIO;
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added merge between buffered read-only and write-only file
stream adapters - TIFF saving needed both reading and writing.
- Fixed bug causing wrong value of TBufferedWriteFile.Size
(needed to add buffer pos to size).
-- 0.21 Changes/Bug Fixes -----------------------------------
- Removed TMemoryIORec.Written, use Position to get proper memory
position (Written didn't take Seeks into account).
- Added TBufferedReadFile and TBufferedWriteFile classes for
buffered file reading/writting. File IO functions now use these
classes resulting in performance increase mainly in file formats
that read/write many small chunks.
- Added fmShareDenyWrite to FileOpenRead. You can now read
files opened for reading by Imaging from other apps.
- Added GetInputSize and PrepareMemIO helper functions.
-- 0.19 Changes/Bug Fixes -----------------------------------
- changed behaviour of MemorySeek to act as TStream
based Seeks
}
end.

589
Imaging/ImagingJpeg.pas Normal file
View File

@@ -0,0 +1,589 @@
{
$Id: ImagingJpeg.pas 103 2007-09-15 01:11:14Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for Jpeg images.}
unit ImagingJpeg;
{$I ImagingOptions.inc}
{ You can choose which Pascal JpegLib implementation will be used.
IMJPEGLIB is version bundled with Imaging which works with all supported
compilers and platforms.
PASJPEG is original JpegLib translation or version modified for FPC
(and shipped with it). You can use PASJPEG if this version is already
linked with another part of your program and you don't want to have
two quite large almost the same libraries linked to your exe.
This is the case with Lazarus applications for example.}
{$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus.}
{$IFDEF LCL}
{ $UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$ENDIF}
interface
uses
SysUtils, ImagingTypes, Imaging, ImagingColors,
{$IF Defined(IMJPEGLIB)}
imjpeglib, imjmorecfg, imjcomapi, imjdapimin,
imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
{$ELSEIF Defined(PASJPEG)}
jpeglib, jmorecfg, jcomapi, jdapimin,
jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
{$IFEND}
ImagingUtility;
{$IF Defined(FPC) and Defined(PASJPEG)}
{ When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
{ $DEFINE RGBSWAPPED} // not needed now apparently
{$IFEND}
type
{ Class for loading/saving Jpeg images. Supports load/save of
8 bit grayscale and 24 bit RGB images.}
TJpegFileFormat = class(TImageFileFormat)
private
FGrayScale: Boolean;
protected
FQuality: LongInt;
FProgressive: LongBool;
procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
{ Controls Jpeg save compression quality. It is number in range 1..100.
1 means small/ugly file, 100 means large/nice file. Accessible trough
ImagingJpegQuality option.}
property Quality: LongInt read FQuality write FQuality;
{ If True Jpeg images are saved in progressive format. Accessible trough
ImagingJpegProgressive option.}
property Progressive: LongBool read FProgressive write FProgressive;
end;
implementation
const
SJpegFormatName = 'Joint Photographic Experts Group Image';
SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
JpegDefaultQuality = 90;
JpegDefaultProgressive = False;
const
{ Jpeg file identifiers.}
JpegMagic: TChar2 = #$FF#$D8;
JFIFSignature: TChar4 = 'JFIF';
EXIFSignature: TChar4 = 'Exif';
BufferSize = 16384;
type
TJpegContext = record
case Byte of
0: (common: jpeg_common_struct);
1: (d: jpeg_decompress_struct);
2: (c: jpeg_compress_struct);
end;
TSourceMgr = record
Pub: jpeg_source_mgr;
Input: TImagingHandle;
Buffer: JOCTETPTR;
StartOfFile: Boolean;
end;
PSourceMgr = ^TSourceMgr;
TDestMgr = record
Pub: jpeg_destination_mgr;
Output: TImagingHandle;
Buffer: JOCTETPTR;
end;
PDestMgr = ^TDestMgr;
var
JIO: TIOFunctions;
{ Intenal unit jpeglib support functions }
procedure JpegError(CurInfo: j_common_ptr);
begin
end;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin
end;
procedure OutputMessage(CurInfo: j_common_ptr);
begin
end;
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
end;
procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
CurInfo^.err^.num_warnings := 0;
CurInfo^.err^.msg_code := 0;
end;
var
JpegErrorRec: jpeg_error_mgr = (
error_exit: JpegError;
emit_message: EmitMessage;
output_message: OutputMessage;
format_message: FormatMessage;
reset_error_mgr: ResetErrorMgr);
procedure ReleaseContext(var jc: TJpegContext);
begin
if jc.common.err = nil then
Exit;
jpeg_destroy(@jc.common);
jpeg_destroy_decompress(@jc.d);
jpeg_destroy_compress(@jc.c);
jc.common.err := nil;
end;
procedure InitSource(cinfo: j_decompress_ptr);
begin
PSourceMgr(cinfo.src).StartOfFile := True;
end;
function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
var
NBytes: LongInt;
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
if NBytes <= 0 then
begin
PChar(Src.Buffer)[0] := #$FF;
PChar(Src.Buffer)[1] := Char(JPEG_EOI);
NBytes := 2;
end;
Src.Pub.next_input_byte := Src.Buffer;
Src.Pub.bytes_in_buffer := NBytes;
Src.StartOfFile := False;
Result := True;
end;
procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
var
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
if num_bytes > 0 then
begin
while num_bytes > Src.Pub.bytes_in_buffer do
begin
Dec(num_bytes, Src.Pub.bytes_in_buffer);
FillInputBuffer(cinfo);
end;
Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
// Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
Dec(Src.Pub.bytes_in_buffer, num_bytes);
end;
end;
procedure TermSource(cinfo: j_decompress_ptr);
var
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
// Move stream position back just after EOI marker so that more that one
// JPEG images can be loaded from one stream
JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
end;
procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
TImagingHandle);
var
Src: PSourceMgr;
begin
if cinfo.src = nil then
begin
cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
SizeOf(TSourceMgr));
Src := PSourceMgr(cinfo.src);
Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
BufferSize * SizeOf(JOCTET));
end;
Src := PSourceMgr(cinfo.src);
Src.Pub.init_source := InitSource;
Src.Pub.fill_input_buffer := FillInputBuffer;
Src.Pub.skip_input_data := SkipInputData;
Src.Pub.resync_to_restart := jpeg_resync_to_restart;
Src.Pub.term_source := TermSource;
Src.Input := Handle;
Src.Pub.bytes_in_buffer := 0;
Src.Pub.next_input_byte := nil;
end;
procedure InitDest(cinfo: j_compress_ptr);
var
Dest: PDestMgr;
begin
Dest := PDestMgr(cinfo.dest);
Dest.Pub.next_output_byte := Dest.Buffer;
Dest.Pub.free_in_buffer := BufferSize;
end;
function EmptyOutput(cinfo: j_compress_ptr): Boolean;
var
Dest: PDestMgr;
begin
Dest := PDestMgr(cinfo.dest);
JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
Dest.Pub.next_output_byte := Dest.Buffer;
Dest.Pub.free_in_buffer := BufferSize;
Result := True;
end;
procedure TermDest(cinfo: j_compress_ptr);
var
Dest: PDestMgr;
DataCount: LongInt;
begin
Dest := PDestMgr(cinfo.dest);
DataCount := BufferSize - Dest.Pub.free_in_buffer;
if DataCount > 0 then
JIO.Write(Dest.Output, Dest.Buffer, DataCount);
end;
procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
TImagingHandle);
var
Dest: PDestMgr;
begin
if cinfo.dest = nil then
cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
JPOOL_PERMANENT, SizeOf(TDestMgr));
Dest := PDestMgr(cinfo.dest);
Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
BufferSize * SIZEOF(JOCTET));
Dest.Pub.init_destination := InitDest;
Dest.Pub.empty_output_buffer := EmptyOutput;
Dest.Pub.term_destination := TermDest;
Dest.Output := Handle;
end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True);
jc.d.scale_num := 1;
jc.d.scale_denom := 1;
jc.d.do_block_smoothing := True;
if jc.d.out_color_space = JCS_GRAYSCALE then
begin
jc.d.quantize_colors := True;
jc.d.desired_number_of_colors := 256;
end;
end;
procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle);
jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FGrayScale then
jpeg_set_colorspace(@jc.c, JCS_GRAYSCALE)
else
jpeg_set_colorspace(@jc.c, JCS_YCbCr);
if Saver.FProgressive then
jpeg_simple_progression(@jc.c);
end;
{ TJpegFileFormat class implementation }
constructor TJpegFileFormat.Create;
begin
inherited Create;
FName := SJpegFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := JpegSupportedFormats;
FQuality := JpegDefaultQuality;
FProgressive := JpegDefaultProgressive;
AddMasks(SJpegMasks);
RegisterOption(ImagingJpegQuality, @FQuality);
RegisterOption(ImagingJpegProgressive, @FProgressive);
end;
procedure TJpegFileFormat.CheckOptionsValidity;
begin
// Check if option values are valid
if not (FQuality in [1..100]) then
FQuality := JpegDefaultQuality;
end;
function TJpegFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
PtrInc, LinesPerCall, LinesRead, I: Integer;
Dest: PByte;
jc: TJpegContext;
Info: TImageFormatInfo;
Format: TImageFormat;
Col32: PColor32Rec;
{$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
begin
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
SetLength(Images, 1);
with JIO, Images[0] do
try
InitDecompressor(Handle, jc);
case jc.d.out_color_space of
JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8;
JCS_CMYK: Format := ifA8R8G8B8;
end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d);
GetImageFormatInfo(Format, Info);
PtrInc := Width * Info.BytesPerPixel;
LinesPerCall := 1;
Dest := Bits;
while jc.d.output_scanline < jc.d.output_height do
begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
begin
Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do
begin
SwapValues(Pix.R, Pix.B);
Inc(Pix);
end;
end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead);
end;
if jc.d.out_color_space = JCS_CMYK then
begin
Col32 := Bits;
// Translate from CMYK to RGB
for I := 0 to Width * Height - 1 do
begin
CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
Col32.R, Col32.G, Col32.B);
Col32.A := 255;
Inc(Col32);
end;
end;
jpeg_finish_output(@jc.d);
jpeg_finish_decompress(@jc.d);
Result := True;
finally
ReleaseContext(jc);
end;
end;
function TJpegFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
PtrInc, LinesWritten: LongInt;
Src, Line: PByte;
jc: TJpegContext;
ImageToSave: TImageData;
Info: TImageFormatInfo;
MustBeFreed: Boolean;
{$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
begin
Result := False;
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
// Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with JIO, ImageToSave do
try
GetImageFormatInfo(Format, Info);
FGrayScale := Format = ifGray8;
InitCompressor(Handle, jc, Self);
jc.c.image_width := Width;
jc.c.image_height := Height;
if FGrayScale then
begin
jc.c.input_components := 1;
jc.c.in_color_space := JCS_GRAYSCALE;
end
else
begin
jc.c.input_components := 3;
jc.c.in_color_space := JCS_RGB;
end;
PtrInc := Width * Info.BytesPerPixel;
Src := Bits;
{$IFDEF RGBSWAPPED}
GetMem(Line, PtrInc);
{$ENDIF}
jpeg_start_compress(@jc.c, True);
while (jc.c.next_scanline < jc.c.image_height) do
begin
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
begin
Move(Src^, Line^, PtrInc);
Pix := PColor24Rec(Line);
for I := 0 to Width - 1 do
begin
SwapValues(Pix.R, Pix.B);
Inc(Pix, 1);
end;
end;
{$ELSE}
Line := Src;
{$ENDIF}
LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
Inc(Src, PtrInc * LinesWritten);
end;
jpeg_finish_compress(@jc.c);
Result := True;
finally
ReleaseContext(jc);
if MustBeFreed then
FreeImage(ImageToSave);
{$IFDEF RGBSWAPPED}
FreeMem(Line);
{$ENDIF}
end;
end;
procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
if Info.HasGrayChannel then
ConvertImage(Image, ifGray8)
else
ConvertImage(Image, ifR8G8B8);
end;
function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
ReadCount: LongInt;
ID: array[0..9] of Char;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
FillChar(ID, SizeOf(ID), 0);
ReadCount := Read(Handle, @ID, SizeOf(ID));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (ReadCount = SizeOf(ID)) and
CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
end;
end;
procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
begin
JIO := JpegIO;
end;
initialization
RegisterImageFileFormat(TJpegFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption
and loaded image looked wrong.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Removed JFIF/EXIF detection from TestFormat. Found JPEGs
with different headers (Lavc) which weren't recognized.
-- 0.21 Changes/Bug Fixes -----------------------------------
- MakeCompatible method moved to base class, put ConvertToSupported here.
GetSupportedFormats removed, it is now set in constructor.
- Made public properties for options registered to SetOption/GetOption
functions.
- Changed extensions to filename masks.
- Changed SaveData, LoadData, and MakeCompatible methods according
to changes in base class in Imaging unit.
- Changes in TestFormat, now reads JFIF and EXIF signatures too.
-- 0.19 Changes/Bug Fixes -----------------------------------
- input position is now set correctly to the end of the image
after loading is done. Loading of sequence of JPEG files stored in
single stream works now
- when loading and saving images in FPC with PASJPEG read and
blue channels are swapped to have the same chanel order as IMJPEGLIB
- you can now choose between IMJPEGLIB and PASJPEG implementations
-- 0.17 Changes/Bug Fixes -----------------------------------
- added SetJpegIO method which is used by JNG image format
}
end.

2146
Imaging/ImagingNetworkGraphics.pas Normal file
View File

File diff suppressed because it is too large Load Diff

867
Imaging/ImagingOpenGL.pas Normal file
View File

@@ -0,0 +1,867 @@
{
$Id: ImagingOpenGL.pas 106 2007-10-23 23:03:35Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains functions for loading and saving OpenGL textures
using Imaging and for converting images to textures and vice versa.}
unit ImagingOpenGL;
{$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.}
{ $DEFINE USE_DGL_HEADERS}
interface
uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
{$IFDEF USE_DGL_HEADERS}
dglOpenGL,
{$ELSE}
gl, glext,
{$ENDIF}
ImagingUtility;
type
{ Various texture capabilities of installed OpenGL driver.}
TGLTextureCaps = record
MaxTextureSize: LongInt;
PowerOfTwo: Boolean;
DXTCompression: Boolean;
FloatTextures: Boolean;
MaxAnisotropy: LongInt;
MaxSimultaneousTextures: LongInt;
end;
{ Returns texture capabilities of installed OpenGL driver.}
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
{ Function which can be used to retrieve GL extension functions.}
function GetGLProcAddress(const ProcName: string): Pointer;
{ Returns True if the given GL extension is supported.}
function IsGLExtensionSupported(const Extension: string): Boolean;
{ Returns True if the given image format can be represented as GL texture
format. GLFormat, GLType, and GLInternal are parameters for functions like
glTexImage. Note that GLU functions like gluBuildMipmaps cannot handle some
formats returned by this function (i.e. GL_UNSIGNED_SHORT_5_5_5_1 as GLType).
If you are using compressed or floating-point images make sure that they are
supported by hardware using GetGLTextureCaps, ImageFormatToGL does not
check this.}
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum;
var GLType: GLenum; var GLInternal: GLint): Boolean;
{ All GL textures created by Imaging functions have default parameters set -
that means that no glTexParameter calls are made so default filtering,
wrapping, and other parameters are used. Created textures
are left bound by glBindTexture when function is exited.}
{ Creates GL texture from image in file in format supported by Imaging.
You can use CreatedWidth and Height parameters to query dimensions of created textures
(it could differ from dimensions of source image).}
function LoadGLTextureFromFile(const FileName: string; CreatedWidth: PLongInt = nil;
CreatedHeight: PLongInt = nil): GLuint;
{ Creates GL texture from image in stream in format supported by Imaging.
You can use CreatedWidth and Height parameters to query dimensions of created textures
(it could differ from dimensions of source image).}
function LoadGLTextureFromStream(Stream: TStream; CreatedWidth: PLongInt = nil;
CreatedHeight: PLongInt = nil): GLuint;
{ Creates GL texture from image in memory in format supported by Imaging.
You can use CreatedWidth and Height parameters to query dimensions of created textures
(it could differ from dimensions of source image).}
function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt;
CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint;
{ Converts TImageData structure to OpenGL texture.
Input images is used as main mipmap level and additional requested
levels are generated from this one. For the details on parameters
look at CreateGLTextureFromMultiImage function.}
function CreateGLTextureFromImage(const Image: TImageData;
Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True;
OverrideFormat: TImageFormat = ifUnknown; CreatedWidth: PLongInt = nil;
CreatedHeight: PLongInt = nil): GLuint;
{ Converts images in TDymImageDataArray to one OpenGL texture.
Image at index MainLevelIndex in the array is used as main mipmap level and
additional images are used as subsequent levels. If there is not enough images
in array missing levels are automatically generated (and if there is enough images
but they have wrong dimensions or format then they are resized/converted).
If driver supports only power of two sized textures images are resized.
OverrideFormat can be used to convert image into specific format before
it is passed to OpenGL, ifUnknown means no conversion.
If desired texture format is not supported by hardware default
A8R8G8B8 format is used instead for color images and ifGray8 is used
for luminance images. DXTC (S3TC) compressed and floating point textures
are created if supported by hardware.
Width and Height can be used to set size of main mipmap level according
to your needs, Width and Height of 0 mean use width and height of input
image that will become main level mipmap.
MipMaps set to True mean build all possible levels, False means use only level 0.
You can use CreatedWidth and CreatedHeight parameters to query dimensions of
created texture's largest mipmap level (it could differ from dimensions
of source image).}
function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray;
Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True;
MainLevelIndex: LongInt = 0; OverrideFormat: TImageFormat = ifUnknown;
CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint;
{ Saves GL texture to file in one of formats supported by Imaging.
Saves all present mipmap levels.}
function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean;
{ Saves GL texture to stream in one of formats supported by Imaging.
Saves all present mipmap levels.}
function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean;
{ Saves GL texture to memory in one of formats supported by Imaging.
Saves all present mipmap levels.}
function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean;
{ Converts main level of the GL texture to TImageData strucrue. OverrideFormat
can be used to convert output image to the specified format rather
than use the format taken from GL texture, ifUnknown means no conversion.}
function CreateImageFromGLTexture(const Texture: GLuint;
var Image: TImageData; OverrideFormat: TImageFormat = ifUnknown): Boolean;
{ Converts GL texture to TDynImageDataArray array of images. You can specify
how many mipmap levels of the input texture you want to be converted
(default is all levels). OverrideFormat can be used to convert output images to
the specified format rather than use the format taken from GL texture,
ifUnknown means no conversion.}
function CreateMultiImageFromGLTexture(const Texture: GLuint;
var Images: TDynImageDataArray; MipLevels: LongInt = 0;
OverrideFormat: TImageFormat = ifUnknown): Boolean;
var
{ Standard behaviour of image->texture functions like CreateGLTextureFrom(Multi)Image is:
If graphic card supports non power of 2 textures and image is nonpow2 then
texture is created directly from image.
If graphic card does not support them input image is rescaled (bilinear)
to power of 2 size.
If you set PasteNonPow2ImagesIntoPow2 to True then instead of rescaling, a new
pow2 texture is created and nonpow2 input image is pasted into it
keeping its original size. This could be useful for some 2D stuff
(and its faster than rescaling of course). Note that this is applied
to all rescaling smaller->bigger operations that might ocurr during
image->texture process (usually only pow2/nonpow2 stuff and when you
set custom Width & Height in CreateGLTextureFrom(Multi)Image).}
PasteNonPow2ImagesIntoPow2: Boolean = False;
implementation
const
// cube map consts
GL_TEXTURE_BINDING_CUBE_MAP = $8514;
GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515;
GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516;
GL_TEXTURE_CUBE_MAP_POSITIVE_Y = $8517;
GL_TEXTURE_CUBE_MAP_NEGATIVE_Y = $8518;
GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519;
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A;
// texture formats
GL_COLOR_INDEX = $1900;
GL_STENCIL_INDEX = $1901;
GL_DEPTH_COMPONENT = $1902;
GL_RED = $1903;
GL_GREEN = $1904;
GL_BLUE = $1905;
GL_ALPHA = $1906;
GL_RGB = $1907;
GL_RGBA = $1908;
GL_LUMINANCE = $1909;
GL_LUMINANCE_ALPHA = $190A;
GL_BGR_EXT = $80E0;
GL_BGRA_EXT = $80E1;
// texture internal formats
GL_ALPHA4 = $803B;
GL_ALPHA8 = $803C;
GL_ALPHA12 = $803D;
GL_ALPHA16 = $803E;
GL_LUMINANCE4 = $803F;
GL_LUMINANCE8 = $8040;
GL_LUMINANCE12 = $8041;
GL_LUMINANCE16 = $8042;
GL_LUMINANCE4_ALPHA4 = $8043;
GL_LUMINANCE6_ALPHA2 = $8044;
GL_LUMINANCE8_ALPHA8 = $8045;
GL_LUMINANCE12_ALPHA4 = $8046;
GL_LUMINANCE12_ALPHA12 = $8047;
GL_LUMINANCE16_ALPHA16 = $8048;
GL_INTENSITY = $8049;
GL_INTENSITY4 = $804A;
GL_INTENSITY8 = $804B;
GL_INTENSITY12 = $804C;
GL_INTENSITY16 = $804D;
GL_R3_G3_B2 = $2A10;
GL_RGB4 = $804F;
GL_RGB5 = $8050;
GL_RGB8 = $8051;
GL_RGB10 = $8052;
GL_RGB12 = $8053;
GL_RGB16 = $8054;
GL_RGBA2 = $8055;
GL_RGBA4 = $8056;
GL_RGB5_A1 = $8057;
GL_RGBA8 = $8058;
GL_RGB10_A2 = $8059;
GL_RGBA12 = $805A;
GL_RGBA16 = $805B;
// floating point texture formats
GL_RGBA32F_ARB = $8814;
GL_INTENSITY32F_ARB = $8817;
GL_LUMINANCE32F_ARB = $8818;
GL_RGBA16F_ARB = $881A;
GL_INTENSITY16F_ARB = $881D;
GL_LUMINANCE16F_ARB = $881E;
// compressed texture formats
GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1;
GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2;
GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3;
// various GL extension constants
GL_MAX_TEXTURE_UNITS = $84E2;
GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE;
GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF;
// texture source data formats
GL_UNSIGNED_BYTE_3_3_2 = $8032;
GL_UNSIGNED_SHORT_4_4_4_4 = $8033;
GL_UNSIGNED_SHORT_5_5_5_1 = $8034;
GL_UNSIGNED_INT_8_8_8_8 = $8035;
GL_UNSIGNED_INT_10_10_10_2 = $8036;
GL_UNSIGNED_BYTE_2_3_3_REV = $8362;
GL_UNSIGNED_SHORT_5_6_5 = $8363;
GL_UNSIGNED_SHORT_5_6_5_REV = $8364;
GL_UNSIGNED_SHORT_4_4_4_4_REV = $8365;
GL_UNSIGNED_SHORT_1_5_5_5_REV = $8366;
GL_UNSIGNED_INT_8_8_8_8_REV = $8367;
GL_UNSIGNED_INT_2_10_10_10_REV = $8368;
GL_HALF_FLOAT_ARB = $140B;
{$IFDEF MSWINDOWS}
GLLibName = 'opengl32.dll';
{$ENDIF}
{$IFDEF UNIX}
GLLibName = 'libGL.so';
{$ENDIF}
type
TglCompressedTexImage2D = procedure (Target: GLenum; Level: GLint;
InternalFormat: GLenum; Width: GLsizei; Height: GLsizei; Border: GLint;
ImageSize: GLsizei; const Data: PGLvoid);
{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}
var
glCompressedTexImage2D: TglCompressedTexImage2D = nil;
ExtensionBuffer: string = '';
{$IFDEF MSWINDOWS}
function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external GLLibName;
{$ENDIF}
{$IFDEF UNIX}
function glXGetProcAddress(ProcName: PChar): Pointer; cdecl; external GLLibName;
{$ENDIF}
function IsGLExtensionSupported(const Extension: string): Boolean;
var
ExtPos: LongInt;
begin
if ExtensionBuffer = '' then
ExtensionBuffer := glGetString(GL_EXTENSIONS);
ExtPos := Pos(Extension, ExtensionBuffer);
Result := ExtPos > 0;
if Result then
begin
Result := ((ExtPos + Length(Extension) - 1) = Length(ExtensionBuffer)) or
not (ExtensionBuffer[ExtPos + Length(Extension)] in ['_', 'A'..'Z', 'a'..'z']);
end;
end;
function GetGLProcAddress(const ProcName: string): Pointer;
begin
{$IFDEF MSWINDOWS}
Result := wglGetProcAddress(PChar(ProcName));
{$ENDIF}
{$IFDEF UNIX}
Result := glXGetProcAddress(PChar(ProcName));
{$ENDIF}
end;
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
begin
// check DXTC support and load extension functions if necesary
Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and
IsGLExtensionSupported('GL_EXT_texture_compression_s3tc');
if Caps.DXTCompression then
glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D');
Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil);
// check non power of 2 textures
Caps.PowerOfTwo := not IsGLExtensionSupported('GL_ARB_texture_non_power_of_two');
// check for floating point textures support
Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float');
// get max texture size
glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize);
// get max anisotropy
if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then
glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy)
else
Caps.MaxAnisotropy := 0;
// get number of texture units
if IsGLExtensionSupported('GL_ARB_multitexture') then
glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures)
else
Caps.MaxSimultaneousTextures := 1;
// get max texture size
glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize);
Result := True;
end;
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum;
var GLType: GLenum; var GLInternal: GLint): Boolean;
begin
GLFormat := 0;
GLType := 0;
GLInternal := 0;
case Format of
// Gray formats
ifGray8, ifGray16:
begin
GLFormat := GL_LUMINANCE;
GLType := Iff(Format = ifGray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT);
GLInternal := Iff(Format = ifGray8, GL_LUMINANCE8, GL_LUMINANCE16);
end;
ifA8Gray8, ifA16Gray16:
begin
GLFormat := GL_LUMINANCE_ALPHA;
GLType := Iff(Format = ifA8Gray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT);
GLInternal := Iff(Format = ifA8Gray8, GL_LUMINANCE8_ALPHA8, GL_LUMINANCE16_ALPHA16);
end;
// RGBA formats
ifR3G3B2:
begin
GLFormat := GL_RGB;
GLType := GL_UNSIGNED_BYTE_3_3_2;
GLInternal := GL_R3_G3_B2;
end;
ifR5G6B5:
begin
GLFormat := GL_RGB;
GLType := GL_UNSIGNED_SHORT_5_6_5;
GLInternal := GL_RGB5;
end;
ifA1R5G5B5, ifX1R5G5B5:
begin
GLFormat := GL_BGRA_EXT;
GLType := GL_UNSIGNED_SHORT_1_5_5_5_REV;
GLInternal := Iff(Format = ifA1R5G5B5, GL_RGB5_A1, GL_RGB5);
end;
ifA4R4G4B4, ifX4R4G4B4:
begin
GLFormat := GL_BGRA_EXT;
GLType := GL_UNSIGNED_SHORT_4_4_4_4_REV;
GLInternal := Iff(Format = ifA4R4G4B4, GL_RGBA4, GL_RGB4);
end;
ifR8G8B8:
begin
GLFormat := GL_BGR_EXT;
GLType := GL_UNSIGNED_BYTE;
GLInternal := GL_RGB8;
end;
ifA8R8G8B8, ifX8R8G8B8:
begin
GLFormat := GL_BGRA_EXT;
GLType := GL_UNSIGNED_BYTE;
GLInternal := Iff(Format = ifA8R8G8B8, GL_RGBA8, GL_RGB8);
end;
ifR16G16B16, ifB16G16R16:
begin
GLFormat := Iff(Format = ifR16G16B16, GL_BGR_EXT, GL_RGB);
GLType := GL_UNSIGNED_SHORT;
GLInternal := GL_RGB16;
end;
ifA16R16G16B16, ifA16B16G16R16:
begin
GLFormat := Iff(Format = ifA16R16G16B16, GL_BGRA_EXT, GL_RGBA);
GLType := GL_UNSIGNED_SHORT;
GLInternal := GL_RGBA16;
end;
// Floating-Point formats
ifR32F:
begin
GLFormat := GL_RED;
GLType := GL_FLOAT;
GLInternal := GL_LUMINANCE32F_ARB;
end;
ifA32R32G32B32F, ifA32B32G32R32F:
begin
GLFormat := Iff(Format = ifA32R32G32B32F, GL_BGRA_EXT, GL_RGBA);
GLType := GL_FLOAT;
GLInternal := GL_RGBA32F_ARB;
end;
ifR16F:
begin
GLFormat := GL_RED;
GLType := GL_HALF_FLOAT_ARB;
GLInternal := GL_LUMINANCE16F_ARB;
end;
ifA16R16G16B16F, ifA16B16G16R16F:
begin
GLFormat := Iff(Format = ifA16R16G16B16F, GL_BGRA_EXT, GL_RGBA);
GLType := GL_HALF_FLOAT_ARB;
GLInternal := GL_RGBA16F_ARB;
end;
// Special formats
ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT;
ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT;
ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_EXT;
end;
Result := GLInternal <> 0;
end;
function LoadGLTextureFromFile(const FileName: string; CreatedWidth, CreatedHeight: PLongInt): GLuint;
var
Images: TDynImageDataArray;
begin
if LoadMultiImageFromFile(FileName, Images) and (Length(Images) > 0) then
begin
Result := CreateGLTextureFromMultiImage(Images, Images[0].Width,
Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight);
end
else
Result := 0;
FreeImagesInArray(Images);
end;
function LoadGLTextureFromStream(Stream: TStream; CreatedWidth, CreatedHeight: PLongInt): GLuint;
var
Images: TDynImageDataArray;
begin
if LoadMultiImageFromStream(Stream, Images) and (Length(Images) > 0) then
begin
Result := CreateGLTextureFromMultiImage(Images, Images[0].Width,
Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight);
end
else
Result := 0;
FreeImagesInArray(Images);
end;
function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt; CreatedWidth, CreatedHeight: PLongInt): GLuint;
var
Images: TDynImageDataArray;
begin
if LoadMultiImageFromMemory(Data, Size, Images) and (Length(Images) > 0) then
begin
Result := CreateGLTextureFromMultiImage(Images, Images[0].Width,
Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight);
end
else
Result := 0;
FreeImagesInArray(Images);
end;
function CreateGLTextureFromImage(const Image: TImageData;
Width, Height: LongInt; MipMaps: Boolean; OverrideFormat: TImageFormat;
CreatedWidth, CreatedHeight: PLongInt): GLuint;
var
Arr: TDynImageDataArray;
begin
// Just calls function operating on image arrays
SetLength(Arr, 1);
Arr[0] := Image;
Result := CreateGLTextureFromMultiImage(Arr, Width, Height, MipMaps, 0,
OverrideFormat, CreatedWidth, CreatedHeight);
end;
function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray;
Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat;
CreatedWidth, CreatedHeight: PLongInt): GLuint;
const
CompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5];
var
I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt;
Caps: TGLTextureCaps;
GLFormat: GLenum;
GLType: GLenum;
GLInternal: GLint;
Desired, ConvTo: TImageFormat;
Info: TImageFormatInfo;
LevelsArray: TDynImageDataArray;
NeedsResize, NeedsConvert: Boolean;
UnpackAlignment, UnpackSkipRows, UnpackSkipPixels, UnpackRowLength: LongInt;
procedure PasteImage(var Image: TImageData; Width, Height: LongInt);
var
Clone: TImageData;
begin
CloneImage(Image, Clone);
NewImage(Width, Height, Clone.Format, Image);
FillRect(Image, 0, 0, Width, Height, Clone.Bits);
CopyRect(Clone, 0, 0, Clone.Width, Clone.Height, Image, 0, 0);
FreeImage(Clone);
end;
begin
Result := 0;
ExistingLevels := Length(Images);
if GetGLTextureCaps(Caps) and (ExistingLevels > 0) then
try
// Check if requested main level is at valid index
if (MainLevelIndex < 0) or (MainLevelIndex > High(Images)) then
MainLevelIndex := 0;
// First check desired size and modify it if necessary
if Width <= 0 then Width := Images[MainLevelIndex].Width;
if Height <= 0 then Height := Images[MainLevelIndex].Height;
if Caps.PowerOfTwo then
begin
// If device supports only power of 2 texture sizes
Width := NextPow2(Width);
Height := NextPow2(Height);
end;
Width := ClampInt(Width, 1, Caps.MaxTextureSize);
Height := ClampInt(Height, 1, Caps.MaxTextureSize);
// Get various mipmap level counts and modify
// desired MipLevels if its value is invalid
PossibleLevels := GetNumMipMapLevels(Width, Height);
if MipMaps then
MipLevels := PossibleLevels
else
MipLevels := 1;
// Prepare array for mipmap levels. Make it larger than necessary - that
// way we can use the same index for input images and levels in the large loop below
SetLength(LevelsArray, MipLevels + MainLevelIndex);
// Now determine which image format will be used
if OverrideFormat = ifUnknown then
Desired := Images[MainLevelIndex].Format
else
Desired := OverrideFormat;
// Check if the hardware supports floating point and compressed textures
GetImageFormatInfo(Desired, Info);
if Info.IsFloatingPoint and not Caps.FloatTextures then
Desired := ifA8R8G8B8;
if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then
Desired := ifA8R8G8B8;
// Try to find GL format equivalent to image format and if it is not
// found use one of default formats
if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal) then
begin
GetImageFormatInfo(Desired, Info);
if Info.HasGrayChannel then
ConvTo := ifGray8
else
ConvTo := ifA8R8G8B8;
if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal) then
Exit;
end
else
ConvTo := Desired;
CurrentWidth := Width;
CurrentHeight := Height;
// If user is interested in width and height of created texture lets
// give him that
if CreatedWidth <> nil then CreatedWidth^ := CurrentWidth;
if CreatedHeight <> nil then CreatedHeight^ := CurrentHeight;
// Store old pixel unpacking settings
glGetIntegerv(GL_UNPACK_ALIGNMENT, @UnpackAlignment);
glGetIntegerv(GL_UNPACK_SKIP_ROWS, @UnpackSkipRows);
glGetIntegerv(GL_UNPACK_SKIP_PIXELS, @UnpackSkipPixels);
glGetIntegerv(GL_UNPACK_ROW_LENGTH, @UnpackRowLength);
// Set new pixel unpacking settings
glPixelStorei(GL_UNPACK_ALIGNMENT, 1);
glPixelStorei(GL_UNPACK_SKIP_ROWS, 0);
glPixelStorei(GL_UNPACK_SKIP_PIXELS, 0);
glPixelStorei(GL_UNPACK_ROW_LENGTH, 0);
// Generate new texture, bind it and set
glGenTextures(1, @Result);
glBindTexture(GL_TEXTURE_2D, Result);
if Byte(glIsTexture(Result)) <> GL_TRUE then
Exit;
for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do
begin
// Check if we can use input image array as a source for this mipmap level
if I < ExistingLevels then
begin
// Check if input image for this mipmap level has the right
// size and format
NeedsConvert := not (Images[I].Format = ConvTo);
if ConvTo in CompressedFormats then
begin
// Input images in DXTC will have min dimensions of 4, but we need
// current Width and Height to be lesser (for glCompressedTexImage2D)
NeedsResize := not ((Images[I].Width = Max(4, CurrentWidth)) and
(Images[I].Height = Max(4, CurrentHeight)));
end
else
NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight));
if NeedsResize or NeedsConvert then
begin
// Input image must be resized or converted to different format
// to become valid mipmap level
CloneImage(Images[I], LevelsArray[I]);
if NeedsConvert then
ConvertImage(LevelsArray[I], ConvTo);
if NeedsResize then
begin
if (not PasteNonPow2ImagesIntoPow2) or (LevelsArray[I].Width > CurrentWidth) or
(LevelsArray[I].Height > CurrentHeight)then
begin
// If pasteNP2toP2 is disabled or if source is bigger than target
// we rescale image, otherwise we paste it with the same size
ResizeImage(LevelsArray[I], CurrentWidth, CurrentHeight, rfBilinear)
end
else
PasteImage(LevelsArray[I], CurrentWidth, CurrentHeight);
end;
end
else
// Input image can be used without any changes
LevelsArray[I] := Images[I];
end
else
begin
// This mipmap level is not present in the input image array
// so we create a new level
FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]);
end;
if ConvTo in CompressedFormats then
begin
// Note: GL DXTC texture snaller than 4x4 must have width and height
// as expected for non-DXTC texture (like 1x1 - we cannot
// use LevelsArray[I].Width and LevelsArray[I].Height - they are
// at least 4 for DXTC images). But Bits and Size passed to
// glCompressedTexImage2D must contain regular 4x4 DXTC block.
glCompressedTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth,
CurrentHeight, 0, LevelsArray[I].Size, LevelsArray[I].Bits)
end
else
begin
glTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth,
CurrentHeight, 0, GLFormat, GLType, LevelsArray[I].Bits);
end;
// Calculate width and height of the next mipmap level
CurrentWidth := ClampInt(CurrentWidth div 2, 1, CurrentWidth);
CurrentHeight := ClampInt(CurrentHeight div 2, 1, CurrentHeight);
end;
// Restore old pixel unpacking settings
glPixelStorei(GL_UNPACK_ALIGNMENT, UnpackAlignment);
glPixelStorei(GL_UNPACK_SKIP_ROWS, UnpackSkipRows);
glPixelStorei(GL_UNPACK_SKIP_PIXELS, UnpackSkipPixels);
glPixelStorei(GL_UNPACK_ROW_LENGTH, UnpackRowLength);
finally
// Free local image copies
for I := 0 to Length(LevelsArray) - 1 do
begin
if ((I < ExistingLevels) and (LevelsArray[I].Bits <> Images[I].Bits)) or
(I >= ExistingLevels) then
FreeImage(LevelsArray[I]);
end;
end;
end;
function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean;
var
Arr: TDynImageDataArray;
Fmt: TImageFileFormat;
IsDDS: Boolean;
begin
Result := CreateMultiImageFromGLTexture(Texture, Arr);
if Result then
begin
Fmt := FindImageFileFormatByName(FileName);
if Fmt <> nil then
begin
IsDDS := SameText(Fmt.Extensions[0], 'dds');
if IsDDS then
begin
PushOptions;
SetOption(ImagingDDSSaveMipMapCount, Length(Arr));
end;
Result := SaveMultiImageToFile(FileName, Arr);
if IsDDS then
PopOptions;
end;
FreeImagesInArray(Arr);
end;
end;
function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean;
var
Arr: TDynImageDataArray;
Fmt: TImageFileFormat;
IsDDS: Boolean;
begin
Result := CreateMultiImageFromGLTexture(Texture, Arr);
if Result then
begin
Fmt := FindImageFileFormatByExt(Ext);
if Fmt <> nil then
begin
IsDDS := SameText(Fmt.Extensions[0], 'dds');
if IsDDS then
begin
PushOptions;
SetOption(ImagingDDSSaveMipMapCount, Length(Arr));
end;
Result := SaveMultiImageToStream(Ext, Stream, Arr);
if IsDDS then
PopOptions;
end;
FreeImagesInArray(Arr);
end;
end;
function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean;
var
Arr: TDynImageDataArray;
Fmt: TImageFileFormat;
IsDDS: Boolean;
begin
Result := CreateMultiImageFromGLTexture(Texture, Arr);
if Result then
begin
Fmt := FindImageFileFormatByExt(Ext);
if Fmt <> nil then
begin
IsDDS := SameText(Fmt.Extensions[0], 'dds');
if IsDDS then
begin
PushOptions;
SetOption(ImagingDDSSaveMipMapCount, Length(Arr));
end;
Result := SaveMultiImageToMemory(Ext, Data, Size, Arr);
if IsDDS then
PopOptions;
end;
FreeImagesInArray(Arr);
end;
end;
function CreateImageFromGLTexture(const Texture: GLuint;
var Image: TImageData; OverrideFormat: TImageFormat): Boolean;
var
Arr: TDynImageDataArray;
begin
// Just calls function operating on image arrays
FreeImage(Image);
SetLength(Arr, 1);
Result := CreateMultiImageFromGLTexture(Texture, Arr, 1, OverrideFormat);
Image := Arr[0];
end;
function CreateMultiImageFromGLTexture(const Texture: GLuint;
var Images: TDynImageDataArray; MipLevels: LongInt; OverrideFormat: TImageFormat): Boolean;
var
I, Width, Height, ExistingLevels: LongInt;
begin
FreeImagesInArray(Images);
SetLength(Images, 0);
Result := False;
if Byte(glIsTexture(Texture)) = GL_TRUE then
begin
// Check if desired mipmap level count is valid
glBindTexture(GL_TEXTURE_2D, Texture);
if MipLevels <= 0 then
MipLevels := GetNumMipMapLevels(Width, Height);
SetLength(Images, MipLevels);
ExistingLevels := 0;
for I := 0 to MipLevels - 1 do
begin
// Get the current level size
glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_WIDTH, @Width);
glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_HEIGHT, @Height);
// Break when the mipmap chain is broken
if (Width = 0) or (Height = 0) then
Break;
// Create new image and copy texture data
NewImage(Width, Height, ifA8R8G8B8, Images[I]);
glGetTexImage(GL_TEXTURE_2D, I, GL_BGRA_EXT, GL_UNSIGNED_BYTE, Images[I].Bits);
Inc(ExistingLevels);
end;
// Resize mipmap array if necessary
if MipLevels <> ExistingLevels then
SetLength(Images, ExistingLevels);
// Convert images to desired format if set
if OverrideFormat <> ifUnknown then
for I := 0 to Length(Images) - 1 do
ConvertImage(Images[I], OverrideFormat);
Result := True;
end;
end;
initialization
{
File Notes:
-- TODOS ----------------------------------------------------
- use internal format of texture in CreateMultiImageFromGLTexture
not only A8R8G8B8
- support for cube and 3D maps
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Added PasteNonPow2ImagesIntoPow2 option and related functionality.
- Better NeedsResize determination for small DXTC textures -
avoids needless resizing.
- Added MainLevelIndex to CreateMultiImageFromGLTexture.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Added CreatedWidth and CreatedHeight parameters to most
LoadGLTextureFromXXX/CreateGLTextureFromXXX functions.
-- 0.19 Changes/Bug Fixes -----------------------------------
- fixed bug in CreateGLTextureFromMultiImage which caused assert failure
when creating mipmaps (using FillMipMapLevel) for DXTC formats
- changed single channel floating point texture formats from
GL_INTENSITY..._ARB to GL_LUMINANCE..._ARB
- added support for half float texture formats (GL_RGBA16F_ARB etc.)
-- 0.17 Changes/Bug Fixes -----------------------------------
- filtered mipmap creation
- more texture caps added
- fixed memory leaks in SaveGLTextureTo... functions
-- 0.15 Changes/Bug Fixes -----------------------------------
- unit created and initial stuff added
}
end.

240
Imaging/ImagingOptions.inc Normal file
View File

@@ -0,0 +1,240 @@
{ $Id: ImagingOptions.inc 100 2007-06-28 21:09:52Z galfar $ }
{
User Options
Following defines and options can be changed by user.
}
{ Source options. }
{$DEFINE USE_INLINE} // use function inlining for some functions
// works in Free Pascal and Delphi 9+
{$DEFINE USE_ASM} // if defined, assembler versions of some
// functions will be used (only for x86)
{ $DEFINE DEBUG} // if defined, debug info, range/IO/overflow
// checking, stack frames, assertions, and
// other debugging options will be turned on
{ File format support linking options. Undefine formats which you don't want
to be registred automatically. }
{.$DEFINE LINK_JPEG} // link support for Jpeg images
{.$DEFINE LINK_PNG} // link support for PNG images
{$DEFINE LINK_TARGA} // link support for Targa images
{$DEFINE LINK_BITMAP} // link support for Windows Bitmap images
{.$DEFINE LINK_DDS} // link support for DDS images
{.$DEFINE LINK_GIF} // link support for GIF images
{.$DEFINE LINK_MNG} // link support for MNG images
{.$DEFINE LINK_JNG} // link support for JNG images
{.$DEFINE LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
{.$DEFINE LINK_EXTRAS} // link support for file formats defined in
// Extras package. Exactly which formats will be
// registered depends on settings in
// ImagingExtras.pas unit.
{ Component set used in ImagignComponents.pas unit. You usually don't need
to be concerned with this - proper component library is selected automatically
according to your compiler (only exception is using CLX in Delphi 6/7). }
{$DEFINE COMPONENT_SET_VCL} // use Borland's VCL
{ $DEFINE COMPONENT_SET_CLX} // use Borland's CLX (set automatically when using Kylix,
// must be se manually when compiling with Delphi 6/7)
{ $DEFINE COMPONENT_SET_LCL} // use Lazarus' LCL (set automatically when
// compiling with FPC)
{
Auto Options
Following options and defines are set automatically and some
are required for Imaging to compile successfully. Do not change
anything here if you don't know what you are doing.
}
{ Compiler options }
{$ALIGN ON} // Field alignment: 8 Bytes (in D6+)
{$BOOLEVAL OFF} // Boolean eval: off
{$EXTENDEDSYNTAX ON} // Extended syntax: on
{$LONGSTRINGS ON} // string = AnsiString: on
{$MINENUMSIZE 4} // Min enum size: 4 B
{$TYPEDADDRESS OFF} // Typed pointers: off
{$WRITEABLECONST OFF} // Writeable constants: off
{$IFNDEF FPC}
{$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/Kylix)
// others are not supported
{$ENDIF}
{$IFDEF DCC}
{$IFDEF LINUX}
{$DEFINE KYLIX} // using Kylix
{$ENDIF}
{$ENDIF}
{$IFDEF DCC}
{$IFNDEF KYLIX}
{$DEFINE DELPHI} // using Delphi
{$ENDIF}
{$ENDIF}
{$IF (Defined(DCC) and (CompilerVersion >= 18.5))}
{$IFDEF RELEASE}
{$UNDEF DEBUG} // If we are using Delphi 2007+ where you can set
// DEBUG/RELEASE mode in project options and RELEASE
// is currently set we undef DEBUG mode
{$ENDIF}
{$IFEND}
{$IFDEF DEBUG}
{$ASSERTIONS ON}
{$DEBUGINFO ON}
{$RANGECHECKS ON}
{$IOCHECKS ON}
{$OVERFLOWCHECKS ON}
{$IFDEF DCC}
{$OPTIMIZATION OFF}
{$STACKFRAMES ON}
{$LOCALSYMBOLS ON}
{ $DEFINE MEMCHECK}
{$ENDIF}
{$IFDEF FPC}
{$S+}
{$CHECKPOINTER ON}
{$ENDIF}
{$ELSE}
{$ASSERTIONS OFF}
{$DEBUGINFO OFF}
{$RANGECHECKS OFF}
{$IOCHECKS OFF}
{$OVERFLOWCHECKS OFF}
{$IFDEF DCC}
{$OPTIMIZATION ON}
{$STACKFRAMES OFF}
{$LOCALSYMBOLS OFF}
{$ENDIF}
{$IFDEF FPC}
{$S-}
{$ENDIF}
{$ENDIF}
{ Compiler capabilities }
// Define if compiler supports inlining of functions and procedures
// Note that FPC inline support crashed in older versions (1.9.8)
{$IF (Defined(DCC) and (CompilerVersion >= 17)) or (Defined(FPC) and Defined(CPU86))}
{$DEFINE HAS_INLINE}
{$IFEND}
// Define if compiler supports advanced records with methods
{$IF (Defined(DCC) and (CompilerVersion >= 18)) }
{$DEFINE HAS_ADVANCED_RECORDS}
{$IFEND}
// Define if compiler supports operator overloading
// (unfortunately Delphi and FPC operator overloaing is not compatible)
{$IF (Defined(DCC) and (CompilerVersion >= 18)) or Defined(FPC)}
{$DEFINE HAS_OPERATOR_OVERLOADING}
{$IFEND}
{ Imaging options check}
{$IFNDEF HAS_INLINE}
{$UNDEF USE_INLINE}
{$ENDIF}
{$IFDEF FPC}
{$IFNDEF CPU86}
{$UNDEF USE_ASM}
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$ENDIF}
{$IFDEF KYLIX}
{$DEFINE COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF DELPHI}
{$UNDEF COMPONENT_SET_LCL}
{$IF CompilerVersion >= 17}
{$UNDEF COMPONENT_SET_CLX} // Delphi 9+ has no CLX
{$IFEND}
{$IFNDEF COMPONENT_SET_VCL}
{$IFNDEF COMPONENT_SET_CLX}
{$DEFINE COMPONENT_SET_VCL} // use VCL as default if not set
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$ENDIF}
{ Platform options }
{$IFDEF WIN32}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$IFDEF DPMI}
{$DEFINE MSDOS}
{$ENDIF}
{$IFDEF LINUX}
{$DEFINE UNIX}
{$ENDIF}
{ More compiler options }
{$IFDEF FPC} // Free Pascal options - some options set above (like min enum size)
// are reset to defaults by setting {$MODE} so they are
// redeclared here
{$MODE DELPHI} // compatible with delphi
{$GOTO ON} // alow goto
{$PACKRECORDS 8} // same as ALING 8 for Delphi
{$PACKENUM 4} // Min enum size: 4 B
{$CALLING REGISTER} // default calling convention is register
{$IFDEF CPU86}
{$IFNDEF DYN_LIBRARY}
{$SMARTLINK ON} // smartlinking on, but not for dll/so -
// nothing gets exported from library when it is on
// in FPC 1.9.8
{$ENDIF}
{$ASMMODE INTEL} // intel assembler mode
{$ENDIF}
{$ENDIF}
{$IFDEF HAS_INLINE}
{$INLINE ON} // turns inlining on for compilers that support it
{$ENDIF}
{ Extension dependencies check }
{$IFDEF LINK_MNG} // MNG uses internaly both PNG and JNG
{$DEFINE LINK_JNG}
{$DEFINE LINK_PNG}
{$ENDIF}
{$IFDEF LINK_JNG} // JNG uses internaly both PNG and JPEG
{$DEFINE LINK_PNG}
{$DEFINE LINK_JPEG}
{$ENDIF}

965
Imaging/ImagingPortableMaps.pas Normal file
View File

@@ -0,0 +1,965 @@
{
$Id: ImagingPortableMaps.pas 107 2007-11-06 23:37:48Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains loader/saver for Portable Maps file format family (or PNM).
That includes PBM, PGM, PPM, PAM, and PFM formats.}
unit ImagingPortableMaps;
{$I ImagingOptions.inc}
interface
uses
SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
type
{ Types of pixels of PNM images.}
TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha,
ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP);
{ Record with info about PNM image used in both loading and saving functions.}
TPortableMapInfo = record
Width: LongInt;
Height: LongInt;
FormatId: Char;
MaxVal: LongInt;
BitCount: LongInt;
Depth: LongInt;
TupleType: TTupleType;
Binary: Boolean;
HasPAMHeader: Boolean;
IsBigEndian: Boolean;
end;
{ Base class for Portable Map file formats (or Portable AnyMaps or PNM).
There are several types of PNM file formats that share common
(simple) structure. This class can actually load all supported PNM formats.
Saving is also done by this class but descendants (each for different PNM
format) control it.}
TPortableMapFileFormat = class(TImageFileFormat)
protected
FIdNumbers: TChar2;
FSaveBinary: LongBool;
FMapInfo: TPortableMapInfo;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ If set to True images will be saved in binary format. If it is False
they will be saved in text format (which could result in 5-10x bigger file).
Default is value True. Note that PAM and PFM files are always saved in binary.}
property SaveBinary: LongBool read FSaveBinary write FSaveBinary;
end;
{ Portable Bit Map is used to store monochrome 1bit images. Raster data
can be saved as text or binary data. Either way value of 0 represents white
and 1 is black. As Imaging does not have support for 1bit data formats
PBM images can be loaded but not saved. Loaded images are returned in
ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
TPBMFileFormat = class(TPortableMapFileFormat)
public
constructor Create; override;
end;
{ Portable Gray Map is used to store grayscale 8bit or 16bit images.
Raster data can be saved as text or binary data.}
TPGMFileFormat = class(TPortableMapFileFormat)
protected
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
Raster data can be saved as text or binary data.}
TPPMFileFormat = class(TPortableMapFileFormat)
protected
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Arbitrary Map is format that can store image data formats
of PBM, PGM, and PPM formats with optional alpha channel. Raster data
can be stored only in binary format. All data formats supported
by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
TPAMFileFormat = class(TPortableMapFileFormat)
protected
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Float Map is unofficial extension of PNM format family which
can store images with floating point pixels. Raster data is saved in
binary format as array of IEEE 32 bit floating point numbers. One channel
or RGB images are supported by PFM format (so no alpha).}
TPFMFileFormat = class(TPortableMapFileFormat)
protected
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
implementation
const
PortableMapDefaultBinary = True;
SPBMFormatName = 'Portable Bit Map';
SPBMMasks = '*.pbm';
SPGMFormatName = 'Portable Gray Map';
SPGMMasks = '*.pgm';
PGMSupportedFormats = [ifGray8, ifGray16];
SPPMFormatName = 'Portable Pixel Map';
SPPMMasks = '*.ppm';
PPMSupportedFormats = [ifR8G8B8, ifR16G16B16];
SPAMFormatName = 'Portable Arbitrary Map';
SPAMMasks = '*.pam';
PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
SPFMFormatName = 'Portable Float Map';
SPFMMasks = '*.pfm';
PFMSupportedFormats = [ifR32F, ifA32B32G32R32F];
const
{ TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
WhiteSpaces = [#9, #10, #13, #32];
SPAMWidth = 'WIDTH';
SPAMHeight = 'HEIGHT';
SPAMDepth = 'DEPTH';
SPAMMaxVal = 'MAXVAL';
SPAMTupleType = 'TUPLTYPE';
SPAMEndHdr = 'ENDHDR';
{ Size of buffer used to speed up text PNM loading/saving.}
LineBufferCapacity = 16 * 1024;
TupleTypeNames: array[TTupleType] of string = (
'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB',
'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP',
'RGBFP');
{ TPortableMapFileFormat }
constructor TPortableMapFileFormat.Create;
begin
inherited Create;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FSaveBinary := PortableMapDefaultBinary;
end;
function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
I, ScanLineSize, MonoSize: LongInt;
Dest: PByte;
MonoData: Pointer;
Info: TImageFormatInfo;
PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of Char;
LineEnd, LinePos: LongInt;
procedure CheckBuffer;
begin
if (LineEnd = 0) or (LinePos = LineEnd) then
begin
// Reload buffer if its is empty or its end was reached
LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity);
LinePos := 0;
end;
end;
procedure FixInputPos;
begin
// Sets input's position to its real pos as it would be without buffering
if LineEnd > 0 then
begin
GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent);
LineEnd := 0;
end;
end;
function ReadString: string;
var
S: AnsiString;
C: Char;
begin
// First skip all whitespace chars
SetLength(S, 1);
repeat
CheckBuffer;
S[1] := LineBuffer[LinePos];
Inc(LinePos);
if S[1] = '#' then
repeat
// Comment detected, skip everything until next line is reached
CheckBuffer;
S[1] := LineBuffer[LinePos];
Inc(LinePos);
until S[1] = #10;
until not(S[1] in WhiteSpaces);
// Now we have reached some chars other than white space, read them until
// there is whitespace again
repeat
SetLength(S, Length(S) + 1);
CheckBuffer;
S[Length(S)] := LineBuffer[LinePos];
Inc(LinePos);
// Repeat until current char is whitespace or end of file is reached
// (Line buffer has 0 bytes which happens only on EOF)
until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0);
// Get rid of last char - whitespace or null
SetLength(S, Length(S) - 1);
// Move position to the beginning of next string (skip white space - needed
// to make the loader stop at the right input position)
repeat
CheckBuffer;
C := LineBuffer[LinePos];
Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0);
// Dec pos, current is the beggining of the the string
Dec(LinePos);
Result := S;
end;
function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := StrToInt(ReadString);
end;
function ParseHeader: Boolean;
var
Id: TChar2;
I: TTupleType;
TupleTypeName: string;
Scale: Single;
OldSeparator: Char;
begin
Result := False;
with GetIO do
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
Read(Handle, @Id, SizeOf(Id));
if Id[1] in ['1'..'6'] then
begin
// Read header for PBM, PGM, and PPM files
FMapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue;
if Id[1] in ['1', '4'] then
begin
FMapInfo.MaxVal := 1;
FMapInfo.BitCount := 1
end
else
begin
// Read channel max value, <=255 for 8bit images, >255 for 16bit images
// but some programs think its max colors so put <=256 here
FMapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16);
end;
FMapInfo.Depth := 1;
case Id[1] of
'1', '4': FMapInfo.TupleType := ttBlackAndWhite;
'2', '5': FMapInfo.TupleType := ttGrayScale;
'3', '6':
begin
FMapInfo.TupleType := ttRGB;
FMapInfo.Depth := 3;
end;
end;
end
else if Id[1] = '7' then
begin
// Read values from PAM header
// WIDTH
if (ReadString <> SPAMWidth) then Exit;
FMapInfo.Width := ReadIntValue;
// HEIGHT
if (ReadString <> SPAMheight) then Exit;
FMapInfo.Height := ReadIntValue;
// DEPTH
if (ReadString <> SPAMDepth) then Exit;
FMapInfo.Depth := ReadIntValue;
// MAXVAL
if (ReadString <> SPAMMaxVal) then Exit;
FMapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16);
// TUPLETYPE
if (ReadString <> SPAMTupleType) then Exit;
TupleTypeName := ReadString;
for I := Low(TTupleType) to High(TTupleType) do
if SameText(TupleTypeName, TupleTypeNames[I]) then
begin
FMapInfo.TupleType := I;
Break;
end;
// ENDHDR
if (ReadString <> SPAMEndHdr) then Exit;
end
else if Id[1] in ['F', 'f'] then
begin
// Read header of PFM file
FMapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue;
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
Scale := StrToFloatDef(ReadString, 0);
DecimalSeparator := OldSeparator;
FMapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then
FMapInfo.TupleType := ttRGBFP
else
FMapInfo.TupleType := ttGrayScaleFP;
FMapInfo.Depth := Iff(FMapInfo.TupleType = ttRGBFP, 3, 1);
FMapInfo.BitCount := Iff(FMapInfo.TupleType = ttRGBFP, 96, 32);
end;
FixInputPos;
FMapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
// Check if values found in header are valid
Result := (FMapInfo.Width > 0) and (FMapInfo.Height > 0) and
(FMapInfo.BitCount in [1, 8, 16, 32, 96]) and (FMapInfo.TupleType <> ttInvalid);
// Now check if image has proper number of channels (PAM)
if Result then
case FMapInfo.TupleType of
ttBlackAndWhite, ttGrayScale: Result := FMapInfo.Depth = 1;
ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := FMapInfo.Depth = 2;
ttRGB: Result := FMapInfo.Depth = 3;
ttRGBAlpha: Result := FMapInfo.Depth = 4;
end;
end;
end;
begin
Result := False;
LineEnd := 0;
LinePos := 0;
SetLength(Images, 1);
with GetIO, Images[0] do
begin
Format := ifUnknown;
// Try to parse file header
if not ParseHeader then Exit;
// Select appropriate data format based on values read from file header
case FMapInfo.TupleType of
ttBlackAndWhite: Format := ifGray8;
ttBlackAndWhiteAlpha: Format := ifA8Gray8;
ttGrayScale: Format := IffFormat(FMapInfo.BitCount = 8, ifGray8, ifGray16);
ttGrayScaleAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
ttRGB: Format := IffFormat(FMapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifA32B32G32R32F;
end;
// Exit if no matching data format was found
if Format = ifUnknown then Exit;
NewImage(FMapInfo.Width, FMapInfo.Height, Format, Images[0]);
Info := GetFormatInfo(Format);
// Now read pixels from file to dest image
if not FMapInfo.Binary then
begin
Dest := Bits;
for I := 0 to Width * Height - 1 do
begin
case Format of
ifGray8:
begin
Dest^ := ReadIntValue;
if FMapInfo.BitCount = 1 then
// If source is 1bit mono image (where 0=white, 1=black)
// we must scale it to 8bits
Dest^ := 255 - Dest^ * 255;
end;
ifGray16: PWord(Dest)^ := ReadIntValue;
ifR8G8B8:
with PColor24Rec(Dest)^ do
begin
R := ReadIntValue;
G := ReadIntValue;
B := ReadIntValue;
end;
ifR16G16B16:
with PColor48Rec(Dest)^ do
begin
R := ReadIntValue;
G := ReadIntValue;
B := ReadIntValue;
end;
end;
Inc(Dest, Info.BytesPerPixel);
end;
end
else
begin
if FMapInfo.BitCount > 1 then
begin
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Just copy bytes from binary Portable Maps (non 1bit, non FP)
Read(Handle, Bits, Size);
end
else
begin
Dest := Bits;
// FP images are in BGR order and endian swap maybe needed.
// Some programs store scanlines in bottom-up order but
// I will stick with Photoshops behaviour here
for I := 0 to Width * Height - 1 do
begin
Read(Handle, @PixelFP, FMapInfo.BitCount shr 3);
if FMapInfo.TupleType = ttRGBFP then
with PColorFPRec(Dest)^ do
begin
A := 1.0;
R := PixelFP.R;
G := PixelFP.G;
B := PixelFP.B;
if FMapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 3);
end
else
begin
PSingle(Dest)^ := PixelFP.B;
if FMapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 1);
end;
Inc(Dest, Info.BytesPerPixel);
end;
end;
if FMapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
begin
// Black and white PAM files must be scaled to 8bits. Note that
// in PAM files 1=white, 0=black (reverse of PBM)
for I := 0 to Width * Height * Iff(FMapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
end;
if FMapInfo.TupleType in [ttRGB, ttRGBAlpha] then
begin
// Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
SwapChannels(Images[0], ChannelBlue, ChannelRed);
end;
if FMapInfo.BitCount = 16 then
begin
Dest := Bits;
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
begin
PWord(Dest)^ := SwapEndianWord(PWord(Dest)^);
Inc(Dest, SizeOf(Word));
end;
end;
end
else
begin
// Handle binary PBM files (ttBlackAndWhite 1bit)
ScanLineSize := (Width + 7) div 8;
// Get total binary data size, read it from file to temp
// buffer and convert the data to Gray8
MonoSize := ScanLineSize * Height;
GetMem(MonoData, MonoSize);
try
Read(Handle, MonoData, MonoSize);
Convert1To8(MonoData, Bits, Width, Height, ScanLineSize);
// 1bit mono images must be scaled to 8bit (where 0=white, 1=black)
for I := 0 to Width * Height - 1 do
PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
finally
FreeMem(MonoData);
end;
end;
end;
FixInputPos;
if (FMapInfo.MaxVal <> Pow2Int(FMapInfo.BitCount) - 1) and
(FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
begin
Dest := Bits;
// Scale color values according to MaxVal we got from header
// if necessary.
for I := 0 to Width * Height * Info.BytesPerPixel div (FMapInfo.BitCount shr 3) - 1 do
begin
if FMapInfo.BitCount = 8 then
Dest^ := Dest^ * 255 div FMapInfo.MaxVal
else
PWord(Dest)^ := PWord(Dest)^ * 65535 div FMapInfo.MaxVal;
Inc(Dest, FMapInfo.BitCount shr 3);
end;
end;
Result := True;
end;
end;
function TPortableMapFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const
LineDelimiter = #10;
PixelDelimiter = #32;
var
ImageToSave: TImageData;
MustBeFreed: Boolean;
Info: TImageFormatInfo;
I, LineLength: LongInt;
Src: PByte;
Pixel32: TColor32Rec;
Pixel64: TColor64Rec;
W: Word;
procedure WriteString(S: string; Delimiter: Char = LineDelimiter);
begin
SetLength(S, Length(S) + 1);
S[Length(S)] := Delimiter;
GetIO.Write(Handle, @S[1], Length(S));
Inc(LineLength, Length(S));
end;
procedure WriteHeader;
var
OldSeparator: Char;
begin
WriteString('P' + FMapInfo.FormatId);
if not FMapInfo.HasPAMHeader then
begin
// Write header of PGM, PPM, and PFM files
WriteString(IntToStr(ImageToSave.Width));
WriteString(IntToStr(ImageToSave.Height));
case FMapInfo.TupleType of
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(FMapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP:
begin
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
// Negative value indicates that raster data is saved in little endian
WriteString(FloatToStr(-1.0));
DecimalSeparator := OldSeparator;
end;
end;
end
else
begin
// Write PAM file header
WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
WriteString(Format('%s %d', [SPAMDepth, FMapInfo.Depth]));
WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(FMapInfo.BitCount) - 1]));
WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[FMapInfo.TupleType]]));
WriteString(SPAMEndHdr);
end;
end;
begin
Result := False;
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with GetIO, ImageToSave do
try
Info := GetFormatInfo(Format);
// Fill values of MapInfo record that were not filled by
// descendants in their SaveData methods
FMapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
FMapInfo.Depth := Info.ChannelCount;
if FMapInfo.TupleType = ttInvalid then
begin
if Info.HasGrayChannel then
begin
if Info.HasAlphaChannel then
FMapInfo.TupleType := ttGrayScaleAlpha
else
FMapInfo.TupleType := ttGrayScale;
end
else
begin
if Info.HasAlphaChannel then
FMapInfo.TupleType := ttRGBAlpha
else
FMapInfo.TupleType := ttRGB;
end;
end;
// Write file header
WriteHeader;
if not FMapInfo.Binary then
begin
Src := Bits;
LineLength := 0;
// For each pixel find its text representation and write it to file
for I := 0 to Width * Height - 1 do
begin
case Format of
ifGray8: WriteString(IntToStr(Src^), PixelDelimiter);
ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter);
ifR8G8B8:
with PColor24Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
ifR16G16B16:
with PColor48Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
end;
// Lines in text PNM images should have length <70
if LineLength > 65 then
begin
LineLength := 0;
WriteString('', LineDelimiter);
end;
Inc(Src, Info.BytesPerPixel);
end;
end
else
begin
// Write binary images
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Save integer binary images
if FMapInfo.BitCount = 8 then
begin
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 8bit grayscale images can be written in one Write call
Write(Handle, Bits, Size);
end
else
begin
// 8bit RGB/ARGB images: read and blue must be swapped and
// 3 or 4 bytes must be written
Src := Bits;
for I := 0 to Width * Height - 1 do
with PColor32Rec(Src)^ do
begin
if FMapInfo.TupleType = ttRGBAlpha then
Pixel32.A := A;
Pixel32.R := B;
Pixel32.G := G;
Pixel32.B := R;
Write(Handle, @Pixel32, Info.BytesPerPixel);
Inc(Src, Info.BytesPerPixel);
end;
end;
end
else
begin
// Images with 16bit channels: make sure that channel values are saved in big endian
Src := Bits;
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 16bit grayscale image
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
begin
W := SwapEndianWord(PWord(Src)^);
Write(Handle, @W, SizeOf(Word));
Inc(Src, SizeOf(Word));
end;
end
else
begin
// RGB images with 16bit channels: swap RB and endian too
for I := 0 to Width * Height - 1 do
with PColor64Rec(Src)^ do
begin
if FMapInfo.TupleType = ttRGBAlpha then
Pixel64.A := SwapEndianWord(A);
Pixel64.R := SwapEndianWord(B);
Pixel64.G := SwapEndianWord(G);
Pixel64.B := SwapEndianWord(R);
Write(Handle, @Pixel64, Info.BytesPerPixel);
Inc(Src, Info.BytesPerPixel);
end;
end;
end;
end
else
begin
// Floating point images (no need to swap endian here - little
// endian is specified in file header)
if FMapInfo.TupleType = ttGrayScaleFP then
begin
// Grayscale images can be written in one Write call
Write(Handle, Bits, Size);
end
else
begin
// Expected data format of PFM RGB file is B32G32R32F which is not
// supported by Imaging. We must write pixels one by one and
// write only RGB part of A32B32G32B32 image.
Src := Bits;
for I := 0 to Width * Height - 1 do
begin
Write(Handle, Src, SizeOf(Single) * 3);
Inc(Src, Info.BytesPerPixel);
end;
end;
end;
end;
Result := True;
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Id: TChar4;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
ReadCount := Read(Handle, @Id, SizeOf(Id));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and
(Id[2] in WhiteSpaces);
end;
end;
{ TPBMFileFormat }
constructor TPBMFileFormat.Create;
begin
inherited Create;
FName := SPBMFormatName;
FCanSave := False;
AddMasks(SPBMMasks);
FIdNumbers := '14';
end;
{ TPGMFileFormat }
constructor TPGMFileFormat.Create;
begin
inherited Create;
FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks);
RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
FIdNumbers := '25';
end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index);
end;
procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
// All FP images go to 16bit
ConvFormat := ifGray16
else if Info.HasGrayChannel then
// Grayscale will be 8 or 16 bit - depends on input's bitcount
ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
ifGray16, ifGray8)
else if Info.BytesPerPixel > 4 then
// Large bitcounts -> 16bit
ConvFormat := ifGray16
else
// Rest of the formats -> 8bit
ConvFormat := ifGray8;
ConvertImage(Image, ConvFormat);
end;
{ TPPMFileFormat }
constructor TPPMFileFormat.Create;
begin
inherited Create;
FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks);
RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
FIdNumbers := '36';
end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index);
end;
procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
// All FP images go to 48bit RGB
ConvFormat := ifR16G16B16
else if Info.HasGrayChannel then
// Grayscale will be 24 or 48 bit RGB - depends on input's bitcount
ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
ifR16G16B16, ifR8G8B8)
else if Info.BytesPerPixel > 4 then
// Large bitcounts -> 48bit RGB
ConvFormat := ifR16G16B16
else
// Rest of the formats -> 24bit RGB
ConvFormat := ifR8G8B8;
ConvertImage(Image, ConvFormat);
end;
{ TPAMFileFormat }
constructor TPAMFileFormat.Create;
begin
inherited Create;
FName := SPAMFormatName;
FSupportedFormats := PAMSupportedFormats;
AddMasks(SPAMMasks);
FIdNumbers := '77';
end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := FIdNumbers[0];
FMapInfo.Binary := True;
FMapInfo.HasPAMHeader := True;
Result := inherited SaveData(Handle, Images, Index);
end;
procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16)
else if Info.HasGrayChannel then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
else
begin
if Info.BytesPerPixel <= 4 then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
else
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16);
end;
ConvertImage(Image, ConvFormat);
end;
{ TPFMFileFormat }
constructor TPFMFileFormat.Create;
begin
inherited Create;
FName := SPFMFormatName;
AddMasks(SPFMMasks);
FIdNumbers := 'Ff';
FSupportedFormats := PFMSupportedFormats;
end;
function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
Info: TImageFormatInfo;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then
FMapInfo.TupleType := ttRGBFP
else
FMapInfo.TupleType := ttGrayScaleFP;
FMapInfo.FormatId := Iff(FMapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := True;
Result := inherited SaveData(Handle, Images, Index);
end;
procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
if (Info.ChannelCount > 1) or Info.IsIndexed then
ConvertImage(Image, ifA32B32G32R32F)
else
ConvertImage(Image, ifR32F);
end;
initialization
RegisterImageFileFormat(TPBMFileFormat);
RegisterImageFileFormat(TPGMFileFormat);
RegisterImageFileFormat(TPPMFileFormat);
RegisterImageFileFormat(TPAMFileFormat);
RegisterImageFileFormat(TPFMFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.21 Changes/Bug Fixes -----------------------------------
- Made modifications to ASCII PNM loading to be more "stream-safe".
- Fixed bug: indexed images saved as grayscale in PFM.
- Changed converting to supported formats little bit.
- Added scaling of channel values (non-FP and non-mono images) according
to MaxVal.
- Added buffering to loading of PNM files. More than 10x faster now
for text files.
- Added saving support to PGM, PPM, PAM, and PFM format.
- Added PFM file format.
- Initial version created.
}
end.

623
Imaging/ImagingTarga.pas Normal file
View File

@@ -0,0 +1,623 @@
{
$Id: ImagingTarga.pas 84 2007-05-27 13:54:27Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for Targa images.}
unit ImagingTarga;
{$I ImagingOptions.inc}
interface
uses
ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
type
{ Class for loading and saving Truevision Targa images.
It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
24 bit RGB and 32 bit ARGB images with or without RLE compression.}
TTargaFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
ImagingTargaRLE option.}
property UseRLE: LongBool read FUseRLE write FUseRLE;
end;
implementation
const
STargaFormatName = 'Truevision Targa Image';
STargaMasks = '*.tga';
TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
ifR8G8B8, ifA8R8G8B8];
TargaDefaultRLE = False;
const
STargaSignature = 'TRUEVISION-XFILE';
type
{ Targa file header.}
TTargaHeader = packed record
IDLength: Byte;
ColorMapType: Byte;
ImageType: Byte;
ColorMapOff: Word;
ColorMapLength: Word;
ColorEntrySize: Byte;
XOrg: SmallInt;
YOrg: SmallInt;
Width: SmallInt;
Height: SmallInt;
PixelSize: Byte;
Desc: Byte;
end;
{ Footer at the end of TGA file.}
TTargaFooter = packed record
ExtOff: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset
Signature: array[0..15] of Char; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0
end;
{ TTargaFileFormat class implementation }
constructor TTargaFileFormat.Create;
begin
inherited Create;
FName := STargaFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := TargaSupportedFormats;
FUseRLE := TargaDefaultRLE;
AddMasks(STargaMasks);
RegisterOption(ImagingTargaRLE, @FUseRLE);
end;
function TTargaFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Hdr: TTargaHeader;
Foo: TTargaFooter;
FooterFound, ExtFound: Boolean;
I, PSize, PalSize: LongWord;
Pal: Pointer;
FmtInfo: TImageFormatInfo;
WordValue: Word;
procedure LoadRLE;
var
I, CPixel, Cnt: LongInt;
Bpp, Rle: Byte;
Buffer, Dest, Src: PByte;
BufSize: LongInt;
begin
with GetIO, Images[0] do
begin
// Alocates buffer large enough to hold the worst case
// RLE compressed data and reads then from input
BufSize := Width * Height * FmtInfo.BytesPerPixel;
BufSize := BufSize + BufSize div 2 + 1;
GetMem(Buffer, BufSize);
Src := Buffer;
Dest := Bits;
BufSize := Read(Handle, Buffer, BufSize);
Cnt := Width * Height;
Bpp := FmtInfo.BytesPerPixel;
CPixel := 0;
while CPixel < Cnt do
begin
Rle := Src^;
Inc(Src);
if Rle < 128 then
begin
// Process uncompressed pixel
Rle := Rle + 1;
CPixel := CPixel + Rle;
for I := 0 to Rle - 1 do
begin
// Copy pixel from src to dest
case Bpp of
1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^;
end;
Inc(Src, Bpp);
Inc(Dest, Bpp);
end;
end
else
begin
// Process compressed pixels
Rle := Rle - 127;
CPixel := CPixel + Rle;
// Copy one pixel from src to dest (many times there)
for I := 0 to Rle - 1 do
begin
case Bpp of
1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^;
end;
Inc(Dest, Bpp);
end;
Inc(Src, Bpp);
end;
end;
// set position in source to real end of compressed data
Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
smFromCurrent);
FreeMem(Buffer);
end;
end;
begin
SetLength(Images, 1);
with GetIO, Images[0] do
begin
// Read targa header
Read(Handle, @Hdr, SizeOf(Hdr));
// Skip image ID info
Seek(Handle, Hdr.IDLength, smFromCurrent);
// Determine image format
Format := ifUnknown;
case Hdr.ImageType of
1, 9: Format := ifIndex8;
2, 10: case Hdr.PixelSize of
15: Format := ifX1R5G5B5;
16: Format := ifA1R5G5B5;
24: Format := ifR8G8B8;
32: Format := ifA8R8G8B8;
end;
3, 11: Format := ifGray8;
end;
// Format was not assigned by previous testing (it should be in
// well formed targas), so formats which reflects bit dept are selected
if Format = ifUnknown then
case Hdr.PixelSize of
8: Format := ifGray8;
15: Format := ifX1R5G5B5;
16: Format := ifA1R5G5B5;
24: Format := ifR8G8B8;
32: Format := ifA8R8G8B8;
end;
NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
FmtInfo := GetFormatInfo(Format);
if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
begin
// Read palette
PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
GetMem(Pal, PSize);
try
Read(Handle, Pal, PSize);
// Process palette
PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
FmtInfo.PaletteEntries, Hdr.ColorMapLength);
for I := 0 to PalSize - 1 do
case Hdr.ColorEntrySize of
24:
with Palette[I] do
begin
A := $FF;
R := PPalette24(Pal)[I].R;
G := PPalette24(Pal)[I].G;
B := PPalette24(Pal)[I].B;
end;
// I've never seen tga with these palettes so they are untested
16:
with Palette[I] do
begin
A := (PWordArray(Pal)[I] and $8000) shr 12;
R := (PWordArray(Pal)[I] and $FC00) shr 7;
G := (PWordArray(Pal)[I] and $03E0) shr 2;
B := (PWordArray(Pal)[I] and $001F) shl 3;
end;
32:
with Palette[I] do
begin
A := PPalette32(Pal)[I].A;
R := PPalette32(Pal)[I].R;
G := PPalette32(Pal)[I].G;
B := PPalette32(Pal)[I].B;
end;
end;
finally
FreeMemNil(Pal);
end;
end;
case Hdr.ImageType of
0, 1, 2, 3:
// Load uncompressed mode images
Read(Handle, Bits, Size);
9, 10, 11:
// Load RLE compressed mode images
LoadRLE;
end;
// Check if there is alpha channel present in A1R5GB5 images, if it is not
// change format to X1R5G5B5
if Format = ifA1R5G5B5 then
begin
if not Has16BitImageAlpha(Width * Height, Bits) then
Format := ifX1R5G5B5;
end;
// We must find true end of file and set input' position to it
// paint programs appends extra info at the end of Targas
// some of them multiple times (PSP Pro 8)
repeat
ExtFound := False;
FooterFound := False;
if Read(Handle, @WordValue, 2) = 2 then
begin
// 495 = size of Extension Area
if WordValue = 495 then
begin
Seek(Handle, 493, smFromCurrent);
ExtFound := True;
end
else
Seek(Handle, -2, smFromCurrent);
end;
if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
begin
if Foo.Signature = STargaSignature then
FooterFound := True
else
Seek(Handle, -SizeOf(Foo), smFromCurrent);
end;
until (not ExtFound) and (not FooterFound);
// Some editors save targas flipped
if Hdr.Desc < 31 then
FlipImage(Images[0]);
Result := True;
end;
end;
function TTargaFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
I: LongInt;
Hdr: TTargaHeader;
FmtInfo: TImageFormatInfo;
Pal: PPalette24;
ImageToSave: TImageData;
MustBeFreed: Boolean;
procedure SaveRLE;
var
Dest: PByte;
WidthBytes, Written, I, Total, DestSize: LongInt;
function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
var
Pixel: LongWord;
NextPixel: LongWord;
N: LongInt;
begin
N := 0;
Pixel := 0;
NextPixel := 0;
if PixelCount = 1 then
begin
Result := PixelCount;
Exit;
end;
case Bpp of
1: Pixel := Data^;
2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^;
end;
while PixelCount > 1 do
begin
Inc(Data, Bpp);
case Bpp of
1: NextPixel := Data^;
2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^;
end;
if NextPixel = Pixel then
Break;
Pixel := NextPixel;
N := N + 1;
PixelCount := PixelCount - 1;
end;
if NextPixel = Pixel then
Result := N
else
Result := N + 1;
end;
function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
var
Pixel: LongWord;
NextPixel: LongWord;
N: LongInt;
begin
N := 1;
Pixel := 0;
NextPixel := 0;
case Bpp of
1: Pixel := Data^;
2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^;
end;
PixelCount := PixelCount - 1;
while PixelCount > 0 do
begin
Inc(Data, Bpp);
case Bpp of
1: NextPixel := Data^;
2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^;
end;
if NextPixel <> Pixel then
Break;
N := N + 1;
PixelCount := PixelCount - 1;
end;
Result := N;
end;
procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
PByte; var Written: LongInt);
const
MaxRun = 128;
var
DiffCount: LongInt;
SameCount: LongInt;
RleBufSize: LongInt;
begin
RleBufSize := 0;
while PixelCount > 0 do
begin
DiffCount := CountDiff(Data, Bpp, PixelCount);
SameCount := CountSame(Data, Bpp, PixelCount);
if (DiffCount > MaxRun) then
DiffCount := MaxRun;
if (SameCount > MaxRun) then
SameCount := MaxRun;
if (DiffCount > 0) then
begin
Dest^ := Byte(DiffCount - 1);
Inc(Dest);
PixelCount := PixelCount - DiffCount;
RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
Move(Data^, Dest^, DiffCount * Bpp);
Inc(Data, DiffCount * Bpp);
Inc(Dest, DiffCount * Bpp);
end;
if SameCount > 1 then
begin
Dest^ := Byte((SameCount - 1) or $80);
Inc(Dest);
PixelCount := PixelCount - SameCount;
RleBufSize := RleBufSize + Bpp + 1;
Inc(Data, (SameCount - 1) * Bpp);
case Bpp of
1: Dest^ := Data^;
2: PWord(Dest)^ := PWord(Data)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
4: PLongWord(Dest)^ := PLongWord(Data)^;
end;
Inc(Data, Bpp);
Inc(Dest, Bpp);
end;
end;
Written := RleBufSize;
end;
begin
with ImageToSave do
begin
// Allocate enough space to hold the worst case compression
// result and then compress source's scanlines
WidthBytes := Width * FmtInfo.BytesPerPixel;
DestSize := WidthBytes * Height;
DestSize := DestSize + DestSize div 2 + 1;
GetMem(Dest, DestSize);
Total := 0;
try
for I := 0 to Height - 1 do
begin
RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
Total := Total + Written;
end;
GetIO.Write(Handle, Dest, Total);
finally
FreeMem(Dest);
end;
end;
end;
begin
Result := False;
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with GetIO, ImageToSave do
try
FmtInfo := GetFormatInfo(Format);
// Fill targa header
FillChar(Hdr, SizeOf(Hdr), 0);
Hdr.IDLength := 0;
Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
Hdr.Width := Width;
Hdr.Height := Height;
Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
Hdr.ColorMapLength := FmtInfo.PaletteEntries;
Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
Hdr.ColorMapOff := 0;
// This indicates that targa is stored in top-left format
// as our images -> no flipping is needed.
Hdr.Desc := 32;
// Set alpha channel size in descriptor (mostly ignored by other software though)
if Format = ifA8R8G8B8 then
Hdr.Desc := Hdr.Desc or 8
else if Format = ifA1R5G5B5 then
Hdr.Desc := Hdr.Desc or 1;
// Choose image type
if FmtInfo.IsIndexed then
Hdr.ImageType := Iff(FUseRLE, 9, 1)
else
if FmtInfo.HasGrayChannel then
Hdr.ImageType := Iff(FUseRLE, 11, 3)
else
Hdr.ImageType := Iff(FUseRLE, 10, 2);
Write(Handle, @Hdr, SizeOf(Hdr));
// Write palette
if FmtInfo.PaletteEntries > 0 then
begin
GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
try
for I := 0 to FmtInfo.PaletteEntries - 1 do
with Pal[I] do
begin
R := Palette[I].R;
G := Palette[I].G;
B := Palette[I].B;
end;
Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
finally
FreeMemNil(Pal);
end;
end;
if FUseRLE then
// Save rle compressed mode images
SaveRLE
else
// Save uncompressed mode images
Write(Handle, Bits, Size);
Result := True;
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
var
ConvFormat: TImageFormat;
begin
if Info.HasGrayChannel then
// Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
else if Info.IsIndexed then
// Convert all indexed images to Index8
ConvFormat := ifIndex8
else if Info.HasAlphaChannel then
// Convert images with alpha channel to A8R8G8B8
ConvFormat := ifA8R8G8B8
else if Info.UsePixelFormat then
// Convert 16bit images (without alpha channel) to A1R5G5B5
ConvFormat := ifA1R5G5B5
else
// Convert all other formats to R8G8B8
ConvFormat := ifR8G8B8;
ConvertImage(Image, ConvFormat);
end;
function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Hdr: TTargaHeader;
ReadCount: LongInt;
begin
Result := False;
if Handle <> nil then
begin
ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
GetIO.Seek(Handle, -ReadCount, smFromCurrent);
Result := (ReadCount >= SizeOf(Hdr)) and
(Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
(Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
(Hdr.ColorEntrySize in [0, 16, 24, 32]);
end;
end;
initialization
RegisterImageFileFormat(TTargaFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.21 Changes/Bug Fixes -----------------------------------
- MakeCompatible method moved to base class, put ConvertToSupported here.
GetSupportedFormats removed, it is now set in constructor.
- Made public properties for options registered to SetOption/GetOption
functions.
- Changed extensions to filename masks.
- Changed SaveData, LoadData, and MakeCompatible methods according
to changes in base class in Imaging unit.
-- 0.17 Changes/Bug Fixes -----------------------------------
- 16 bit images are usually without alpha but some has alpha
channel and there is no indication of it - so I have added
a check: if all pixels of image are with alpha = 0 image is treated
as X1R5G5B5 otherwise as A1R5G5B5
- fixed problems with some nonstandard 15 bit images
}
end.

488
Imaging/ImagingTypes.pas Normal file
View File

@@ -0,0 +1,488 @@
{
$Id: ImagingTypes.pas 112 2007-12-11 19:43:15Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains basic types and constants used by Imaging library.}
unit ImagingTypes;
{$I ImagingOptions.inc}
interface
const
{ Current Major version of Imaging.}
ImagingVersionMajor = 0;
{ Current Minor version of Imaging.}
ImagingVersionMinor = 24;
{ Current patch of Imaging.}
ImagingVersionPatch = 2;
{ Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.}
{ Defines Jpeg compression quality, ranges from 1 (ugly/small) to 100 (nice/large).
Default value is 90.}
ImagingJpegQuality = 10;
{ Specifies whether Jpeg images are saved in progressive format,
can be 0 or 1. Default value is 0.}
ImagingJpegProgressive = 11;
{ Specifies whether Windows Bitmaps are saved using RLE compression
(only for 1/4/8 bit images), can be 0 or 1. Default value is 1.}
ImagingBitmapRLE = 12;
{ Specifies whether Targa images are saved using RLE compression,
can be 0 or 1. Default value is 0.}
ImagingTargaRLE = 13;
{ Value of this option is non-zero if last loaded DDS file was cube map.}
ImagingDDSLoadedCubeMap = 14;
{ Value of this option is non-zero if last loaded DDS file was volume texture.}
ImagingDDSLoadedVolume = 15;
{ Value of this option is number of mipmap levels of last loaded DDS image.}
ImagingDDSLoadedMipMapCount = 16;
{ Value of this option is depth (slices of volume texture or faces of
cube map) of last loaded DDS image.}
ImagingDDSLoadedDepth = 17;
{ If it is non-zero next saved DDS file should be stored as cube map.}
ImagingDDSSaveCubeMap = 18;
{ If it is non-zero next saved DDS file should be stored as volume texture.}
ImagingDDSSaveVolume = 19;
{ Sets the number of mipmaps which should be stored in the next saved DDS file.
Only applies to cube maps and volumes, ordinary 2D textures save all
levels present in input.}
ImagingDDSSaveMipMapCount = 20;
{ Sets the depth (slices of volume texture or faces of cube map)
of the next saved DDS file.}
ImagingDDSSaveDepth = 21;
{ Sets precompression filter used when saving PNG images. Allowed values
are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth),
5 (use 0 for indexed/gray images and 4 for RGB/ARGB images),
6 (adaptive filtering - use best filter for each scanline - very slow).
Note that filters 3 and 4 are much slower than filters 1 and 2.
Default value is 5.}
ImagingPNGPreFilter = 25;
{ Sets ZLib compression level used when saving PNG images.
Allowed values are in range 0 (no compresstion) to 9 (best compression).
Default value is 5.}
ImagingPNGCompressLevel = 26;
{ Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are
saved as JNG images. Allowed values are 0 (False) and 1 (True).
Default value is 0.}
ImagingMNGLossyCompression = 28;
{ Defines whether alpha channel of lossy compressed MNG frames
(when ImagingMNGLossyCompression is 1) is lossy compressed too.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
ImagingMNGLossyAlpha = 29;
{ Sets precompression filter used when saving MNG frames as PNG images.
For details look at ImagingPNGPreFilter.}
ImagingMNGPreFilter = 30;
{ Sets ZLib compression level used when saving MNG frames as PNG images.
For details look at ImagingPNGCompressLevel.}
ImagingMNGCompressLevel = 31;
{ Specifies compression quality used when saving MNG frames as JNG images.
For details look at ImagingJpegQuality.}
ImagingMNGQuality = 32;
{ Specifies whether images are saved in progressive format when saving MNG
frames as JNG images. For details look at ImagingJpegProgressive.}
ImagingMNGProgressive = 33;
{ Specifies whether alpha channels of JNG images are lossy compressed.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
ImagingJNGLossyAlpha = 40;
{ Sets precompression filter used when saving lossless alpha channels.
For details look at ImagingPNGPreFilter.}
ImagingJNGAlphaPreFilter = 41;
{ Sets ZLib compression level used when saving lossless alpha channels.
For details look at ImagingPNGCompressLevel.}
ImagingJNGAlphaCompressLevel = 42;
{ Defines compression quality used when saving JNG images (and lossy alpha channels).
For details look at ImagingJpegQuality.}
ImagingJNGQuality = 43;
{ Specifies whether JNG images are saved in progressive format.
For details look at ImagingJpegProgressive.}
ImagingJNGProgressive = 44;
{ Specifies whether PGM files are stored in text or in binary format.
Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.}
ImagingPGMSaveBinary = 50;
{ Specifies whether PPM files are stored in text or in binary format.
Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.}
ImagingPPMSaveBinary = 51;
{ This option is used when reducing number of colors used in
image (mainly when converting from ARGB image to indexed
format). Mask is 'anded' (bitwise AND) with every pixel's
channel value when creating color histogram. If $FF is used
all 8bits of color channels are used which can result in very
slow proccessing of large images with many colors so you can
use lower masks to speed it up (FC, F8 and F0 are good
choices). Allowed values are in range <0, $FF> and default is
$FE. }
ImagingColorReductionMask = 128;
{ This option can be used to override image data format during image
loading. If set to format different from ifUnknown all loaded images
are automaticaly converted to this format. Useful when you have
many files in various formats but you want them all in one format for
further proccessing. Allowed values are in
range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))> and
default value is ifUnknown.}
ImagingLoadOverrideFormat = 129;
{ This option can be used to override image data format during image
saving. If set to format different from ifUnknown all images
to be saved are automaticaly internaly converted to this format.
Note that image file formats support only a subset of Imaging data formats
so final saved file may in different format than this override.
Allowed values are in range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))>
and default value is ifUnknown.}
ImagingSaveOverrideFormat = 130;
{ Specifies resampling filter used when generating mipmaps. It is used
in GenerateMipMaps low level function and Direct3D and OpenGL extensions.
Allowed values are in range
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
and default value is 1 (linear filter).}
ImagingMipMapFilter = 131;
{ Returned by GetOption if given Option Id is invalid.}
InvalidOption = -$7FFFFFFF;
{ Indices that can be used to access channel values in array parts
of structures like TColor32Rec. Note that this order can be
used only for ARGB images. For ABGR image you must swap Red and Blue.}
ChannelBlue = 0;
ChannelGreen = 1;
ChannelRed = 2;
ChannelAlpha = 3;
type
{ Enum defining image data format. In formats with more channels,
first channel after "if" is stored in the most significant bits and channel
before end is stored in the least significant.}
TImageFormat = (
ifUnknown = 0,
ifDefault = 1,
{ Indexed formats using palette.}
ifIndex8 = 10,
{ Grayscale/Luminance formats.}
ifGray8 = 40,
ifA8Gray8 = 41,
ifGray16 = 42,
ifGray32 = 43,
ifGray64 = 44,
ifA16Gray16 = 45,
{ ARGB formats.}
ifX5R1G1B1 = 80,
ifR3G3B2 = 81,
ifR5G6B5 = 82,
ifA1R5G5B5 = 83,
ifA4R4G4B4 = 84,
ifX1R5G5B5 = 85,
ifX4R4G4B4 = 86,
ifR8G8B8 = 87,
ifA8R8G8B8 = 88,
ifX8R8G8B8 = 89,
ifR16G16B16 = 90,
ifA16R16G16B16 = 91,
ifB16G16R16 = 92,
ifA16B16G16R16 = 93,
{ Floating point formats.}
ifR32F = 170,
ifA32R32G32B32F = 171,
ifA32B32G32R32F = 172,
ifR16F = 173,
ifA16R16G16B16F = 174,
ifA16B16G16R16F = 175,
{ Special formats.}
ifDXT1 = 220,
ifDXT3 = 221,
ifDXT5 = 222,
ifBTC = 223);
{ Color value for 32 bit images.}
TColor32 = LongWord;
PColor32 = ^TColor32;
{ Color value for 64 bit images.}
TColor64 = type Int64;
PColor64 = ^TColor64;
{ Color record for 24 bit images, which allows access to individual color
channels.}
TColor24Rec = packed record
case LongInt of
0: (B, G, R: Byte);
1: (Channels: array[0..2] of Byte);
end;
PColor24Rec = ^TColor24Rec;
TColor24RecArray = array[0..MaxInt div SizeOf(TColor24Rec) - 1] of TColor24Rec;
PColor24RecArray = ^TColor24RecArray;
{ Color record for 32 bit images, which allows access to individual color
channels.}
TColor32Rec = packed record
case LongInt of
0: (Color: TColor32);
1: (B, G, R, A: Byte);
2: (Channels: array[0..3] of Byte);
3: (Color24Rec: TColor24Rec);
end;
PColor32Rec = ^TColor32Rec;
TColor32RecArray = array[0..MaxInt div SizeOf(TColor32Rec) - 1] of TColor32Rec;
PColor32RecArray = ^TColor32RecArray;
{ Color record for 48 bit images, which allows access to individual color
channels.}
TColor48Rec = packed record
case LongInt of
0: (B, G, R: Word);
1: (Channels: array[0..2] of Word);
end;
PColor48Rec = ^TColor48Rec;
TColor48RecArray = array[0..MaxInt div SizeOf(TColor48Rec) - 1] of TColor48Rec;
PColor48RecArray = ^TColor48RecArray;
{ Color record for 64 bit images, which allows access to individual color
channels.}
TColor64Rec = packed record
case LongInt of
0: (Color: TColor64);
1: (B, G, R, A: Word);
2: (Channels: array[0..3] of Word);
3: (Color48Rec: TColor48Rec);
end;
PColor64Rec = ^TColor64Rec;
TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
PColor64RecArray = ^TColor64RecArray;
{ Color record for 128 bit floating point images, which allows access to
individual color channels.}
TColorFPRec = packed record
case LongInt of
0: (B, G, R, A: Single);
1: (Channels: array[0..3] of Single);
end;
PColorFPRec = ^TColorFPRec;
TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
PColorFPRecArray = ^TColorFPRecArray;
{ 16 bit floating-point value. It has 1 sign bit, 5 exponent bits,
and 10 mantissa bits.}
THalfFloat = type Word;
PHalfFloat = ^THalfFloat;
{ Color record for 64 bit floating point images, which allows access to
individual color channels.}
TColorHFRec = packed record
case LongInt of
0: (B, G, R, A: THalfFloat);
1: (Channels: array[0..3] of THalfFloat);
end;
PColorHFRec = ^TColorHFRec;
TColorHFRecArray = array[0..MaxInt div SizeOf(TColorHFRec) - 1] of TColorHFRec;
PColorHFRecArray = ^TColorHFRecArray;
{ Palette for indexed mode images with 32 bit colors.}
TPalette32 = TColor32RecArray;
TPalette32Size256 = array[0..255] of TColor32Rec;
PPalette32 = ^TPalette32;
{ Palette for indexd mode images with 24 bit colors.}
TPalette24 = TColor24RecArray;
TPalette24Size256 = array[0..255] of TColor24Rec;
PPalette24 = ^TPalette24;
{ Record that stores single image data and information describing it.}
TImageData = packed record
Width: LongInt; // Width of image in pixels
Height: LongInt; // Height of image in pixels
Format: TImageFormat; // Data format of image
Size: LongInt; // Size of image bits in Bytes
Bits: Pointer; // Pointer to memory containing image bits
Palette: PPalette32; // Image palette for indexed images
end;
PImageData = ^TImageData;
{ Pixel format information used in conversions to/from 16 and 8 bit ARGB
image formats.}
TPixelFormatInfo = packed record
ABitCount, RBitCount, GBitCount, BBitCount: Byte;
ABitMask, RBitMask, GBitMask, BBitMask: LongWord;
AShift, RShift, GShift, BShift: Byte;
ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
end;
PPixelFormatInfo = ^TPixelFormatInfo;
PImageFormatInfo = ^TImageFormatInfo;
{ Look at TImageFormatInfo.GetPixelsSize for details.}
TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width,
Height: LongInt): LongInt;
{ Look at TImageFormatInfo.CheckDimensions for details.}
TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width,
Height: LongInt);
{ Function for getting pixel colors. Native pixel is read from Image and
then translated to 32 bit ARGB.}
TGetPixel32Func = function(Bits: Pointer; Info: PImageFormatInfo;
Palette: PPalette32): TColor32Rec;
{ Function for getting pixel colors. Native pixel is read from Image and
then translated to FP ARGB.}
TGetPixelFPFunc = function(Bits: Pointer; Info: PImageFormatInfo;
Palette: PPalette32): TColorFPRec;
{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
native format and then written to Image.}
TSetPixel32Proc = procedure(Bits: Pointer; Info: PImageFormatInfo;
Palette: PPalette32;const Color: TColor32Rec);
{ Procedure for setting pixel colors. Input FP ARGB color is translated to
native format and then written to Image.}
TSetPixelFPProc = procedure(Bits: Pointer; Info: PImageFormatInfo;
Palette: PPalette32; const Color: TColorFPRec);
{ Additional information for each TImageFormat value.}
TImageFormatInfo = packed record
Format: TImageFormat; // Format described by this record
Name: array[0..15] of Char; // Symbolic name of format
BytesPerPixel: LongInt; // Number of bytes per pixel (note: it is
// 0 for formats where BitsPerPixel < 8 (e.g. DXT).
// Use GetPixelsSize function to get size of
// image data.
ChannelCount: LongInt; // Number of image channels (R, G, B, A, Gray)
PaletteEntries: LongInt; // Number of palette entries
HasGrayChannel: Boolean; // True if image has grayscale channel
HasAlphaChannel: Boolean; // True if image has alpha channel
IsFloatingPoint: Boolean; // True if image has floating point pixels
UsePixelFormat: Boolean; // True if image uses pixel format
IsRBSwapped: Boolean; // True if Red and Blue channels are swapped
// e.g. A16B16G16R16 has IsRBSwapped True
RBSwapFormat: TImageFormat; // Indicates supported format with swapped
// Red and Blue channels, ifUnknown if such
// format does not exist
IsIndexed: Boolean; // True if image uses palette
IsSpecial: Boolean; // True if image is in special format
PixelFormat: PPixelFormatInfo; // Pixel format structure
GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
// Width * Height pixels of image
CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited
// values of Width and Height. This
// procedure checks and changes dimensions
// to be valid for given format.
GetPixel32: TGetPixel32Func; // 32bit ARGB pixel get function
GetPixelFP: TGetPixelFPFunc; // FP ARGB pixel get function
SetPixel32: TSetPixel32Proc; // 32bit ARGB pixel set procedure
SetPixelFP: TSetPixelFPProc; // FP ARGB pixel set procedure
SpecialNearestFormat: TImageFormat; // Regular image format used when
// compressing/decompressing special images
// as source/target
end;
{ Handle to list of image data records.}
TImageDataList = Pointer;
PImageDataList = ^TImageDataList;
{ Handle to input/output.}
TImagingHandle = Pointer;
{ Filters used in functions that resize images or their portions.}
TResizeFilter = (
rfNearest = 0,
rfBilinear = 1,
rfBicubic = 2);
{ Seek origin mode for IO function Seek.}
TSeekMode = (
smFromBeginning = 0,
smFromCurrent = 1,
smFromEnd = 2);
{ IO functions used for reading and writing images from/to input/output.}
TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl;
TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
TCloseProc = procedure(Handle: TImagingHandle); cdecl;
TEofProc = function(Handle: TImagingHandle): Boolean; cdecl;
TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl;
TTellProc = function(Handle: TImagingHandle): LongInt; cdecl;
TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
implementation
{
File Notes:
-- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions
- change TImageFormatInfo - add new fields that shoudl replace old chaos
like not knowing whether it is RGB without checking all other fields for False
(add something like FormatType = (ftIndexed, ftRGB, ftIntensity, ftCompressed,
ftFloatingPoint, ftRGBBitFields) and additional infos like HasAlphaChannel,
ChannelSize, ChannelCount, ...)
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format and SpecialNearestFormat field
to TImageFormatInfo.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Added option constants for PGM and PPM file formats.
- Added TPalette32Size256 and TPalette24Size256 types.
-- 0.19 Changes/Bug Fixes -----------------------------------
- added ImagingVersionPatch constant so bug fix only releases
can be distinguished from ordinary major/minor releases
- renamed TPixelFormat to TPixelFormatInfo to avoid name collisions
with Graphics.TPixelFormat
- added new image data formats: ifR16F, ifA16R16G16B16F,
ifA16B16G16R16F
- added pixel get/set function pointers to TImageFormatInfo
- added 16bit half float type and color record
- renamed TColorFRec to TColorFPRec (and related types too)
-- 0.17 Changes/Bug Fixes -----------------------------------
- added option ImagingMipMapFilter which now controls resampling filter
used when generating mipmaps
- added TResizeFilter type
- added ChannelCount to TImageFormatInfo
- added new option constants for MNG and JNG images
-- 0.15 Changes/Bug Fixes -----------------------------------
- added RBSwapFormat to TImageFormatInfo for faster conversions
between swapped formats (it just calls SwapChannels now if
RBSwapFormat is not ifUnknown)
- moved TImageFormatInfo and required types from Imaging unit
here, removed TImageFormatShortInfo
- added new options: ImagingLoadOverrideFormat, ImagingSaveOverrideFormat
-- 0.13 Changes/Bug Fixes -----------------------------------
- new ImagingColorReductionMask option added
- new image format added: ifA16Gray16
}
end.

1566
Imaging/ImagingUtility.pas Normal file
View File

File diff suppressed because it is too large Load Diff

401
Imaging/JpegLib/imjcapimin.pas Normal file
View File

@@ -0,0 +1,401 @@
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
case.
Most of the routines intended to be called directly by an application
are in this file or in jcapistd.c. But also see jcparam.c for
parameter-setup helper routines, jcomapi.c for routines shared by
compression and decompression, and jctrans.c for the transcoding case. }
{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcomapi,
imjmemmgr,
imjcmarker;
{ Initialization of JPEG compression objects.
Nomssi: This is a macro in the original code.
jpeg_create_compress() and jpeg_create_decompress() are the exported
names that applications should call. These expand to calls on
jpeg_CreateCompress and jpeg_CreateDecompress with additional information
passed for version mismatch checking.
NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. }
procedure jpeg_create_compress(cinfo : j_compress_ptr);
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
implementation
procedure jpeg_create_compress(cinfo : j_compress_ptr);
begin
jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_compress_struct)));
end;
{ Initialization of a JPEG compression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateCompress (cinfo : j_compress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_compress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_compress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.dest := NIL;
cinfo^.comp_info := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
cinfo^.script_space := NIL;
cinfo^.input_gamma := 1.0; { in case application forgets }
{ OK, I'm ready }
cinfo^.global_state := CSTATE_START;
end;
{ Destruction of a JPEG compression object }
{GLOBAL}
procedure jpeg_destroy_compress (cinfo : j_compress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG compression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_compress (cinfo : j_compress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Forcibly suppress or un-suppress all quantization and Huffman tables.
Marks all currently defined tables as already written (if suppress)
or not written (if !suppress). This will control whether they get emitted
by a subsequent jpeg_start_compress call.
This routine is exported for use by applications that want to produce
abbreviated JPEG datastreams. It logically belongs in jcparam.c, but
since it is called by jpeg_start_compress, we put it here --- otherwise
jcparam.o would be linked whether the application used it or not. }
{GLOBAL}
procedure jpeg_suppress_tables (cinfo : j_compress_ptr;
suppress : boolean);
var
i : int;
qtbl : JQUANT_TBL_PTR;
htbl : JHUFF_TBL_PTR;
begin
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
qtbl := cinfo^.quant_tbl_ptrs[i];
if (qtbl <> NIL) then
qtbl^.sent_table := suppress;
end;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
htbl := cinfo^.dc_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
htbl := cinfo^.ac_huff_tbl_ptrs[i];
if (htbl <> NIL) then
htbl^.sent_table := suppress;
end;
end;
{ Finish JPEG compression.
If a multipass operating mode was selected, this may do a great deal of
work including most of the actual output. }
{GLOBAL}
procedure jpeg_finish_compress (cinfo : j_compress_ptr);
var
iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state = CSTATE_SCANNING) or
(cinfo^.global_state = CSTATE_RAW_OK) then
begin
{ Terminate first pass }
if (cinfo^.next_scanline < cinfo^.image_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_pass (cinfo);
end
else
if (cinfo^.global_state <> CSTATE_WRCOEFS) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any remaining passes }
while (not cinfo^.master^.is_last_pass) do
begin
cinfo^.master^.prepare_for_pass (cinfo);
for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do
begin
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (iMCU_row);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
{ Write EOI, do final cleanup }
cinfo^.marker^.write_file_trailer (cinfo);
cinfo^.dest^.term_destination (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
end;
{ Write a special marker.
This is only recommended for writing COM or APPn markers.
Must be called after jpeg_start_compress() and before
first call to jpeg_write_scanlines() or jpeg_write_raw_data(). }
{GLOBAL}
procedure jpeg_write_marker (cinfo : j_compress_ptr;
marker : int;
dataptr : JOCTETptr;
datalen : uInt);
var
write_marker_byte : procedure(info : j_compress_ptr; val : int);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed }
while (datalen <> 0) do
begin
Dec(datalen);
write_marker_byte (cinfo, dataptr^);
Inc(dataptr);
end;
end;
{ Same, but piecemeal. }
{GLOBAL}
procedure jpeg_write_m_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
begin
if (cinfo^.next_scanline <> 0) or
((cinfo^.global_state <> CSTATE_SCANNING) and
(cinfo^.global_state <> CSTATE_RAW_OK) and
(cinfo^.global_state <> CSTATE_WRCOEFS)) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
cinfo^.marker^.write_marker_header (cinfo, marker, datalen);
end;
{GLOBAL}
procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int);
begin
cinfo^.marker^.write_marker_byte (cinfo, val);
end;
{ Alternate compression function: just write an abbreviated table file.
Before calling this, all parameters and a data destination must be set up.
To produce a pair of files containing abbreviated tables and abbreviated
image data, one would proceed as follows:
initialize JPEG object
set JPEG parameters
set destination to table file
jpeg_write_tables(cinfo);
set destination to image file
jpeg_start_compress(cinfo, FALSE);
write data...
jpeg_finish_compress(cinfo);
jpeg_write_tables has the side effect of marking all tables written
(same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress
will not re-emit the tables unless it is passed write_all_tables=TRUE. }
{GLOBAL}
procedure jpeg_write_tables (cinfo : j_compress_ptr);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Initialize the marker writer ... bit of a crock to do it here. }
jinit_marker_writer(cinfo);
{ Write them tables! }
cinfo^.marker^.write_tables_only (cinfo);
{ And clean up. }
cinfo^.dest^.term_destination (cinfo);
{ In library releases up through v6a, we called jpeg_abort() here to free
any working memory allocated by the destination manager and marker
writer. Some applications had a problem with that: they allocated space
of their own from the library memory manager, and didn't want it to go
away during write_tables. So now we do nothing. This will cause a
memory leak if an app calls write_tables repeatedly without doing a full
compression cycle or otherwise resetting the JPEG object. However, that
seems less bad than unexpectedly freeing memory in the normal case.
An app that prefers the old behavior can call jpeg_abort for itself after
each call to jpeg_write_tables(). }
end;
end.

222
Imaging/JpegLib/imjcapistd.pas Normal file
View File

@@ -0,0 +1,222 @@
unit imjcapistd;
{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the compression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-compression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_compress, it will end up linking in the entire compressor.
We thus must separate this file from jcapimin.c to avoid linking the
whole compression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjcapimin, imjcinit;
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
implementation
{ Compression initialization.
Before calling this, all parameters and a data destination must be set up.
We require a write_all_tables parameter as a failsafe check when writing
multiple datastreams from the same compression object. Since prior runs
will have left all the tables marked sent_table=TRUE, a subsequent run
would emit an abbreviated stream (no tables) by default. This may be what
is wanted, but for safety's sake it should not be the default behavior:
programmers should have to make a deliberate choice to emit abbreviated
images. Therefore the documentation and examples should encourage people
to pass write_all_tables=TRUE; then it will take active thought to do the
wrong thing. }
{GLOBAL}
procedure jpeg_start_compress (cinfo : j_compress_ptr;
write_all_tables : boolean);
begin
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (write_all_tables) then
jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written }
{ (Re)initialize error mgr and destination modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.dest^.init_destination (cinfo);
{ Perform master selection of active modules }
jinit_compress_master(cinfo);
{ Set up for the first pass }
cinfo^.master^.prepare_for_pass (cinfo);
{ Ready for application to drive first pass through jpeg_write_scanlines
or jpeg_write_raw_data. }
cinfo^.next_scanline := 0;
if cinfo^.raw_data_in then
cinfo^.global_state := CSTATE_RAW_OK
else
cinfo^.global_state := CSTATE_SCANNING;
end;
{ Write some scanlines of data to the JPEG compressor.
The return value will be the number of lines actually written.
This should be less than the supplied num_lines only in case that
the data destination module has requested suspension of the compressor,
or if more than image_height scanlines are passed in.
Note: we warn about excess calls to jpeg_write_scanlines() since
this likely signals an application programmer error. However,
excess scanlines passed in the last valid call are *silently* ignored,
so that the application need not adjust num_lines for end-of-image
when using a multiple-scanline buffer. }
{GLOBAL}
function jpeg_write_scanlines (cinfo : j_compress_ptr;
scanlines : JSAMPARRAY;
num_lines : JDIMENSION) : JDIMENSION;
var
row_ctr, rows_left : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_scanlines. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_scanlines. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Ignore any extra scanlines at bottom of image. }
rows_left := cinfo^.image_height - cinfo^.next_scanline;
if (num_lines > rows_left) then
num_lines := rows_left;
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines);
Inc(cinfo^.next_scanline, row_ctr);
jpeg_write_scanlines := row_ctr;
end;
{ Alternate entry point to write raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_write_raw_data (cinfo : j_compress_ptr;
data : JSAMPIMAGE;
num_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> CSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.next_scanline >= cinfo^.image_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_write_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long(cinfo^.next_scanline);
cinfo^.progress^.pass_limit := long(cinfo^.image_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Give master control module another chance if this is first call to
jpeg_write_raw_data. This lets output of the frame/scan headers be
delayed so that application can write COM, etc, markers between
jpeg_start_compress and jpeg_write_raw_data. }
if (cinfo^.master^.call_pass_startup) then
cinfo^.master^.pass_startup (cinfo);
{ Verify that at least one iMCU row has been passed. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE;
if (num_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Directly compress the row. }
if (not cinfo^.coef^.compress_data (cinfo, data)) then
begin
{ If compressor did not consume the whole row, suspend processing. }
jpeg_write_raw_data := 0;
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.next_scanline, lines_per_iMCU_row);
jpeg_write_raw_data := lines_per_iMCU_row;
end;
end.

521
Imaging/JpegLib/imjccoefct.pas Normal file
View File

@@ -0,0 +1,521 @@
unit imjccoefct;
{ This file contains the coefficient buffer controller for compression.
This controller is the top level of the JPEG compressor proper.
The coefficient buffer lies between forward-DCT and entropy encoding steps.}
{ Original: jccoefct.c; Copyright (C) 1994-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjerror,
imjdeferr,
imjutils,
imjpeglib;
{ We use a full-image coefficient buffer when doing Huffman optimization,
and also for writing multiple-scan JPEG files. In all cases, the DCT
step is run during the first pass, and subsequent passes need only read
the buffered coefficients. }
{$ifdef ENTROPY_OPT_SUPPORTED}
{$define FULL_COEF_BUFFER_SUPPORTED}
{$else}
{$ifdef C_MULTISCAN_FILES_SUPPORTED}
{$define FULL_COEF_BUFFER_SUPPORTED}
{$endif}
{$endif}
{ Initialize coefficient buffer controller. }
{GLOBAL}
procedure jinit_c_coef_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_coef_ptr = ^my_coef_controller;
my_coef_controller = record
pub : jpeg_c_coef_controller; { public fields }
iMCU_row_num : JDIMENSION; { iMCU row # within image }
mcu_ctr : JDIMENSION; { counts MCUs processed in current row }
MCU_vert_offset : int; { counts MCU rows within iMCU row }
MCU_rows_per_iMCU_row : int; { number of such rows needed }
{ For single-pass compression, it's sufficient to buffer just one MCU
(although this may prove a bit slow in practice). We allocate a
workspace of C_MAX_BLOCKS_IN_MCU coefficient blocks, and reuse it for each
MCU constructed and sent. (On 80x86, the workspace is FAR even though
it's not really very big; this is to keep the module interfaces unchanged
when a large coefficient buffer is necessary.)
In multi-pass modes, this array points to the current MCU's blocks
within the virtual arrays. }
MCU_buffer : array[0..C_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW;
{ In multi-pass modes, we need a virtual block array for each component. }
whole_image : array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr;
end;
{ Forward declarations }
{METHODDEF}
function compress_data(cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean; forward;
{$ifdef FULL_COEF_BUFFER_SUPPORTED}
{METHODDEF}
function compress_first_pass(cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean; forward;
{METHODDEF}
function compress_output(cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean; forward;
{$endif}
{LOCAL}
procedure start_iMCU_row (cinfo : j_compress_ptr);
{ Reset within-iMCU-row counters for a new row }
var
coef : my_coef_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
{ In an interleaved scan, an MCU row is the same as an iMCU row.
In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows.
But at the bottom of the image, process only what's left. }
if (cinfo^.comps_in_scan > 1) then
begin
coef^.MCU_rows_per_iMCU_row := 1;
end
else
begin
if (coef^.iMCU_row_num < (cinfo^.total_iMCU_rows-1)) then
coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor
else
coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height;
end;
coef^.mcu_ctr := 0;
coef^.MCU_vert_offset := 0;
end;
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_coef (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE);
var
coef : my_coef_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
coef^.iMCU_row_num := 0;
start_iMCU_row(cinfo);
case (pass_mode) of
JBUF_PASS_THRU:
begin
if (coef^.whole_image[0] <> NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
coef^.pub.compress_data := compress_data;
end;
{$ifdef FULL_COEF_BUFFER_SUPPORTED}
JBUF_SAVE_AND_PASS:
begin
if (coef^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
coef^.pub.compress_data := compress_first_pass;
end;
JBUF_CRANK_DEST:
begin
if (coef^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
coef^.pub.compress_data := compress_output;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
end;
{ Process some data in the single-pass case.
We process the equivalent of one fully interleaved MCU row ("iMCU" row)
per call, ie, v_samp_factor block rows for each component in the image.
Returns TRUE if the iMCU row is completed, FALSE if suspended.
NB: input_buf contains a plane for each component in image,
which we index according to the component's SOF position. }
{METHODDEF}
function compress_data (cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean;
var
coef : my_coef_ptr;
MCU_col_num : JDIMENSION; { index of current MCU within row }
last_MCU_col : JDIMENSION;
last_iMCU_row : JDIMENSION;
blkn, bi, ci, yindex, yoffset, blockcnt : int;
ypos, xpos : JDIMENSION;
compptr : jpeg_component_info_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
last_MCU_col := cinfo^.MCUs_per_row - 1;
last_iMCU_row := cinfo^.total_iMCU_rows - 1;
{ Loop to write as much as one whole iMCU row }
for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do
begin
for MCU_col_num := coef^.mcu_ctr to last_MCU_col do
begin
{ Determine where data comes from in input_buf and do the DCT thing.
Each call on forward_DCT processes a horizontal row of DCT blocks
as wide as an MCU; we rely on having allocated the MCU_buffer[] blocks
sequentially. Dummy blocks at the right or bottom edge are filled in
specially. The data in them does not matter for image reconstruction,
so we fill them with values that will encode to the smallest amount of
data, viz: all zeroes in the AC entries, DC entries equal to previous
block's DC value. (Thanks to Thomas Kinsman for this idea.) }
blkn := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
if (MCU_col_num < last_MCU_col) then
blockcnt := compptr^.MCU_width
else
blockcnt := compptr^.last_col_width;
xpos := MCU_col_num * JDIMENSION(compptr^.MCU_sample_width);
ypos := yoffset * DCTSIZE; { ypos = (yoffset+yindex) * DCTSIZE }
for yindex := 0 to pred(compptr^.MCU_height) do
begin
if (coef^.iMCU_row_num < last_iMCU_row) or
(yoffset+yindex < compptr^.last_row_height) then
begin
cinfo^.fdct^.forward_DCT (cinfo, compptr,
input_buf^[compptr^.component_index],
coef^.MCU_buffer[blkn],
ypos, xpos, JDIMENSION (blockcnt));
if (blockcnt < compptr^.MCU_width) then
begin
{ Create some dummy blocks at the right edge of the image. }
jzero_far({FAR}pointer(coef^.MCU_buffer[blkn + blockcnt]),
(compptr^.MCU_width - blockcnt) * SIZEOF(JBLOCK));
for bi := blockcnt to pred(compptr^.MCU_width) do
begin
coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn+bi-1]^[0][0];
end;
end;
end
else
begin
{ Create a row of dummy blocks at the bottom of the image. }
jzero_far({FAR}pointer(coef^.MCU_buffer[blkn]),
compptr^.MCU_width * SIZEOF(JBLOCK));
for bi := 0 to pred(compptr^.MCU_width) do
begin
coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn-1]^[0][0];
end;
end;
Inc(blkn, compptr^.MCU_width);
Inc(ypos, DCTSIZE);
end;
end;
{ Try to write the MCU. In event of a suspension failure, we will
re-DCT the MCU on restart (a bit inefficient, could be fixed...) }
if (not cinfo^.entropy^.encode_mcu (cinfo, JBLOCKARRAY(@coef^.MCU_buffer)^)) then
begin
{ Suspension forced; update state counters and exit }
coef^.MCU_vert_offset := yoffset;
coef^.mcu_ctr := MCU_col_num;
compress_data := FALSE;
exit;
end;
end;
{ Completed an MCU row, but perhaps not an iMCU row }
coef^.mcu_ctr := 0;
end;
{ Completed the iMCU row, advance counters for next one }
Inc(coef^.iMCU_row_num);
start_iMCU_row(cinfo);
compress_data := TRUE;
end;
{$ifdef FULL_COEF_BUFFER_SUPPORTED}
{ Process some data in the first pass of a multi-pass case.
We process the equivalent of one fully interleaved MCU row ("iMCU" row)
per call, ie, v_samp_factor block rows for each component in the image.
This amount of data is read from the source buffer, DCT'd and quantized,
and saved into the virtual arrays. We also generate suitable dummy blocks
as needed at the right and lower edges. (The dummy blocks are constructed
in the virtual arrays, which have been padded appropriately.) This makes
it possible for subsequent passes not to worry about real vs. dummy blocks.
We must also emit the data to the entropy encoder. This is conveniently
done by calling compress_output() after we've loaded the current strip
of the virtual arrays.
NB: input_buf contains a plane for each component in image. All
components are DCT'd and loaded into the virtual arrays in this pass.
However, it may be that only a subset of the components are emitted to
the entropy encoder during this first pass; be careful about looking
at the scan-dependent variables (MCU dimensions, etc). }
{METHODDEF}
function compress_first_pass (cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean;
var
coef : my_coef_ptr;
last_iMCU_row : JDIMENSION;
blocks_across, MCUs_across, MCUindex : JDIMENSION;
bi, ci, h_samp_factor, block_row, block_rows, ndummy : int;
lastDC : JCOEF;
compptr : jpeg_component_info_ptr;
buffer : JBLOCKARRAY;
thisblockrow, lastblockrow : JBLOCKROW;
begin
coef := my_coef_ptr (cinfo^.coef);
last_iMCU_row := cinfo^.total_iMCU_rows - 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Align the virtual buffer for this component. }
buffer := cinfo^.mem^.access_virt_barray
(j_common_ptr(cinfo), coef^.whole_image[ci],
coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor),
JDIMENSION (compptr^.v_samp_factor), TRUE);
{ Count non-dummy DCT block rows in this iMCU row. }
if (coef^.iMCU_row_num < last_iMCU_row) then
block_rows := compptr^.v_samp_factor
else
begin
{ NB: can't use last_row_height here, since may not be set! }
block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor;
if (block_rows = 0) then
block_rows := compptr^.v_samp_factor;
end;
blocks_across := compptr^.width_in_blocks;
h_samp_factor := compptr^.h_samp_factor;
{ Count number of dummy blocks to be added at the right margin. }
ndummy := int (blocks_across) mod h_samp_factor;
if (ndummy > 0) then
ndummy := h_samp_factor - ndummy;
{ Perform DCT for all non-dummy blocks in this iMCU row. Each call
on forward_DCT processes a complete horizontal row of DCT blocks. }
for block_row := 0 to pred(block_rows) do
begin
thisblockrow := buffer^[block_row];
cinfo^.fdct^.forward_DCT (cinfo, compptr,
input_buf^[ci],
thisblockrow,
JDIMENSION (block_row * DCTSIZE),
JDIMENSION (0),
blocks_across);
if (ndummy > 0) then
begin
{ Create dummy blocks at the right edge of the image. }
Inc(JBLOCK_PTR(thisblockrow), blocks_across); { => first dummy block }
jzero_far({FAR}pointer(thisblockrow), ndummy * SIZEOF(JBLOCK));
{lastDC := thisblockrow^[-1][0];}
{ work around Range Checking }
Dec(JBLOCK_PTR(thisblockrow));
lastDC := thisblockrow^[0][0];
Inc(JBLOCK_PTR(thisblockrow));
for bi := 0 to pred(ndummy) do
begin
thisblockrow^[bi][0] := lastDC;
end;
end;
end;
{ If at end of image, create dummy block rows as needed.
The tricky part here is that within each MCU, we want the DC values
of the dummy blocks to match the last real block's DC value.
This squeezes a few more bytes out of the resulting file... }
if (coef^.iMCU_row_num = last_iMCU_row) then
begin
Inc(blocks_across, ndummy); { include lower right corner }
MCUs_across := blocks_across div JDIMENSION(h_samp_factor);
for block_row := block_rows to pred(compptr^.v_samp_factor) do
begin
thisblockrow := buffer^[block_row];
lastblockrow := buffer^[block_row-1];
jzero_far({FAR} pointer(thisblockrow),
size_t(blocks_across * SIZEOF(JBLOCK)));
for MCUindex := 0 to pred(MCUs_across) do
begin
lastDC := lastblockrow^[h_samp_factor-1][0];
for bi := 0 to pred(h_samp_factor) do
begin
thisblockrow^[bi][0] := lastDC;
end;
Inc(JBLOCK_PTR(thisblockrow), h_samp_factor); { advance to next MCU in row }
Inc(JBLOCK_PTR(lastblockrow), h_samp_factor);
end;
end;
end;
Inc(compptr);
end;
{ NB: compress_output will increment iMCU_row_num if successful.
A suspension return will result in redoing all the work above next time.}
{ Emit data to the entropy encoder, sharing code with subsequent passes }
compress_first_pass := compress_output(cinfo, input_buf);
end;
{ Process some data in subsequent passes of a multi-pass case.
We process the equivalent of one fully interleaved MCU row ("iMCU" row)
per call, ie, v_samp_factor block rows for each component in the scan.
The data is obtained from the virtual arrays and fed to the entropy coder.
Returns TRUE if the iMCU row is completed, FALSE if suspended.
NB: input_buf is ignored; it is likely to be a NIL pointer. }
{METHODDEF}
function compress_output (cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE) : boolean;
var
coef : my_coef_ptr;
MCU_col_num : JDIMENSION; { index of current MCU within row }
blkn, ci, xindex, yindex, yoffset : int;
start_col : JDIMENSION;
buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY;
buffer_ptr : JBLOCKROW;
compptr : jpeg_component_info_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
{ Align the virtual buffers for the components used in this scan.
NB: during first pass, this is safe only because the buffers will
already be aligned properly, so jmemmgr.c won't need to do any I/O. }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
buffer[ci] := cinfo^.mem^.access_virt_barray (
j_common_ptr(cinfo), coef^.whole_image[compptr^.component_index],
coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor),
JDIMENSION (compptr^.v_samp_factor), FALSE);
end;
{ Loop to process one whole iMCU row }
for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do
begin
for MCU_col_num := coef^.mcu_ctr to pred(cinfo^.MCUs_per_row) do
begin
{ Construct list of pointers to DCT blocks belonging to this MCU }
blkn := 0; { index of current DCT block within MCU }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
start_col := MCU_col_num * JDIMENSION(compptr^.MCU_width);
for yindex := 0 to pred(compptr^.MCU_height) do
begin
buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]);
for xindex := 0 to pred(compptr^.MCU_width) do
begin
coef^.MCU_buffer[blkn] := buffer_ptr;
Inc(blkn);
Inc(JBLOCK_PTR(buffer_ptr));
end;
end;
end;
{ Try to write the MCU. }
if (not cinfo^.entropy^.encode_mcu (cinfo, coef^.MCU_buffer)) then
begin
{ Suspension forced; update state counters and exit }
coef^.MCU_vert_offset := yoffset;
coef^.mcu_ctr := MCU_col_num;
compress_output := FALSE;
exit;
end;
end;
{ Completed an MCU row, but perhaps not an iMCU row }
coef^.mcu_ctr := 0;
end;
{ Completed the iMCU row, advance counters for next one }
Inc(coef^.iMCU_row_num);
start_iMCU_row(cinfo);
compress_output := TRUE;
end;
{$endif} { FULL_COEF_BUFFER_SUPPORTED }
{ Initialize coefficient buffer controller. }
{GLOBAL}
procedure jinit_c_coef_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
coef : my_coef_ptr;
var
buffer : JBLOCKROW;
i : int;
var
ci : int;
compptr : jpeg_component_info_ptr;
begin
coef := my_coef_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_coef_controller)) );
cinfo^.coef := jpeg_c_coef_controller_ptr(coef);
coef^.pub.start_pass := start_pass_coef;
{ Create the coefficient buffer. }
if (need_full_buffer) then
begin
{$ifdef FULL_COEF_BUFFER_SUPPORTED}
{ Allocate a full-image virtual array for each component, }
{ padded to a multiple of samp_factor DCT blocks in each direction. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
JDIMENSION (jround_up( long (compptr^.width_in_blocks),
long (compptr^.h_samp_factor) )),
JDIMENSION (jround_up(long (compptr^.height_in_blocks),
long (compptr^.v_samp_factor))),
JDIMENSION (compptr^.v_samp_factor));
Inc(compptr);
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
end
else
begin
{ We only need a single-MCU buffer. }
buffer := JBLOCKROW (
cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE,
C_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) );
for i := 0 to pred(C_MAX_BLOCKS_IN_MCU) do
begin
coef^.MCU_buffer[i] := JBLOCKROW(@ buffer^[i]);
end;
coef^.whole_image[0] := NIL; { flag for no virtual arrays }
end;
end;
end.

533
Imaging/JpegLib/imjccolor.pas Normal file
View File

@@ -0,0 +1,533 @@
unit imjccolor;
{ This file contains input colorspace conversion routines. }
{ Original : jccolor.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib;
{ Module initialization routine for input colorspace conversion. }
{GLOBAL}
procedure jinit_color_converter (cinfo : j_compress_ptr);
implementation
{ Private subobject }
type
jTInt32 = 0..Pred(MaxInt div SizeOf(INT32));
INT32_FIELD = array[jTInt32] of INT32;
INT32_FIELD_PTR = ^INT32_FIELD;
type
my_cconvert_ptr = ^my_color_converter;
my_color_converter = record
pub : jpeg_color_converter; { public fields }
{ Private state for RGB -> YCC conversion }
rgb_ycc_tab : INT32_FIELD_PTR; { => table for RGB to YCbCr conversion }
end; {my_color_converter;}
{*************** RGB -> YCbCr conversion: most common case *************}
{
YCbCr is defined per CCIR 601-1, except that Cb and Cr are
normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5.
The conversion equations to be implemented are therefore
Y = 0.29900 * R + 0.58700 * G + 0.11400 * B
Cb = -0.16874 * R - 0.33126 * G + 0.50000 * B + CENTERJSAMPLE
Cr = 0.50000 * R - 0.41869 * G - 0.08131 * B + CENTERJSAMPLE
(These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.)
Note: older versions of the IJG code used a zero offset of MAXJSAMPLE/2,
rather than CENTERJSAMPLE, for Cb and Cr. This gave equal positive and
negative swings for Cb/Cr, but meant that grayscale values (Cb=Cr=0)
were not represented exactly. Now we sacrifice exact representation of
maximum red and maximum blue in order to get exact grayscales.
To avoid floating-point arithmetic, we represent the fractional constants
as integers scaled up by 2^16 (about 4 digits precision); we have to divide
the products by 2^16, with appropriate rounding, to get the correct answer.
For even more speed, we avoid doing any multiplications in the inner loop
by precalculating the constants times R,G,B for all possible values.
For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table);
for 12-bit samples it is still acceptable. It's not very reasonable for
16-bit samples, but if you want lossless storage you shouldn't be changing
colorspace anyway.
The CENTERJSAMPLE offsets and the rounding fudge-factor of 0.5 are included
in the tables to save adding them separately in the inner loop. }
const
SCALEBITS = 16; { speediest right-shift on some machines }
CBCR_OFFSET = INT32(CENTERJSAMPLE shl SCALEBITS);
ONE_HALF = INT32(1) shl (SCALEBITS-1);
{ We allocate one big table and divide it up into eight parts, instead of
doing eight alloc_small requests. This lets us use a single table base
address, which can be held in a register in the inner loops on many
machines (more than can hold all eight addresses, anyway). }
R_Y_OFF = 0; { offset to R => Y section }
G_Y_OFF = 1*(MAXJSAMPLE+1); { offset to G => Y section }
B_Y_OFF = 2*(MAXJSAMPLE+1); { etc. }
R_CB_OFF = 3*(MAXJSAMPLE+1);
G_CB_OFF = 4*(MAXJSAMPLE+1);
B_CB_OFF = 5*(MAXJSAMPLE+1);
R_CR_OFF = B_CB_OFF; { B=>Cb, R=>Cr are the same }
G_CR_OFF = 6*(MAXJSAMPLE+1);
B_CR_OFF = 7*(MAXJSAMPLE+1);
TABLE_SIZE = 8*(MAXJSAMPLE+1);
{ Initialize for RGB->YCC colorspace conversion. }
{METHODDEF}
procedure rgb_ycc_start (cinfo : j_compress_ptr);
const
FIX_0_29900 = INT32(Round (0.29900 * (1 shl SCALEBITS)) );
FIX_0_58700 = INT32(Round (0.58700 * (1 shl SCALEBITS)) );
FIX_0_11400 = INT32(Round (0.11400 * (1 shl SCALEBITS)) );
FIX_0_16874 = INT32(Round (0.16874 * (1 shl SCALEBITS)) );
FIX_0_33126 = INT32(Round (0.33126 * (1 shl SCALEBITS)) );
FIX_0_50000 = INT32(Round (0.50000 * (1 shl SCALEBITS)) );
FIX_0_41869 = INT32(Round (0.41869 * (1 shl SCALEBITS)) );
FIX_0_08131 = INT32(Round (0.08131 * (1 shl SCALEBITS)) );
var
cconvert : my_cconvert_ptr;
rgb_ycc_tab : INT32_FIELD_PTR;
i : INT32;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
{ Allocate and fill in the conversion tables. }
rgb_ycc_tab := INT32_FIELD_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(TABLE_SIZE * SIZEOF(INT32))) );
cconvert^.rgb_ycc_tab := rgb_ycc_tab;
for i := 0 to MAXJSAMPLE do
begin
rgb_ycc_tab^[i+R_Y_OFF] := FIX_0_29900 * i;
rgb_ycc_tab^[i+G_Y_OFF] := FIX_0_58700 * i;
rgb_ycc_tab^[i+B_Y_OFF] := FIX_0_11400 * i + ONE_HALF;
rgb_ycc_tab^[i+R_CB_OFF] := (-FIX_0_16874) * i;
rgb_ycc_tab^[i+G_CB_OFF] := (-FIX_0_33126) * i;
{ We use a rounding fudge-factor of 0.5-epsilon for Cb and Cr.
This ensures that the maximum output will round to MAXJSAMPLE
not MAXJSAMPLE+1, and thus that we don't have to range-limit. }
rgb_ycc_tab^[i+B_CB_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1;
{ B=>Cb and R=>Cr tables are the same
rgb_ycc_tab^[i+R_CR_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1;
}
rgb_ycc_tab^[i+G_CR_OFF] := (-FIX_0_41869) * i;
rgb_ycc_tab^[i+B_CR_OFF] := (-FIX_0_08131) * i;
end;
end;
{ Convert some rows of samples to the JPEG colorspace.
Note that we change from the application's interleaved-pixel format
to our internal noninterleaved, one-plane-per-component format.
The input buffer is therefore three times as wide as the output buffer.
A starting row offset is provided only for the output buffer. The caller
can easily adjust the passed input_buf value to accommodate any row
offset required on that side. }
{METHODDEF}
procedure rgb_ycc_convert (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
output_buf : JSAMPIMAGE;
output_row : JDIMENSION;
num_rows : int);
var
cconvert : my_cconvert_ptr;
{register} r, g, b : int;
{register} ctab : INT32_FIELD_PTR;
{register} inptr : JSAMPROW;
{register} outptr0, outptr1, outptr2 : JSAMPROW;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
ctab := cconvert^.rgb_ycc_tab;
num_cols := cinfo^.image_width;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr := input_buf^[0];
Inc(JSAMPROW_PTR(input_buf));
outptr0 := output_buf^[0]^[output_row];
outptr1 := output_buf^[1]^[output_row];
outptr2 := output_buf^[2]^[output_row];
Inc(output_row);
for col := 0 to pred(num_cols) do
begin
r := GETJSAMPLE(inptr^[RGB_RED]);
g := GETJSAMPLE(inptr^[RGB_GREEN]);
b := GETJSAMPLE(inptr^[RGB_BLUE]);
Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE);
{ If the inputs are 0..MAXJSAMPLE, the outputs of these equations
must be too; we do not need an explicit range-limiting operation.
Hence the value being shifted is never negative, and we don't
need the general RIGHT_SHIFT macro. }
{ Y }
outptr0^[col] := JSAMPLE(
((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF])
shr SCALEBITS) );
{ Cb }
outptr1^[col] := JSAMPLE(
((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF])
shr SCALEBITS) );
{ Cr }
outptr2^[col] := JSAMPLE(
((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF])
shr SCALEBITS) );
end;
end;
end;
{*************** Cases other than RGB -> YCbCr *************}
{ Convert some rows of samples to the JPEG colorspace.
This version handles RGB -> grayscale conversion, which is the same
as the RGB -> Y portion of RGB -> YCbCr.
We assume rgb_ycc_start has been called (we only use the Y tables). }
{METHODDEF}
procedure rgb_gray_convert (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
output_buf : JSAMPIMAGE;
output_row : JDIMENSION;
num_rows : int);
var
cconvert : my_cconvert_ptr;
{register} r, g, b : int;
{register} ctab :INT32_FIELD_PTR;
{register} inptr : JSAMPROW;
{register} outptr : JSAMPROW;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
ctab := cconvert^.rgb_ycc_tab;
num_cols := cinfo^.image_width;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr := input_buf^[0];
Inc(JSAMPROW_PTR(input_buf));
outptr := output_buf^[0]^[output_row];
Inc(output_row);
for col := 0 to pred(num_cols) do
begin
r := GETJSAMPLE(inptr^[RGB_RED]);
g := GETJSAMPLE(inptr^[RGB_GREEN]);
b := GETJSAMPLE(inptr^[RGB_BLUE]);
Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE);
(* Y *)
// kylix 3 compiler crashes on this
{$IF (not Defined(LINUX)) or Defined(FPC)}
outptr^[col] := JSAMPLE (
((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF])
shr SCALEBITS) );
{$IFEND}
end;
end;
end;
{ Convert some rows of samples to the JPEG colorspace.
This version handles Adobe-style CMYK -> YCCK conversion,
where we convert R=1-C, G=1-M, and B=1-Y to YCbCr using the same
conversion as above, while passing K (black) unchanged.
We assume rgb_ycc_start has been called. }
{METHODDEF}
procedure cmyk_ycck_convert (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
output_buf : JSAMPIMAGE;
output_row : JDIMENSION;
num_rows : int);
var
cconvert : my_cconvert_ptr;
{register} r, g, b : int;
{register} ctab : INT32_FIELD_PTR;
{register} inptr : JSAMPROW;
{register} outptr0, outptr1, outptr2, outptr3 : JSAMPROW;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
ctab := cconvert^.rgb_ycc_tab;
num_cols := cinfo^.image_width;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr := input_buf^[0];
Inc(JSAMPROW_PTR(input_buf));
outptr0 := output_buf^[0]^[output_row];
outptr1 := output_buf^[1]^[output_row];
outptr2 := output_buf^[2]^[output_row];
outptr3 := output_buf^[3]^[output_row];
Inc(output_row);
for col := 0 to pred(num_cols) do
begin
r := MAXJSAMPLE - GETJSAMPLE(inptr^[0]);
g := MAXJSAMPLE - GETJSAMPLE(inptr^[1]);
b := MAXJSAMPLE - GETJSAMPLE(inptr^[2]);
{ K passes through as-is }
outptr3^[col] := inptr^[3]; { don't need GETJSAMPLE here }
Inc(JSAMPLE_PTR(inptr), 4);
{ If the inputs are 0..MAXJSAMPLE, the outputs of these equations
must be too; we do not need an explicit range-limiting operation.
Hence the value being shifted is never negative, and we don't
need the general RIGHT_SHIFT macro. }
{ Y }
outptr0^[col] := JSAMPLE (
((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF])
shr SCALEBITS) );
{ Cb }
outptr1^[col] := JSAMPLE(
((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF])
shr SCALEBITS) );
{ Cr }
outptr2^[col] := JSAMPLE (
((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF])
shr SCALEBITS) );
end;
end;
end;
{ Convert some rows of samples to the JPEG colorspace.
This version handles grayscale output with no conversion.
The source can be either plain grayscale or YCbCr (since Y = gray). }
{METHODDEF}
procedure grayscale_convert (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
output_buf : JSAMPIMAGE;
output_row : JDIMENSION;
num_rows: int);
var
{register} inptr : JSAMPROW;
{register} outptr : JSAMPROW;
{register} col : JDIMENSION;
num_cols :JDIMENSION;
instride : int;
begin
num_cols := cinfo^.image_width;
instride := cinfo^.input_components;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr := input_buf^[0];
Inc(JSAMPROW_PTR(input_buf));
outptr := output_buf^[0]^[output_row];
Inc(output_row);
for col := 0 to pred(num_cols) do
begin
outptr^[col] := inptr^[0]; { don't need GETJSAMPLE() here }
Inc(JSAMPLE_PTR(inptr), instride);
end;
end;
end;
{ Convert some rows of samples to the JPEG colorspace.
This version handles multi-component colorspaces without conversion.
We assume input_components = num_components. }
{METHODDEF}
procedure null_convert (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
output_buf : JSAMPIMAGE;
output_row : JDIMENSION;
num_rows : int);
var
{register} inptr : JSAMPROW;
{register} outptr : JSAMPROW;
{register} col : JDIMENSION;
{register} ci : int;
nc : int;
num_cols : JDIMENSION;
begin
nc := cinfo^.num_components;
num_cols := cinfo^.image_width;
while (num_rows > 0) do
begin
Dec(num_rows);
{ It seems fastest to make a separate pass for each component. }
for ci := 0 to pred(nc) do
begin
inptr := input_buf^[0];
outptr := output_buf^[ci]^[output_row];
for col := 0 to pred(num_cols) do
begin
outptr^[col] := inptr^[ci]; { don't need GETJSAMPLE() here }
Inc(JSAMPLE_PTR(inptr), nc);
end;
end;
Inc(JSAMPROW_PTR(input_buf));
Inc(output_row);
end;
end;
{ Empty method for start_pass. }
{METHODDEF}
procedure null_method (cinfo : j_compress_ptr);
begin
{ no work needed }
end;
{ Module initialization routine for input colorspace conversion. }
{GLOBAL}
procedure jinit_color_converter (cinfo : j_compress_ptr);
var
cconvert : my_cconvert_ptr;
begin
cconvert := my_cconvert_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_color_converter)) );
cinfo^.cconvert := jpeg_color_converter_ptr(cconvert);
{ set start_pass to null method until we find out differently }
cconvert^.pub.start_pass := null_method;
{ Make sure input_components agrees with in_color_space }
case (cinfo^.in_color_space) of
JCS_GRAYSCALE:
if (cinfo^.input_components <> 1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
{$ifdef RGB_PIXELSIZE <> 3}
JCS_RGB:
if (cinfo^.input_components <> RGB_PIXELSIZE) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
{$else} { share code with YCbCr }
JCS_RGB,
{$endif}
JCS_YCbCr:
if (cinfo^.input_components <> 3) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
JCS_CMYK,
JCS_YCCK:
if (cinfo^.input_components <> 4) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
else { JCS_UNKNOWN can be anything }
if (cinfo^.input_components < 1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
end;
{ Check num_components, set conversion method based on requested space }
case (cinfo^.jpeg_color_space) of
JCS_GRAYSCALE:
begin
if (cinfo^.num_components <> 1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
if (cinfo^.in_color_space = JCS_GRAYSCALE) then
cconvert^.pub.color_convert := grayscale_convert
else
if (cinfo^.in_color_space = JCS_RGB) then
begin
cconvert^.pub.start_pass := rgb_ycc_start;
cconvert^.pub.color_convert := rgb_gray_convert;
end
else
if (cinfo^.in_color_space = JCS_YCbCr) then
cconvert^.pub.color_convert := grayscale_convert
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_RGB:
begin
if (cinfo^.num_components <> 3) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
if (cinfo^.in_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then
cconvert^.pub.color_convert := null_convert
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_YCbCr:
begin
if (cinfo^.num_components <> 3) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
if (cinfo^.in_color_space = JCS_RGB) then
begin
cconvert^.pub.start_pass := rgb_ycc_start;
cconvert^.pub.color_convert := rgb_ycc_convert;
end
else
if (cinfo^.in_color_space = JCS_YCbCr) then
cconvert^.pub.color_convert := null_convert
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_CMYK:
begin
if (cinfo^.num_components <> 4) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
if (cinfo^.in_color_space = JCS_CMYK) then
cconvert^.pub.color_convert := null_convert
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_YCCK:
begin
if (cinfo^.num_components <> 4) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
if (cinfo^.in_color_space = JCS_CMYK) then
begin
cconvert^.pub.start_pass := rgb_ycc_start;
cconvert^.pub.color_convert := cmyk_ycck_convert;
end
else
if (cinfo^.in_color_space = JCS_YCCK) then
cconvert^.pub.color_convert := null_convert
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
else { allow null conversion of JCS_UNKNOWN }
begin
if (cinfo^.jpeg_color_space <> cinfo^.in_color_space) or
(cinfo^.num_components <> cinfo^.input_components) then
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
cconvert^.pub.color_convert := null_convert;
end;
end;
end;
end.

514
Imaging/JpegLib/imjcdctmgr.pas Normal file
View File

@@ -0,0 +1,514 @@
unit imjcdctmgr;
{ Original : jcdctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains the forward-DCT management logic.
This code selects a particular DCT implementation to be used,
and it performs related housekeeping chores including coefficient
quantization. }
interface
{$N+}
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdct, { Private declarations for DCT subsystem }
imjfdctint, imjfdctfst, imjfdctflt;
{ Initialize FDCT manager. }
{GLOBAL}
procedure jinit_forward_dct (cinfo : j_compress_ptr);
implementation
{ Private subobject for this module }
type
my_fdct_ptr = ^my_fdct_controller;
my_fdct_controller = record
pub : jpeg_forward_dct; { public fields }
{ Pointer to the DCT routine actually in use }
do_dct : forward_DCT_method_ptr;
{ The actual post-DCT divisors --- not identical to the quant table
entries, because of scaling (especially for an unnormalized DCT).
Each table is given in normal array order. }
divisors : array[0..NUM_QUANT_TBLS-1] of DCTELEM_FIELD_PTR;
{$ifdef DCT_FLOAT_SUPPORTED}
{ Same as above for the floating-point case. }
do_float_dct : float_DCT_method_ptr;
float_divisors : array[0..NUM_QUANT_TBLS-1] of FAST_FLOAT_FIELD_PTR;
{$endif}
end;
{ Initialize for a processing pass.
Verify that all referenced Q-tables are present, and set up
the divisor table for each one.
In the current implementation, DCT of all components is done during
the first pass, even if only some components will be output in the
first scan. Hence all components should be examined here. }
{METHODDEF}
procedure start_pass_fdctmgr (cinfo : j_compress_ptr);
var
fdct : my_fdct_ptr;
ci, qtblno, i : int;
compptr : jpeg_component_info_ptr;
qtbl : JQUANT_TBL_PTR;
dtbl : DCTELEM_FIELD_PTR;
{$ifdef DCT_IFAST_SUPPORTED}
const
CONST_BITS = 14;
aanscales : array[0..DCTSIZE2-1] of INT16 =
({ precomputed values scaled up by 14 bits }
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270,
21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906,
19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315,
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552,
8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446,
4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247);
{SHIFT_TEMPS}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
shift_temp := x + (INT32(1) shl (n-1));
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
var
fdtbl : FAST_FLOAT_FIELD_PTR;
row, col : int;
const
aanscalefactor : array[0..DCTSIZE-1] of double =
(1.0, 1.387039845, 1.306562965, 1.175875602,
1.0, 0.785694958, 0.541196100, 0.275899379);
{$endif}
begin
fdct := my_fdct_ptr (cinfo^.fdct);
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
qtblno := compptr^.quant_tbl_no;
{ Make sure specified quantization table is present }
if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or
(cinfo^.quant_tbl_ptrs[qtblno] = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno);
qtbl := cinfo^.quant_tbl_ptrs[qtblno];
{ Compute divisors for this quant table }
{ We may do this more than once for same table, but it's not a big deal }
case (cinfo^.dct_method) of
{$ifdef DCT_ISLOW_SUPPORTED}
JDCT_ISLOW:
begin
{ For LL&M IDCT method, divisors are equal to raw quantization
coefficients multiplied by 8 (to counteract scaling). }
if (fdct^.divisors[qtblno] = NIL) then
begin
fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
DCTSIZE2 * SIZEOF(DCTELEM)) );
end;
dtbl := fdct^.divisors[qtblno];
for i := 0 to pred(DCTSIZE2) do
begin
dtbl^[i] := (DCTELEM(qtbl^.quantval[i])) shl 3;
end;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
{ For AA&N IDCT method, divisors are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7
We apply a further scale factor of 8. }
if (fdct^.divisors[qtblno] = NIL) then
begin
fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
DCTSIZE2 * SIZEOF(DCTELEM)) );
end;
dtbl := fdct^.divisors[qtblno];
for i := 0 to pred(DCTSIZE2) do
begin
dtbl^[i] := DCTELEM(
{MULTIPLY16V16}
DESCALE( INT32(qtbl^.quantval[i]) * INT32 (aanscales[i]),
CONST_BITS-3) );
end;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
{ For float AA&N IDCT method, divisors are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7
We apply a further scale factor of 8.
What's actually stored is 1/divisor so that the inner loop can
use a multiplication rather than a division. }
if (fdct^.float_divisors[qtblno] = NIL) then
begin
fdct^.float_divisors[qtblno] := FAST_FLOAT_FIELD_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
DCTSIZE2 * SIZEOF(FAST_FLOAT)) );
end;
fdtbl := fdct^.float_divisors[qtblno];
i := 0;
for row := 0 to pred(DCTSIZE) do
begin
for col := 0 to pred(DCTSIZE) do
begin
fdtbl^[i] := {FAST_FLOAT}
(1.0 / (( {double}(qtbl^.quantval[i]) *
aanscalefactor[row] * aanscalefactor[col] * 8.0)));
Inc(i);
end;
end;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
Inc(compptr);
end;
end;
{ Perform forward DCT on one or more blocks of a component.
The input samples are taken from the sample_data[] array starting at
position start_row/start_col, and moving to the right for any additional
blocks. The quantized coefficients are returned in coef_blocks[]. }
{METHODDEF}
procedure forward_DCT (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
sample_data : JSAMPARRAY;
coef_blocks : JBLOCKROW;
start_row : JDIMENSION;
start_col : JDIMENSION;
num_blocks : JDIMENSION);
{ This version is used for integer DCT implementations. }
var
{ This routine is heavily used, so it's worth coding it tightly. }
fdct : my_fdct_ptr;
do_dct : forward_DCT_method_ptr;
divisors : DCTELEM_FIELD_PTR;
workspace : array[0..DCTSIZE2-1] of DCTELEM; { work area for FDCT subroutine }
bi : JDIMENSION;
var
{register} workspaceptr : DCTELEMPTR;
{register} elemptr : JSAMPLE_PTR;
{register} elemr : int;
{$ifndef DCTSIZE_IS_8}
var
{register} elemc : int;
{$endif}
var
{register} temp, qval : DCTELEM;
{register} i : int;
{register} output_ptr : JCOEFPTR;
begin
fdct := my_fdct_ptr (cinfo^.fdct);
do_dct := fdct^.do_dct;
divisors := fdct^.divisors[compptr^.quant_tbl_no];
Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once }
for bi := 0 to pred(num_blocks) do
begin
{ Load data into workspace, applying unsigned->signed conversion }
workspaceptr := @workspace[0];
for elemr := 0 to pred(DCTSIZE) do
begin
elemptr := @sample_data^[elemr]^[start_col];
{$ifdef DCTSIZE_IS_8} { unroll the inner loop }
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
{Inc(elemptr); - Value never used }
{$else}
for elemc := pred(DCTSIZE) downto 0 do
begin
workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE;
Inc(workspaceptr);
Inc(elemptr);
end;
{$endif}
end;
{ Perform the DCT }
do_dct (workspace);
{ Quantize/descale the coefficients, and store into coef_blocks[] }
output_ptr := JCOEFPTR(@coef_blocks^[bi]);
for i := 0 to pred(DCTSIZE2) do
begin
qval := divisors^[i];
temp := workspace[i];
{ Divide the coefficient value by qval, ensuring proper rounding.
Since C does not specify the direction of rounding for negative
quotients, we have to force the dividend positive for portability.
In most files, at least half of the output values will be zero
(at default quantization settings, more like three-quarters...)
so we should ensure that this case is fast. On many machines,
a comparison is enough cheaper than a divide to make a special test
a win. Since both inputs will be nonnegative, we need only test
for a < b to discover whether a/b is 0.
If your machine's division is fast enough, define FAST_DIVIDE. }
if (temp < 0) then
begin
temp := -temp;
Inc(temp, qval shr 1); { for rounding }
{DIVIDE_BY(temp, qval);}
{$ifdef FAST_DIVIDE}
temp := temp div qval;
{$else}
if (temp >= qval) then
temp := temp div qval
else
temp := 0;
{$endif}
temp := -temp;
end
else
begin
Inc(temp, qval shr 1); { for rounding }
{DIVIDE_BY(temp, qval);}
{$ifdef FAST_DIVIDE}
temp := temp div qval;
{$else}
if (temp >= qval) then
temp := temp div qval
else
temp := 0;
{$endif}
end;
output_ptr^[i] := JCOEF (temp);
end;
Inc(start_col, DCTSIZE);
end;
end;
{$ifdef DCT_FLOAT_SUPPORTED}
{METHODDEF}
procedure forward_DCT_float (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
sample_data : JSAMPARRAY;
coef_blocks : JBLOCKROW;
start_row : JDIMENSION;
start_col : JDIMENSION;
num_blocks : JDIMENSION);
{ This version is used for floating-point DCT implementations. }
var
{ This routine is heavily used, so it's worth coding it tightly. }
fdct : my_fdct_ptr;
do_dct : float_DCT_method_ptr;
divisors : FAST_FLOAT_FIELD_PTR;
workspace : array[0..DCTSIZE2-1] of FAST_FLOAT; { work area for FDCT subroutine }
bi : JDIMENSION;
var
{register} workspaceptr : FAST_FLOAT_PTR;
{register} elemptr : JSAMPLE_PTR;
{register} elemr : int;
{$ifndef DCTSIZE_IS_8}
var
{register} elemc : int;
{$endif}
var
{register} temp : FAST_FLOAT;
{register} i : int;
{register} output_ptr : JCOEFPTR;
begin
fdct := my_fdct_ptr (cinfo^.fdct);
do_dct := fdct^.do_float_dct;
divisors := fdct^.float_divisors[compptr^.quant_tbl_no];
Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once }
for bi := 0 to pred(num_blocks) do
begin
{ Load data into workspace, applying unsigned->signed conversion }
workspaceptr := @workspace[0];
for elemr := 0 to pred(DCTSIZE) do
begin
elemptr := @(sample_data^[elemr]^[start_col]);
{$ifdef DCTSIZE_IS_8} { unroll the inner loop }
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
Inc(elemptr);
workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE);
Inc(workspaceptr);
{Inc(elemptr); - value never used }
{$else}
for elemc := pred(DCTSIZE) downto 0 do
begin
workspaceptr^ := {FAST_FLOAT}(
(GETJSAMPLE(elemptr^) - CENTERJSAMPLE) );
Inc(workspaceptr);
Inc(elemptr);
end;
{$endif}
end;
{ Perform the DCT }
do_dct (workspace);
{ Quantize/descale the coefficients, and store into coef_blocks[] }
output_ptr := JCOEFPTR(@(coef_blocks^[bi]));
for i := 0 to pred(DCTSIZE2) do
begin
{ Apply the quantization and scaling factor }
temp := workspace[i] * divisors^[i];
{ Round to nearest integer.
Since C does not specify the direction of rounding for negative
quotients, we have to force the dividend positive for portability.
The maximum coefficient size is +-16K (for 12-bit data), so this
code should work for either 16-bit or 32-bit ints. }
output_ptr^[i] := JCOEF ( int(Trunc (temp + {FAST_FLOAT}(16384.5))) - 16384);
end;
Inc(start_col, DCTSIZE);
end;
end;
{$endif} { DCT_FLOAT_SUPPORTED }
{ Initialize FDCT manager. }
{GLOBAL}
procedure jinit_forward_dct (cinfo : j_compress_ptr);
var
fdct : my_fdct_ptr;
i : int;
begin
fdct := my_fdct_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_fdct_controller)) );
cinfo^.fdct := jpeg_forward_dct_ptr (fdct);
fdct^.pub.start_pass := start_pass_fdctmgr;
case (cinfo^.dct_method) of
{$ifdef DCT_ISLOW_SUPPORTED}
JDCT_ISLOW:
begin
fdct^.pub.forward_DCT := forward_DCT;
fdct^.do_dct := jpeg_fdct_islow;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
fdct^.pub.forward_DCT := forward_DCT;
fdct^.do_dct := jpeg_fdct_ifast;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
fdct^.pub.forward_DCT := forward_DCT_float;
fdct^.do_float_dct := jpeg_fdct_float;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
{ Mark divisor tables unallocated }
for i := 0 to pred(NUM_QUANT_TBLS) do
begin
fdct^.divisors[i] := NIL;
{$ifdef DCT_FLOAT_SUPPORTED}
fdct^.float_divisors[i] := NIL;
{$endif}
end;
end;
end.

1116
Imaging/JpegLib/imjchuff.pas Normal file
View File

File diff suppressed because it is too large Load Diff

95
Imaging/JpegLib/imjcinit.pas Normal file
View File

@@ -0,0 +1,95 @@
unit imjcinit;
{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file contains initialization logic for the JPEG compressor.
This routine is in charge of selecting the modules to be executed and
making an initialization call to each one.
Logically, this code belongs in jcmaster.c. It's split out because
linking this routine implies linking the entire compression library.
For a transcoding-only application, we want to be able to use jcmaster.c
without linking in the whole library. }
interface
{$I imjconfig.inc}
uses
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
{$ifdef C_PROGRESSIVE_SUPPORTED}
imjcphuff,
{$endif}
imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct,
imjcdctmgr, imjccoefct, imjcmainct, imjcmarker;
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
implementation
{ Master selection of compression modules.
This is done once at the start of processing an image. We determine
which modules will be used and give them appropriate initialization calls. }
{GLOBAL}
procedure jinit_compress_master (cinfo : j_compress_ptr);
begin
{ Initialize master control (includes parameter checking/processing) }
jinit_c_master_control(cinfo, FALSE { full compression });
{ Preprocessing }
if (not cinfo^.raw_data_in) then
begin
jinit_color_converter(cinfo);
jinit_downsampler(cinfo);
jinit_c_prep_controller(cinfo, FALSE { never need full buffer here });
end;
{ Forward DCT }
jinit_forward_dct(cinfo);
{ Entropy encoding: either Huffman or arithmetic coding. }
if (cinfo^.arith_code) then
begin
ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL);
end
else
begin
if (cinfo^.progressive_mode) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
jinit_phuff_encoder(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
jinit_huff_encoder(cinfo);
end;
{ Need a full-image coefficient buffer in any multi-pass mode. }
jinit_c_coef_controller(cinfo,
(cinfo^.num_scans > 1) or (cinfo^.optimize_coding));
jinit_c_main_controller(cinfo, FALSE { never need full buffer here });
jinit_marker_writer(cinfo);
{ We can now tell the memory manager to allocate virtual arrays. }
cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo));
{ Write the datastream header (SOI) immediately.
Frame and scan headers are postponed till later.
This lets application insert special markers after the SOI. }
cinfo^.marker^.write_file_header (cinfo);
end;
end.

343
Imaging/JpegLib/imjcmainct.pas Normal file
View File

@@ -0,0 +1,343 @@
unit imjcmainct;
{ This file contains the main buffer controller for compression.
The main buffer lies between the pre-processor and the JPEG
compressor proper; it holds downsampled data in the JPEG colorspace. }
{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Note: currently, there is no operating mode in which a full-image buffer
is needed at this step. If there were, that mode could not be used with
"raw data" input, since this module is bypassed in that case. However,
we've left the code here for possible use in special applications. }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
imjutils,
{$endif}
imjpeglib;
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_main_ptr = ^my_main_controller;
my_main_controller = record
pub : jpeg_c_main_controller; { public fields }
cur_iMCU_row : JDIMENSION; { number of current iMCU row }
rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row }
suspended : boolean; { remember if we suspended output }
pass_mode : J_BUF_MODE; { current operating mode }
{ If using just a strip buffer, this points to the entire set of buffers
(we allocate one for each component). In the full-image case, this
points to the currently accessible strips of the virtual arrays. }
buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ If using full-image storage, this array holds pointers to virtual-array
control blocks for each component. Unused if not full-image storage. }
whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr;
{$endif}
end; {my_main_controller}
{ Forward declarations }
{METHODDEF}
procedure process_data_simple_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr: JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{METHODDEF}
procedure process_data_buffer_main(cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_main (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
{ Do nothing in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
main^.cur_iMCU_row := 0; { initialize counters }
main^.rowgroup_ctr := 0;
main^.suspended := FALSE;
main^.pass_mode := pass_mode; { save mode for use by process_data }
case (pass_mode) of
JBUF_PASS_THRU:
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
if (main^.whole_image[0] <> NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
main^.pub.process_data := process_data_simple_main;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
JBUF_SAVE_SOURCE,
JBUF_CRANK_DEST,
JBUF_SAVE_AND_PASS:
begin
if (main^.whole_image[0] = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
main^.pub.process_data := process_data_buffer_main;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
end;
{ Process some data.
This routine handles the simple pass-through mode,
where we have only a strip buffer. }
{METHODDEF}
procedure process_data_simple_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Read input data if we haven't filled the main buffer yet }
if (main^.rowgroup_ctr < DCTSIZE) then
cinfo^.prep^.pre_process_data (cinfo,
input_buf,
in_row_ctr,
in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION(DCTSIZE));
{ If we don't have a full iMCU row buffered, return to application for
more data. Note that preprocessor will always pad to fill the iMCU row
at the bottom of the image. }
if (main^.rowgroup_ctr <> DCTSIZE) then
exit;
{ Send the completed row to the compressor }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Process some data.
This routine handles all of the modes that use a full-size buffer. }
{METHODDEF}
procedure process_data_buffer_main (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
writing : boolean;
begin
main := my_main_ptr (cinfo^.main);
writing := (main^.pass_mode <> JBUF_CRANK_DEST);
while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do
begin
{ Realign the virtual buffers if at the start of an iMCU row. }
if (main^.rowgroup_ctr = 0) then
begin
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.access_virt_sarray
(j_common_ptr (cinfo), main^.whole_image[ci],
main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing);
Inc(compptr);
end;
{ In a read pass, pretend we just read some source data. }
if (not writing) then
begin
Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE);
main^.rowgroup_ctr := DCTSIZE;
end;
end;
{ If a write pass, read input data until the current iMCU row is full. }
{ Note: preprocessor will pad if necessary to fill the last iMCU row. }
if (writing) then
begin
cinfo^.prep^.pre_process_data (cinfo,
input_buf, in_row_ctr, in_rows_avail,
JSAMPIMAGE(@main^.buffer),
main^.rowgroup_ctr,
JDIMENSION (DCTSIZE));
{ Return to application if we need more data to fill the iMCU row. }
if (main^.rowgroup_ctr < DCTSIZE) then
exit;
end;
{ Emit data, unless this is a sink-only pass. }
if (main^.pass_mode <> JBUF_SAVE_SOURCE) then
begin
if (not cinfo^.coef^.compress_data (cinfo,
JSAMPIMAGE(@main^.buffer))) then
begin
{ If compressor did not consume the whole row, then we must need to
suspend processing and return to the application. In this situation
we pretend we didn't yet consume the last input row; otherwise, if
it happened to be the last row of the image, the application would
think we were done. }
if (not main^.suspended) then
begin
Dec(in_row_ctr);
main^.suspended := TRUE;
end;
exit;
end;
{ We did finish the row. Undo our little suspension hack if a previous
call suspended; then mark the main buffer empty. }
if (main^.suspended) then
begin
Inc(in_row_ctr);
main^.suspended := FALSE;
end;
end;
{ If get here, we are done with this iMCU row. Mark buffer empty. }
main^.rowgroup_ctr := 0;
Inc(main^.cur_iMCU_row);
end;
end;
{$endif} { FULL_MAIN_BUFFER_SUPPORTED }
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_c_main_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
main : my_main_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
main := my_main_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_main_controller)) );
cinfo^.main := jpeg_c_main_controller_ptr(main);
main^.pub.start_pass := start_pass_main;
{ We don't need to create a buffer in raw-data mode. }
if (cinfo^.raw_data_in) then
exit;
{ Create the buffer. It holds downsampled data, so each component
may be of a different size. }
if (need_full_buffer) then
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
{ Allocate a full-image virtual array for each component }
{ Note we pad the bottom to a multiple of the iMCU height }
compptr := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (jround_up( long (compptr^.height_in_blocks),
long (compptr^.v_samp_factor)) * DCTSIZE),
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif}
end
else
begin
{$ifdef FULL_MAIN_BUFFER_SUPPORTED}
main^.whole_image[0] := NIL; { flag for no virtual arrays }
{$endif}
{ Allocate a strip buffer for each component }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * DCTSIZE,
JDIMENSION (compptr^.v_samp_factor * DCTSIZE));
Inc(compptr);
end;
end;
end;
end.

724
Imaging/JpegLib/imjcmarker.pas Normal file
View File

@@ -0,0 +1,724 @@
unit imjcmarker;
{ This file contains routines to write JPEG datastream markers. }
{ Original: jcmarker.c; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjinclude, imjmorecfg, imjerror,
imjdeferr, imjpeglib, imjutils;
const
{ JPEG marker codes }
M_SOF0 = $c0;
M_SOF1 = $c1;
M_SOF2 = $c2;
M_SOF3 = $c3;
M_SOF5 = $c5;
M_SOF6 = $c6;
M_SOF7 = $c7;
M_JPG = $c8;
M_SOF9 = $c9;
M_SOF10 = $ca;
M_SOF11 = $cb;
M_SOF13 = $cd;
M_SOF14 = $ce;
M_SOF15 = $cf;
M_DHT = $c4;
M_DAC = $cc;
M_RST0 = $d0;
M_RST1 = $d1;
M_RST2 = $d2;
M_RST3 = $d3;
M_RST4 = $d4;
M_RST5 = $d5;
M_RST6 = $d6;
M_RST7 = $d7;
M_SOI = $d8;
M_EOI = $d9;
M_SOS = $da;
M_DQT = $db;
M_DNL = $dc;
M_DRI = $dd;
M_DHP = $de;
M_EXP = $df;
M_APP0 = $e0;
M_APP1 = $e1;
M_APP2 = $e2;
M_APP3 = $e3;
M_APP4 = $e4;
M_APP5 = $e5;
M_APP6 = $e6;
M_APP7 = $e7;
M_APP8 = $e8;
M_APP9 = $e9;
M_APP10 = $ea;
M_APP11 = $eb;
M_APP12 = $ec;
M_APP13 = $ed;
M_APP14 = $ee;
M_APP15 = $ef;
M_JPG0 = $f0;
M_JPG13 = $fd;
M_COM = $fe;
M_TEM = $01;
M_ERROR = $100;
type
JPEG_MARKER = Word;
{ Private state }
type
my_marker_ptr = ^my_marker_writer;
my_marker_writer = record
pub : jpeg_marker_writer; { public fields }
last_restart_interval : uint; { last DRI value emitted; 0 after SOI }
end;
{GLOBAL}
procedure jinit_marker_writer (cinfo : j_compress_ptr);
implementation
{ Basic output routines.
Note that we do not support suspension while writing a marker.
Therefore, an application using suspension must ensure that there is
enough buffer space for the initial markers (typ. 600-700 bytes) before
calling jpeg_start_compress, and enough space to write the trailing EOI
(a few bytes) before calling jpeg_finish_compress. Multipass compression
modes are not supported at all with suspension, so those two are the only
points where markers will be written. }
{LOCAL}
procedure emit_byte (cinfo : j_compress_ptr; val : int);
{ Emit a byte }
var
dest : jpeg_destination_mgr_ptr;
begin
dest := cinfo^.dest;
dest^.next_output_byte^ := JOCTET(val);
Inc(dest^.next_output_byte);
Dec(dest^.free_in_buffer);
if (dest^.free_in_buffer = 0) then
begin
if not dest^.empty_output_buffer(cinfo) then
ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
end;
{LOCAL}
procedure emit_marker(cinfo : j_compress_ptr; mark : JPEG_MARKER);
{ Emit a marker code }
begin
emit_byte(cinfo, $FF);
emit_byte(cinfo, int(mark));
end;
{LOCAL}
procedure emit_2bytes (cinfo : j_compress_ptr; value : int);
{ Emit a 2-byte integer; these are always MSB first in JPEG files }
begin
emit_byte(cinfo, (value shr 8) and $FF);
emit_byte(cinfo, value and $FF);
end;
{ Routines to write specific marker types. }
{LOCAL}
function emit_dqt (cinfo : j_compress_ptr; index : int) : int;
{ Emit a DQT marker }
{ Returns the precision used (0 = 8bits, 1 = 16bits) for baseline checking }
var
qtbl : JQUANT_TBL_PTR;
prec : int;
i : int;
var
qval : uint;
begin
qtbl := cinfo^.quant_tbl_ptrs[index];
if (qtbl = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, index);
prec := 0;
for i := 0 to Pred(DCTSIZE2) do
begin
if (qtbl^.quantval[i] > 255) then
prec := 1;
end;
if not qtbl^.sent_table then
begin
emit_marker(cinfo, M_DQT);
if (prec <> 0) then
emit_2bytes(cinfo, DCTSIZE2*2 + 1 + 2)
else
emit_2bytes(cinfo, DCTSIZE2 + 1 + 2);
emit_byte(cinfo, index + (prec shl 4));
for i := 0 to Pred(DCTSIZE2) do
begin
{ The table entries must be emitted in zigzag order. }
qval := qtbl^.quantval[jpeg_natural_order[i]];
if (prec <> 0) then
emit_byte(cinfo, int(qval shr 8));
emit_byte(cinfo, int(qval and $FF));
end;
qtbl^.sent_table := TRUE;
end;
emit_dqt := prec;
end;
{LOCAL}
procedure emit_dht (cinfo : j_compress_ptr; index : int; is_ac : boolean);
{ Emit a DHT marker }
var
htbl : JHUFF_TBL_PTR;
length, i : int;
begin
if (is_ac) then
begin
htbl := cinfo^.ac_huff_tbl_ptrs[index];
index := index + $10; { output index has AC bit set }
end
else
begin
htbl := cinfo^.dc_huff_tbl_ptrs[index];
end;
if (htbl = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, index);
if not htbl^.sent_table then
begin
emit_marker(cinfo, M_DHT);
length := 0;
for i := 1 to 16 do
length := length + htbl^.bits[i];
emit_2bytes(cinfo, length + 2 + 1 + 16);
emit_byte(cinfo, index);
for i := 1 to 16 do
emit_byte(cinfo, htbl^.bits[i]);
for i := 0 to Pred(length) do
emit_byte(cinfo, htbl^.huffval[i]);
htbl^.sent_table := TRUE;
end;
end;
{LOCAL}
procedure emit_dac (cinfo : j_compress_ptr);
{ Emit a DAC marker }
{ Since the useful info is so small, we want to emit all the tables in }
{ one DAC marker. Therefore this routine does its own scan of the table. }
{$ifdef C_ARITH_CODING_SUPPORTED}
var
dc_in_use : array[0..NUM_ARITH_TBLS] of byte;
ac_in_use : array[0..NUM_ARITH_TBLS] of byte;
length, i : int;
compptr : jpeg_component_info_ptr;
begin
for i := 0 to pred(NUM_ARITH_TBLS) do
begin
dc_in_use[i] := 0;
ac_in_use[i] := 0;
end;
for i := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[i];
dc_in_use[compptr^.dc_tbl_no] := 1;
ac_in_use[compptr^.ac_tbl_no] := 1;
end;
length := 0;
for i := 0 to pred(NUM_ARITH_TBLS) do
Inc(length, dc_in_use[i] + ac_in_use[i]);
emit_marker(cinfo, M_DAC);
emit_2bytes(cinfo, length*2 + 2);
for i := 0 to pred(NUM_ARITH_TBLS) do
begin
if (dc_in_use[i] <> 0) then
begin
emit_byte(cinfo, i);
emit_byte(cinfo, cinfo^.arith_dc_L[i] + (cinfo^.arith_dc_U[i] shl 4));
end;
if (ac_in_use[i] <> 0) then
begin
emit_byte(cinfo, i + $10);
emit_byte(cinfo, cinfo^.arith_ac_K[i]);
end;
end;
end;
{$else}
begin
end;
{$endif} {C_ARITH_CODING_SUPPORTED}
{LOCAL}
procedure emit_dri (cinfo : j_compress_ptr);
{ Emit a DRI marker }
begin
emit_marker(cinfo, M_DRI);
emit_2bytes(cinfo, 4); { fixed length }
emit_2bytes(cinfo, int(cinfo^.restart_interval));
end;
{LOCAL}
procedure emit_sof (cinfo : j_compress_ptr; code : JPEG_MARKER);
{ Emit a SOF marker }
var
ci : int;
compptr : jpeg_component_info_ptr;
begin
emit_marker(cinfo, code);
emit_2bytes(cinfo, 3 * cinfo^.num_components + 2 + 5 + 1); { length }
{ Make sure image isn't bigger than SOF field can handle }
if (long(cinfo^.image_height) > long(65535)) or
(long(cinfo^.image_width) > long(65535)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(65535));
emit_byte(cinfo, cinfo^.data_precision);
emit_2bytes(cinfo, int(cinfo^.image_height));
emit_2bytes(cinfo, int(cinfo^.image_width));
emit_byte(cinfo, cinfo^.num_components);
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to Pred(cinfo^.num_components) do
begin
emit_byte(cinfo, compptr^.component_id);
emit_byte(cinfo, (compptr^.h_samp_factor shl 4) + compptr^.v_samp_factor);
emit_byte(cinfo, compptr^.quant_tbl_no);
Inc(compptr);
end;
end;
{LOCAL}
procedure emit_sos (cinfo : j_compress_ptr);
{ Emit a SOS marker }
var
i, td, ta : int;
compptr : jpeg_component_info_ptr;
begin
emit_marker(cinfo, M_SOS);
emit_2bytes(cinfo, 2 * cinfo^.comps_in_scan + 2 + 1 + 3); { length }
emit_byte(cinfo, cinfo^.comps_in_scan);
for i := 0 to Pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[i];
emit_byte(cinfo, compptr^.component_id);
td := compptr^.dc_tbl_no;
ta := compptr^.ac_tbl_no;
if (cinfo^.progressive_mode) then
begin
{ Progressive mode: only DC or only AC tables are used in one scan;
furthermore, Huffman coding of DC refinement uses no table at all.
We emit 0 for unused field(s); this is recommended by the P&M text
but does not seem to be specified in the standard. }
if (cinfo^.Ss = 0) then
begin
ta := 0; { DC scan }
if (cinfo^.Ah <> 0) and not cinfo^.arith_code then
td := 0; { no DC table either }
end
else
begin
td := 0; { AC scan }
end;
end;
emit_byte(cinfo, (td shl 4) + ta);
end;
emit_byte(cinfo, cinfo^.Ss);
emit_byte(cinfo, cinfo^.Se);
emit_byte(cinfo, (cinfo^.Ah shl 4) + cinfo^.Al);
end;
{LOCAL}
procedure emit_jfif_app0 (cinfo : j_compress_ptr);
{ Emit a JFIF-compliant APP0 marker }
{
Length of APP0 block (2 bytes)
Block ID (4 bytes - ASCII "JFIF")
Zero byte (1 byte to terminate the ID string)
Version Major, Minor (2 bytes - major first)
Units (1 byte - $00 = none, $01 = inch, $02 = cm)
Xdpu (2 bytes - dots per unit horizontal)
Ydpu (2 bytes - dots per unit vertical)
Thumbnail X size (1 byte)
Thumbnail Y size (1 byte)
}
begin
emit_marker(cinfo, M_APP0);
emit_2bytes(cinfo, 2 + 4 + 1 + 2 + 1 + 2 + 2 + 1 + 1); { length }
emit_byte(cinfo, $4A); { Identifier: ASCII "JFIF" }
emit_byte(cinfo, $46);
emit_byte(cinfo, $49);
emit_byte(cinfo, $46);
emit_byte(cinfo, 0);
emit_byte(cinfo, cinfo^.JFIF_major_version); { Version fields }
emit_byte(cinfo, cinfo^.JFIF_minor_version);
emit_byte(cinfo, cinfo^.density_unit); { Pixel size information }
emit_2bytes(cinfo, int(cinfo^.X_density));
emit_2bytes(cinfo, int(cinfo^.Y_density));
emit_byte(cinfo, 0); { No thumbnail image }
emit_byte(cinfo, 0);
end;
{LOCAL}
procedure emit_adobe_app14 (cinfo : j_compress_ptr);
{ Emit an Adobe APP14 marker }
{
Length of APP14 block (2 bytes)
Block ID (5 bytes - ASCII "Adobe")
Version Number (2 bytes - currently 100)
Flags0 (2 bytes - currently 0)
Flags1 (2 bytes - currently 0)
Color transform (1 byte)
Although Adobe TN 5116 mentions Version = 101, all the Adobe files
now in circulation seem to use Version = 100, so that's what we write.
We write the color transform byte as 1 if the JPEG color space is
YCbCr, 2 if it's YCCK, 0 otherwise. Adobe's definition has to do with
whether the encoder performed a transformation, which is pretty useless.
}
begin
emit_marker(cinfo, M_APP14);
emit_2bytes(cinfo, 2 + 5 + 2 + 2 + 2 + 1); { length }
emit_byte(cinfo, $41); { Identifier: ASCII "Adobe" }
emit_byte(cinfo, $64);
emit_byte(cinfo, $6F);
emit_byte(cinfo, $62);
emit_byte(cinfo, $65);
emit_2bytes(cinfo, 100); { Version }
emit_2bytes(cinfo, 0); { Flags0 }
emit_2bytes(cinfo, 0); { Flags1 }
case (cinfo^.jpeg_color_space) of
JCS_YCbCr:
emit_byte(cinfo, 1); { Color transform = 1 }
JCS_YCCK:
emit_byte(cinfo, 2); { Color transform = 2 }
else
emit_byte(cinfo, 0); { Color transform = 0 }
end;
end;
{ These routines allow writing an arbitrary marker with parameters.
The only intended use is to emit COM or APPn markers after calling
write_file_header and before calling write_frame_header.
Other uses are not guaranteed to produce desirable results.
Counting the parameter bytes properly is the caller's responsibility. }
{METHODDEF}
procedure write_marker_header (cinfo : j_compress_ptr;
marker : int;
datalen : uint);
{ Emit an arbitrary marker header }
begin
if (datalen > uint(65533)) then { safety check }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
emit_marker(cinfo, JPEG_MARKER(marker));
emit_2bytes(cinfo, int(datalen + 2)); { total length }
end;
{METHODDEF}
procedure write_marker_byte (cinfo : j_compress_ptr; val : int);
{ Emit one byte of marker parameters following write_marker_header }
begin
emit_byte(cinfo, val);
end;
{ Write datastream header.
This consists of an SOI and optional APPn markers.
We recommend use of the JFIF marker, but not the Adobe marker,
when using YCbCr or grayscale data. The JFIF marker should NOT
be used for any other JPEG colorspace. The Adobe marker is helpful
to distinguish RGB, CMYK, and YCCK colorspaces.
Note that an application can write additional header markers after
jpeg_start_compress returns. }
{METHODDEF}
procedure write_file_header (cinfo : j_compress_ptr);
var
marker : my_marker_ptr;
begin
marker := my_marker_ptr(cinfo^.marker);
emit_marker(cinfo, M_SOI); { first the SOI }
{ SOI is defined to reset restart interval to 0 }
marker^.last_restart_interval := 0;
if (cinfo^.write_JFIF_header) then { next an optional JFIF APP0 }
emit_jfif_app0(cinfo);
if (cinfo^.write_Adobe_marker) then { next an optional Adobe APP14 }
emit_adobe_app14(cinfo);
end;
{ Write frame header.
This consists of DQT and SOFn markers.
Note that we do not emit the SOF until we have emitted the DQT(s).
This avoids compatibility problems with incorrect implementations that
try to error-check the quant table numbers as soon as they see the SOF. }
{METHODDEF}
procedure write_frame_header (cinfo : j_compress_ptr);
var
ci, prec : int;
is_baseline : boolean;
compptr : jpeg_component_info_ptr;
begin
{ Emit DQT for each quantization table.
Note that emit_dqt() suppresses any duplicate tables. }
prec := 0;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to Pred(cinfo^.num_components) do
begin
prec := prec + emit_dqt(cinfo, compptr^.quant_tbl_no);
Inc(compptr);
end;
{ now prec is nonzero iff there are any 16-bit quant tables. }
{ Check for a non-baseline specification.
Note we assume that Huffman table numbers won't be changed later. }
if (cinfo^.arith_code) or (cinfo^.progressive_mode)
or (cinfo^.data_precision <> 8) then
begin
is_baseline := FALSE;
end
else
begin
is_baseline := TRUE;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to Pred(cinfo^.num_components) do
begin
if (compptr^.dc_tbl_no > 1) or (compptr^.ac_tbl_no > 1) then
is_baseline := FALSE;
Inc(compptr);
end;
if (prec <> 0) and (is_baseline) then
begin
is_baseline := FALSE;
{ If it's baseline except for quantizer size, warn the user }
{$IFDEF DEBUG}
TRACEMS(j_common_ptr(cinfo), 0, JTRC_16BIT_TABLES);
{$ENDIF}
end;
end;
{ Emit the proper SOF marker }
if (cinfo^.arith_code) then
begin
emit_sof(cinfo, M_SOF9); { SOF code for arithmetic coding }
end
else
begin
if (cinfo^.progressive_mode) then
emit_sof(cinfo, M_SOF2) { SOF code for progressive Huffman }
else if (is_baseline) then
emit_sof(cinfo, M_SOF0) { SOF code for baseline implementation }
else
emit_sof(cinfo, M_SOF1); { SOF code for non-baseline Huffman file }
end;
end;
{ Write scan header.
This consists of DHT or DAC markers, optional DRI, and SOS.
Compressed data will be written following the SOS. }
{METHODDEF}
procedure write_scan_header (cinfo : j_compress_ptr);
var
marker : my_marker_ptr;
i : int;
compptr : jpeg_component_info_ptr;
begin
marker := my_marker_ptr(cinfo^.marker);
if (cinfo^.arith_code) then
begin
{ Emit arith conditioning info. We may have some duplication
if the file has multiple scans, but it's so small it's hardly
worth worrying about. }
emit_dac(cinfo);
end
else
begin
{ Emit Huffman tables.
Note that emit_dht() suppresses any duplicate tables. }
for i := 0 to Pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[i];
if (cinfo^.progressive_mode) then
begin
{ Progressive mode: only DC or only AC tables are used in one scan }
if (cinfo^.Ss = 0) then
begin
if (cinfo^.Ah = 0) then { DC needs no table for refinement scan }
emit_dht(cinfo, compptr^.dc_tbl_no, FALSE);
end
else
begin
emit_dht(cinfo, compptr^.ac_tbl_no, TRUE);
end;
end
else
begin
{ Sequential mode: need both DC and AC tables }
emit_dht(cinfo, compptr^.dc_tbl_no, FALSE);
emit_dht(cinfo, compptr^.ac_tbl_no, TRUE);
end;
end;
end;
{ Emit DRI if required --- note that DRI value could change for each scan.
We avoid wasting space with unnecessary DRIs, however. }
if (cinfo^.restart_interval <> marker^.last_restart_interval) then
begin
emit_dri(cinfo);
marker^.last_restart_interval := cinfo^.restart_interval;
end;
emit_sos(cinfo);
end;
{ Write datastream trailer. }
{METHODDEF}
procedure write_file_trailer (cinfo : j_compress_ptr);
begin
emit_marker(cinfo, M_EOI);
end;
{ Write an abbreviated table-specification datastream.
This consists of SOI, DQT and DHT tables, and EOI.
Any table that is defined and not marked sent_table = TRUE will be
emitted. Note that all tables will be marked sent_table = TRUE at exit. }
{METHODDEF}
procedure write_tables_only (cinfo : j_compress_ptr);
var
i : int;
begin
emit_marker(cinfo, M_SOI);
for i := 0 to Pred(NUM_QUANT_TBLS) do
begin
if (cinfo^.quant_tbl_ptrs[i] <> NIL) then
emit_dqt(cinfo, i); { dummy := ... }
end;
if (not cinfo^.arith_code) then
begin
for i := 0 to Pred(NUM_HUFF_TBLS) do
begin
if (cinfo^.dc_huff_tbl_ptrs[i] <> NIL) then
emit_dht(cinfo, i, FALSE);
if (cinfo^.ac_huff_tbl_ptrs[i] <> NIL) then
emit_dht(cinfo, i, TRUE);
end;
end;
emit_marker(cinfo, M_EOI);
end;
{ Initialize the marker writer module. }
{GLOBAL}
procedure jinit_marker_writer (cinfo : j_compress_ptr);
var
marker : my_marker_ptr;
begin
{ Create the subobject }
marker := my_marker_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_marker_writer)) );
cinfo^.marker := jpeg_marker_writer_ptr(marker);
{ Initialize method pointers }
marker^.pub.write_file_header := write_file_header;
marker^.pub.write_frame_header := write_frame_header;
marker^.pub.write_scan_header := write_scan_header;
marker^.pub.write_file_trailer := write_file_trailer;
marker^.pub.write_tables_only := write_tables_only;
marker^.pub.write_marker_header := write_marker_header;
marker^.pub.write_marker_byte := write_marker_byte;
{ Initialize private state }
marker^.last_restart_interval := 0;
end;
end.

701
Imaging/JpegLib/imjcmaster.pas Normal file
View File

@@ -0,0 +1,701 @@
unit imjcmaster;
{ This file contains master control logic for the JPEG compressor.
These routines are concerned with parameter validation, initial setup,
and inter-pass control (determining the number of passes and the work
to be done in each pass). }
{ Original: jcmaster.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjutils,
imjpeglib;
{ Initialize master compression control. }
{GLOBAL}
procedure jinit_c_master_control (cinfo : j_compress_ptr;
transcode_only : boolean);
implementation
{ Private state }
type
c_pass_type = (
main_pass, { input data, also do first output step }
huff_opt_pass, { Huffman code optimization pass }
output_pass { data output pass }
);
type
my_master_ptr = ^my_comp_master;
my_comp_master = record
pub : jpeg_comp_master; { public fields }
pass_type : c_pass_type; { the type of the current pass }
pass_number : int; { # of passes completed }
total_passes : int; { total # of passes needed }
scan_number : int; { current index in scan_info[] }
end;
{ Support routines that do various essential calculations. }
{LOCAL}
procedure initial_setup (cinfo : j_compress_ptr);
{ Do computations that are needed before master selection phase }
var
ci : int;
compptr : jpeg_component_info_ptr;
samplesperrow : long;
jd_samplesperrow : JDIMENSION;
begin
{ Sanity check on image dimensions }
if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0) or
(cinfo^.num_components <= 0) or (cinfo^.input_components <= 0) then
ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE);
{ Make sure image isn't bigger than I can handle }
if ( long(cinfo^.image_height) > long(JPEG_MAX_DIMENSION)) or
( long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG,
uInt(JPEG_MAX_DIMENSION));
{ Width of an input scanline must be representable as JDIMENSION. }
samplesperrow := long (cinfo^.image_width) * long (cinfo^.input_components);
jd_samplesperrow := JDIMENSION (samplesperrow);
if ( long(jd_samplesperrow) <> samplesperrow) then
ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW);
{ For now, precision must match compiled-in value... }
if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision);
{ Check that number of components won't exceed internal array sizes }
if (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPONENTS);
{ Compute maximum sampling factors; check factor validity }
cinfo^.max_h_samp_factor := 1;
cinfo^.max_v_samp_factor := 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR)
or (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING);
{ MAX }
if cinfo^.max_h_samp_factor > compptr^.h_samp_factor then
cinfo^.max_h_samp_factor := cinfo^.max_h_samp_factor
else
cinfo^.max_h_samp_factor := compptr^.h_samp_factor;
{ MAX }
if cinfo^.max_v_samp_factor > compptr^.v_samp_factor then
cinfo^.max_v_samp_factor := cinfo^.max_v_samp_factor
else
cinfo^.max_v_samp_factor := compptr^.v_samp_factor;
Inc(compptr);
end;
{ Compute dimensions of components }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Fill in the correct component_index value; don't rely on application }
compptr^.component_index := ci;
{ For compression, we never do DCT scaling. }
compptr^.DCT_scaled_size := DCTSIZE;
{ Size in DCT blocks }
compptr^.width_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) * long (compptr^.h_samp_factor),
long (cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.height_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long (compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor * DCTSIZE)) );
{ Size in samples }
compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long(cinfo^.image_width) * long(compptr^.h_samp_factor),
long(cinfo^.max_h_samp_factor)) );
compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor)) );
{ Mark component needed (this flag isn't actually used for compression) }
compptr^.component_needed := TRUE;
Inc(compptr);
end;
{ Compute number of fully interleaved MCU rows (number of times that
main controller will call coefficient controller). }
cinfo^.total_iMCU_rows := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) );
end;
{$ifdef C_MULTISCAN_FILES_SUPPORTED}
{LOCAL}
procedure validate_script (cinfo : j_compress_ptr);
{ Verify that the scan script in cinfo^.scan_info[] is valid; also
determine whether it uses progressive JPEG, and set cinfo^.progressive_mode. }
type
IntRow = array[0..DCTSIZE2-1] of int;
introw_ptr = ^IntRow;
var
{const}scanptr : jpeg_scan_info_ptr;
scanno, ncomps, ci, coefi, thisi : int;
Ss, Se, Ah, Al : int;
component_sent : array[0..MAX_COMPONENTS-1] of boolean;
{$ifdef C_PROGRESSIVE_SUPPORTED}
last_bitpos_int_ptr : int_ptr;
last_bitpos_ptr : introw_ptr;
last_bitpos : array[0..MAX_COMPONENTS-1] of IntRow;
{ -1 until that coefficient has been seen; then last Al for it }
{ The JPEG spec simply gives the ranges 0..13 for Ah and Al, but that
seems wrong: the upper bound ought to depend on data precision.
Perhaps they really meant 0..N+1 for N-bit precision.
Here we allow 0..10 for 8-bit data; Al larger than 10 results in
out-of-range reconstructed DC values during the first DC scan,
which might cause problems for some decoders. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
MAX_AH_AL = 10;
{$else}
const
MAX_AH_AL = 13;
{$endif}
{$endif}
begin
if (cinfo^.num_scans <= 0) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, 0);
{ For sequential JPEG, all scans must have Ss=0, Se=DCTSIZE2-1;
for progressive JPEG, no scan can have this. }
scanptr := cinfo^.scan_info;
if (scanptr^.Ss <> 0) or (scanptr^.Se <> DCTSIZE2-1) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
cinfo^.progressive_mode := TRUE;
last_bitpos_int_ptr := @(last_bitpos[0][0]);
for ci := 0 to pred(cinfo^.num_components) do
for coefi := 0 to pred(DCTSIZE2) do
begin
last_bitpos_int_ptr^ := -1;
Inc(last_bitpos_int_ptr);
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
cinfo^.progressive_mode := FALSE;
for ci := 0 to pred(cinfo^.num_components) do
component_sent[ci] := FALSE;
end;
for scanno := 1 to cinfo^.num_scans do
begin
{ Validate component indexes }
ncomps := scanptr^.comps_in_scan;
if (ncomps <= 0) or (ncomps > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, ncomps, MAX_COMPS_IN_SCAN);
for ci := 0 to pred(ncomps) do
begin
thisi := scanptr^.component_index[ci];
if (thisi < 0) or (thisi >= cinfo^.num_components) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno);
{ Components must appear in SOF order within each scan }
if (ci > 0) and (thisi <= scanptr^.component_index[ci-1]) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno);
end;
{ Validate progression parameters }
Ss := scanptr^.Ss;
Se := scanptr^.Se;
Ah := scanptr^.Ah;
Al := scanptr^.Al;
if (cinfo^.progressive_mode) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2) or
(Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2)
or (Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
if (Ss = 0) then
begin
if (Se <> 0) then { DC and AC together not OK }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
end
else
begin
if (ncomps <> 1) then { AC scans must be for only one component }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
end;
for ci := 0 to pred(ncomps) do
begin
last_bitpos_ptr := @( last_bitpos[scanptr^.component_index[ci]]);
if (Ss <> 0) and (last_bitpos_ptr^[0] < 0) then { AC without prior DC scan }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
for coefi := Ss to Se do
begin
if (last_bitpos_ptr^[coefi] < 0) then
begin
{ first scan of this coefficient }
if (Ah <> 0) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
end
else
begin
{ not first scan }
if (Ah <> last_bitpos_ptr^[coefi]) or (Al <> Ah-1) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
end;
last_bitpos_ptr^[coefi] := Al;
end;
end;
{$endif}
end
else
begin
{ For sequential JPEG, all progression parameters must be these: }
if (Ss <> 0) or (Se <> DCTSIZE2-1) or (Ah <> 0) or (Al <> 0) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno);
{ Make sure components are not sent twice }
for ci := 0 to pred(ncomps) do
begin
thisi := scanptr^.component_index[ci];
if (component_sent[thisi]) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno);
component_sent[thisi] := TRUE;
end;
end;
Inc(scanptr);
end;
{ Now verify that everything got sent. }
if (cinfo^.progressive_mode) then
begin
{$ifdef C_PROGRESSIVE_SUPPORTED}
{ For progressive mode, we only check that at least some DC data
got sent for each component; the spec does not require that all bits
of all coefficients be transmitted. Would it be wiser to enforce
transmission of all coefficient bits?? }
for ci := 0 to pred(cinfo^.num_components) do
begin
if (last_bitpos[ci][0] < 0) then
ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA);
end;
{$endif}
end
else
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
if (not component_sent[ci]) then
ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA);
end;
end;
end;
{$endif} { C_MULTISCAN_FILES_SUPPORTED }
{LOCAL}
procedure select_scan_parameters (cinfo : j_compress_ptr);
{ Set up the scan parameters for the current scan }
var
master : my_master_ptr;
{const} scanptr : jpeg_scan_info_ptr;
ci : int;
var
comp_infos : jpeg_component_info_list_ptr;
begin
{$ifdef C_MULTISCAN_FILES_SUPPORTED}
if (cinfo^.scan_info <> NIL) then
begin
{ Prepare for current scan --- the script is already validated }
master := my_master_ptr (cinfo^.master);
scanptr := cinfo^.scan_info;
Inc(scanptr, master^.scan_number);
cinfo^.comps_in_scan := scanptr^.comps_in_scan;
comp_infos := cinfo^.comp_info;
for ci := 0 to pred(scanptr^.comps_in_scan) do
begin
cinfo^.cur_comp_info[ci] :=
@(comp_infos^[scanptr^.component_index[ci]]);
end;
cinfo^.Ss := scanptr^.Ss;
cinfo^.Se := scanptr^.Se;
cinfo^.Ah := scanptr^.Ah;
cinfo^.Al := scanptr^.Al;
end
else
{$endif}
begin
{ Prepare for single sequential-JPEG scan containing all components }
if (cinfo^.num_components > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPS_IN_SCAN);
cinfo^.comps_in_scan := cinfo^.num_components;
comp_infos := cinfo^.comp_info;
for ci := 0 to pred(cinfo^.num_components) do
begin
cinfo^.cur_comp_info[ci] := @(comp_infos^[ci]);
end;
cinfo^.Ss := 0;
cinfo^.Se := DCTSIZE2-1;
cinfo^.Ah := 0;
cinfo^.Al := 0;
end;
end;
{LOCAL}
procedure per_scan_setup (cinfo : j_compress_ptr);
{ Do computations that are needed before processing a JPEG scan }
{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] are already set }
var
ci, mcublks, tmp : int;
compptr : jpeg_component_info_ptr;
nominal : long;
begin
if (cinfo^.comps_in_scan = 1) then
begin
{ Noninterleaved (single-component) scan }
compptr := cinfo^.cur_comp_info[0];
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := compptr^.width_in_blocks;
cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks;
{ For noninterleaved scan, always one block per MCU }
compptr^.MCU_width := 1;
compptr^.MCU_height := 1;
compptr^.MCU_blocks := 1;
compptr^.MCU_sample_width := DCTSIZE;
compptr^.last_col_width := 1;
{ For noninterleaved scans, it is convenient to define last_row_height
as the number of block rows present in the last iMCU row. }
tmp := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor;
if (tmp = 0) then
tmp := compptr^.v_samp_factor;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
cinfo^.blocks_in_MCU := 1;
cinfo^.MCU_membership[0] := 0;
end
else
begin
{ Interleaved (multi-component) scan }
if (cinfo^.comps_in_scan <= 0) or
(cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT,
cinfo^.comps_in_scan, MAX_COMPS_IN_SCAN);
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := JDIMENSION (
jdiv_round_up( long (cinfo^.image_width),
long (cinfo^.max_h_samp_factor*DCTSIZE)) );
cinfo^.MCU_rows_in_scan := JDIMENSION (
jdiv_round_up( long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) );
cinfo^.blocks_in_MCU := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Sampling factors give # of blocks of component in each MCU }
compptr^.MCU_width := compptr^.h_samp_factor;
compptr^.MCU_height := compptr^.v_samp_factor;
compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height;
compptr^.MCU_sample_width := compptr^.MCU_width * DCTSIZE;
{ Figure number of non-dummy blocks in last MCU column & row }
tmp := int (compptr^.width_in_blocks) mod compptr^.MCU_width;
if (tmp = 0) then
tmp := compptr^.MCU_width;
compptr^.last_col_width := tmp;
tmp := int (compptr^.height_in_blocks) mod compptr^.MCU_height;
if (tmp = 0) then
tmp := compptr^.MCU_height;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
mcublks := compptr^.MCU_blocks;
if (cinfo^.blocks_in_MCU + mcublks > C_MAX_BLOCKS_IN_MCU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE);
while (mcublks > 0) do
begin
Dec(mcublks);
cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci;
Inc(cinfo^.blocks_in_MCU);
end;
end;
end;
{ Convert restart specified in rows to actual MCU count. }
{ Note that count must fit in 16 bits, so we provide limiting. }
if (cinfo^.restart_in_rows > 0) then
begin
nominal := long(cinfo^.restart_in_rows) * long(cinfo^.MCUs_per_row);
if nominal < long(65535) then
cinfo^.restart_interval := uInt (nominal)
else
cinfo^.restart_interval := long(65535);
end;
end;
{ Per-pass setup.
This is called at the beginning of each pass. We determine which modules
will be active during this pass and give them appropriate start_pass calls.
We also set is_last_pass to indicate whether any more passes will be
required. }
{METHODDEF}
procedure prepare_for_pass (cinfo : j_compress_ptr);
var
master : my_master_ptr;
var
fallthrough : boolean;
begin
master := my_master_ptr (cinfo^.master);
fallthrough := true;
case (master^.pass_type) of
main_pass:
begin
{ Initial pass: will collect input data, and do either Huffman
optimization or data output for the first scan. }
select_scan_parameters(cinfo);
per_scan_setup(cinfo);
if (not cinfo^.raw_data_in) then
begin
cinfo^.cconvert^.start_pass (cinfo);
cinfo^.downsample^.start_pass (cinfo);
cinfo^.prep^.start_pass (cinfo, JBUF_PASS_THRU);
end;
cinfo^.fdct^.start_pass (cinfo);
cinfo^.entropy^.start_pass (cinfo, cinfo^.optimize_coding);
if master^.total_passes > 1 then
cinfo^.coef^.start_pass (cinfo, JBUF_SAVE_AND_PASS)
else
cinfo^.coef^.start_pass (cinfo, JBUF_PASS_THRU);
cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU);
if (cinfo^.optimize_coding) then
begin
{ No immediate data output; postpone writing frame/scan headers }
master^.pub.call_pass_startup := FALSE;
end
else
begin
{ Will write frame/scan headers at first jpeg_write_scanlines call }
master^.pub.call_pass_startup := TRUE;
end;
end;
{$ifdef ENTROPY_OPT_SUPPORTED}
huff_opt_pass,
output_pass:
begin
if (master^.pass_type = huff_opt_pass) then
begin
{ Do Huffman optimization for a scan after the first one. }
select_scan_parameters(cinfo);
per_scan_setup(cinfo);
if (cinfo^.Ss <> 0) or (cinfo^.Ah = 0) or (cinfo^.arith_code) then
begin
cinfo^.entropy^.start_pass (cinfo, TRUE);
cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST);
master^.pub.call_pass_startup := FALSE;
fallthrough := false;
end;
{ Special case: Huffman DC refinement scans need no Huffman table
and therefore we can skip the optimization pass for them. }
if fallthrough then
begin
master^.pass_type := output_pass;
Inc(master^.pass_number);
{FALLTHROUGH}
end;
end;
{$else}
output_pass:
begin
{$endif}
if fallthrough then
begin
{ Do a data-output pass. }
{ We need not repeat per-scan setup if prior optimization pass did it. }
if (not cinfo^.optimize_coding) then
begin
select_scan_parameters(cinfo);
per_scan_setup(cinfo);
end;
cinfo^.entropy^.start_pass (cinfo, FALSE);
cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST);
{ We emit frame/scan headers now }
if (master^.scan_number = 0) then
cinfo^.marker^.write_frame_header (cinfo);
cinfo^.marker^.write_scan_header (cinfo);
master^.pub.call_pass_startup := FALSE;
end;
end;
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
master^.pub.is_last_pass := (master^.pass_number = master^.total_passes-1);
{ Set up progress monitor's pass info if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.completed_passes := master^.pass_number;
cinfo^.progress^.total_passes := master^.total_passes;
end;
end;
{ Special start-of-pass hook.
This is called by jpeg_write_scanlines if call_pass_startup is TRUE.
In single-pass processing, we need this hook because we don't want to
write frame/scan headers during jpeg_start_compress; we want to let the
application write COM markers etc. between jpeg_start_compress and the
jpeg_write_scanlines loop.
In multi-pass processing, this routine is not used. }
{METHODDEF}
procedure pass_startup (cinfo : j_compress_ptr);
begin
cinfo^.master^.call_pass_startup := FALSE; { reset flag so call only once }
cinfo^.marker^.write_frame_header (cinfo);
cinfo^.marker^.write_scan_header (cinfo);
end;
{ Finish up at end of pass. }
{METHODDEF}
procedure finish_pass_master (cinfo : j_compress_ptr);
var
master : my_master_ptr;
begin
master := my_master_ptr (cinfo^.master);
{ The entropy coder always needs an end-of-pass call,
either to analyze statistics or to flush its output buffer. }
cinfo^.entropy^.finish_pass (cinfo);
{ Update state for next pass }
case (master^.pass_type) of
main_pass:
begin
{ next pass is either output of scan 0 (after optimization)
or output of scan 1 (if no optimization). }
master^.pass_type := output_pass;
if (not cinfo^.optimize_coding) then
Inc(master^.scan_number);
end;
huff_opt_pass:
{ next pass is always output of current scan }
master^.pass_type := output_pass;
output_pass:
begin
{ next pass is either optimization or output of next scan }
if (cinfo^.optimize_coding) then
master^.pass_type := huff_opt_pass;
Inc(master^.scan_number);
end;
end;
Inc(master^.pass_number);
end;
{ Initialize master compression control. }
{GLOBAL}
procedure jinit_c_master_control (cinfo : j_compress_ptr;
transcode_only : boolean);
var
master : my_master_ptr;
begin
master := my_master_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_comp_master)) );
cinfo^.master := jpeg_comp_master_ptr(master);
master^.pub.prepare_for_pass := prepare_for_pass;
master^.pub.pass_startup := pass_startup;
master^.pub.finish_pass := finish_pass_master;
master^.pub.is_last_pass := FALSE;
{ Validate parameters, determine derived values }
initial_setup(cinfo);
if (cinfo^.scan_info <> NIL) then
begin
{$ifdef C_MULTISCAN_FILES_SUPPORTED}
validate_script(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
cinfo^.progressive_mode := FALSE;
cinfo^.num_scans := 1;
end;
if (cinfo^.progressive_mode) then { TEMPORARY HACK ??? }
cinfo^.optimize_coding := TRUE; { assume default tables no good for progressive mode }
{ Initialize my private state }
if (transcode_only) then
begin
{ no main pass in transcoding }
if (cinfo^.optimize_coding) then
master^.pass_type := huff_opt_pass
else
master^.pass_type := output_pass;
end
else
begin
{ for normal compression, first pass is always this type: }
master^.pass_type := main_pass;
end;
master^.scan_number := 0;
master^.pass_number := 0;
if (cinfo^.optimize_coding) then
master^.total_passes := cinfo^.num_scans * 2
else
master^.total_passes := cinfo^.num_scans;
end;
end.

130
Imaging/JpegLib/imjcomapi.pas Normal file
View File

@@ -0,0 +1,130 @@
unit imjcomapi;
{ This file contains application interface routines that are used for both
compression and decompression. }
{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
{ Destruction of a JPEG object. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
implementation
{ Abort processing of a JPEG compression or decompression operation,
but don't destroy the object itself.
For this, we merely clean up all the nonpermanent memory pools.
Note that temp files (virtual arrays) are not allowed to belong to
the permanent pool, so we will be able to close all temp files here.
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_abort (cinfo : j_common_ptr);
var
pool : int;
begin
{ Do nothing if called on a not-initialized or destroyed JPEG object. }
if (cinfo^.mem = NIL) then
exit;
{ Releasing pools in reverse order might help avoid fragmentation
with some (brain-damaged) malloc libraries. }
for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do
begin
cinfo^.mem^.free_pool (cinfo, pool);
end;
{ Reset overall state for possible reuse of object }
if (cinfo^.is_decompressor) then
begin
cinfo^.global_state := DSTATE_START;
{ Try to keep application from accessing now-deleted marker list.
A bit kludgy to do it here, but this is the most central place. }
j_decompress_ptr(cinfo)^.marker_list := NIL;
end
else
begin
cinfo^.global_state := CSTATE_START;
end;
end;
{ Destruction of a JPEG object.
Everything gets deallocated except the master jpeg_compress_struct itself
and the error manager struct. Both of these are supplied by the application
and must be freed, if necessary, by the application. (Often they are on
the stack and so don't need to be freed anyway.)
Closing a data source or destination, if necessary, is the application's
responsibility. }
{GLOBAL}
procedure jpeg_destroy (cinfo : j_common_ptr);
begin
{ We need only tell the memory manager to release everything. }
{ NB: mem pointer is NIL if memory mgr failed to initialize. }
if (cinfo^.mem <> NIL) then
cinfo^.mem^.self_destruct (cinfo);
cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice }
cinfo^.global_state := 0; { mark it destroyed }
end;
{ Convenience routines for allocating quantization and Huffman tables.
(Would jutils.c be a more reasonable place to put these?) }
{GLOBAL}
function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR;
var
tbl : JQUANT_TBL_PTR;
begin
tbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_quant_table := tbl;
end;
{GLOBAL}
function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR;
var
tbl : JHUFF_TBL_PTR;
begin
tbl := JHUFF_TBL_PTR(
cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL))
);
tbl^.sent_table := FALSE; { make sure this is false in any new table }
jpeg_alloc_huff_table := tbl;
end;
end.

124
Imaging/JpegLib/imjconfig.inc Normal file
View File

@@ -0,0 +1,124 @@
{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- }
{ These defines indicate whether to include various optional functions.
Undefining some of these symbols will produce a smaller but less capable
library. Note that you can leave certain source files out of the
compilation/linking process if you've #undef'd the corresponding symbols.
(You may HAVE to do that if your compiler doesn't like null source files.)}
{ Arithmetic coding is unsupported for legal reasons. Complaints to IBM. }
{ Capability options common to encoder and decoder: }
{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm }
{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method }
{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW }
{ Encoder capability options: }
{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? }
{ Note: if you selected 12-bit data precision, it is dangerous to turn off
ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit
precision, so jchuff.c normally uses entropy optimization to compute
usable tables for higher precision. If you don't want to do optimization,
you'll have to supply different default Huffman tables.
The exact same statements apply for progressive JPEG: the default tables
don't work for progressive mode. (This may get fixed, however.) }
{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? }
{ Decoder capability options: }
{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? }
{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? }
{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)}
{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? }
{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) }
{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? }
{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? }
{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? }
{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? }
{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? }
{ If you happen not to want the image transform support, disable it here }
{$define TRANSFORMS_SUPPORTED}
{ more capability options later, no doubt }
{$ifopt I+} {$define IOcheck} {$endif}
{ ------------------------------------------------------------------------ }
{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() }
{$define FMEMCOPY}
{$define FMEMZERO}
{$define DCTSIZE_IS_8} { e.g. unroll the inner loop }
{$define RIGHT_SHIFT_IS_UNSIGNED}
{$undef AVOID_TABLES}
{$undef FAST_DIVIDE}
{$define BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
{ for test of 12 bit JPEG code only. !! }
{-- $undef BITS_IN_JSAMPLE_IS_8}
{----------------------------------------------------------------}
//{$define RGB_RED_IS_0}
{ !CHANGE: This must be defined for Delphi/Kylix/FPC }
{$define RGB_RED_IS_2} { RGB byte order }
{$define RGB_PIXELSIZE_IS_3}
{$define SLOW_SHIFT_32}
{$undef NO_ZERO_ROW_TEST}
{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c }
{$define XMS_SUPPORTED}
{$define EMS_SUPPORTED}
{$undef MEM_STATS} { Write out memory usage }
{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs }
{$undef FULL_MAIN_BUFFER_SUPPORTED}
{$define PROGRESS_REPORT}
{$define TWO_FILE_COMMANDLINE}
{$undef BMP_SUPPORTED}
{$undef PPM_SUPPORTED}
{$undef GIF_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$define EXT_SWITCH}
{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples }
{$undef BMP_SUPPORTED}
{$undef RLE_SUPPORTED}
{$undef TARGA_SUPPORTED}
{$endif}
{!CHANGE: Allowed only for Delphi}
{$undef BASM16} { for TP7 - use BASM for fast multiply }
{$ifdef Win32}
{$ifndef FPC}
{$define BASM} { jidctint with BASM for Delphi 2/3 }
{$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 }
{$endif}
{$endif}
{$ifdef FPC}
{$MODE DELPHI}
{$endif}
{!CHANGE: Added this}
{$define Delphi_Stream}
{$Q-}

701
Imaging/JpegLib/imjcparam.pas Normal file
View File

@@ -0,0 +1,701 @@
unit imjcparam;
{ This file contains optional default-setting code for the JPEG compressor.
Applications do not have to use this file, but those that don't use it
must know a lot more about the innards of the JPEG code. }
{ Original: jcparam.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjcomapi,
imjpeglib;
{ Quantization table setup routines }
{GLOBAL}
procedure jpeg_add_quant_table (cinfo : j_compress_ptr;
which_tbl : int;
const basic_table : array of uInt;
scale_factor : int;
force_baseline : boolean);
{GLOBAL}
procedure jpeg_set_linear_quality (cinfo : j_compress_ptr;
scale_factor : int;
force_baseline : boolean);
{ Set or change the 'quality' (quantization) setting, using default tables
and a straight percentage-scaling quality scale. In most cases it's better
to use jpeg_set_quality (below); this entry point is provided for
applications that insist on a linear percentage scaling. }
{GLOBAL}
function jpeg_quality_scaling (quality : int) : int;
{ Convert a user-specified quality rating to a percentage scaling factor
for an underlying quantization table, using our recommended scaling curve.
The input 'quality' factor should be 0 (terrible) to 100 (very good). }
{GLOBAL}
procedure jpeg_set_quality (cinfo : j_compress_ptr;
quality : int;
force_baseline : boolean);
{ Set or change the 'quality' (quantization) setting, using default tables.
This is the standard quality-adjusting entry point for typical user
interfaces; only those who want detailed control over quantization tables
would use the preceding three routines directly. }
{GLOBAL}
procedure jpeg_set_defaults (cinfo : j_compress_ptr);
{ Create a recommended progressive-JPEG script.
cinfo^.num_components and cinfo^.jpeg_color_space must be correct. }
{ Set the JPEG colorspace, and choose colorspace-dependent default values. }
{GLOBAL}
procedure jpeg_set_colorspace (cinfo : j_compress_ptr;
colorspace : J_COLOR_SPACE);
{ Select an appropriate JPEG colorspace for in_color_space. }
{GLOBAL}
procedure jpeg_default_colorspace (cinfo : j_compress_ptr);
{GLOBAL}
procedure jpeg_simple_progression (cinfo : j_compress_ptr);
implementation
{ Quantization table setup routines }
{GLOBAL}
procedure jpeg_add_quant_table (cinfo : j_compress_ptr;
which_tbl : int;
const basic_table : array of uInt;
scale_factor : int;
force_baseline : boolean);
{ Define a quantization table equal to the basic_table times
a scale factor (given as a percentage).
If force_baseline is TRUE, the computed quantization table entries
are limited to 1..255 for JPEG baseline compatibility. }
var
qtblptr :^JQUANT_TBL_PTR;
i : int;
temp : long;
begin
{ Safety check to ensure start_compress not called yet. }
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (which_tbl < 0) or (which_tbl >= NUM_QUANT_TBLS) then
ERREXIT1(j_common_ptr(cinfo), JERR_DQT_INDEX, which_tbl);
qtblptr := @(cinfo^.quant_tbl_ptrs[which_tbl]);
if (qtblptr^ = NIL) then
qtblptr^ := jpeg_alloc_quant_table(j_common_ptr(cinfo));
for i := 0 to pred(DCTSIZE2) do
begin
temp := (long(basic_table[i]) * scale_factor + long(50)) div long(100);
{ limit the values to the valid range }
if (temp <= long(0)) then
temp := long(1);
if (temp > long(32767)) then
temp := long(32767); { max quantizer needed for 12 bits }
if (force_baseline) and (temp > long(255)) then
temp := long(255); { limit to baseline range if requested }
(qtblptr^)^.quantval[i] := UINT16 (temp);
end;
{ Initialize sent_table FALSE so table will be written to JPEG file. }
(qtblptr^)^.sent_table := FALSE;
end;
{GLOBAL}
procedure jpeg_set_linear_quality (cinfo : j_compress_ptr;
scale_factor : int;
force_baseline : boolean);
{ Set or change the 'quality' (quantization) setting, using default tables
and a straight percentage-scaling quality scale. In most cases it's better
to use jpeg_set_quality (below); this entry point is provided for
applications that insist on a linear percentage scaling. }
{ These are the sample quantization tables given in JPEG spec section K.1.
The spec says that the values given produce "good" quality, and
when divided by 2, "very good" quality. }
const
std_luminance_quant_tbl : array[0..DCTSIZE2-1] of uInt =
(16, 11, 10, 16, 24, 40, 51, 61,
12, 12, 14, 19, 26, 58, 60, 55,
14, 13, 16, 24, 40, 57, 69, 56,
14, 17, 22, 29, 51, 87, 80, 62,
18, 22, 37, 56, 68, 109, 103, 77,
24, 35, 55, 64, 81, 104, 113, 92,
49, 64, 78, 87, 103, 121, 120, 101,
72, 92, 95, 98, 112, 100, 103, 99);
const
std_chrominance_quant_tbl : array[0..DCTSIZE2-1] of uInt =
(17, 18, 24, 47, 99, 99, 99, 99,
18, 21, 26, 66, 99, 99, 99, 99,
24, 26, 56, 99, 99, 99, 99, 99,
47, 66, 99, 99, 99, 99, 99, 99,
99, 99, 99, 99, 99, 99, 99, 99,
99, 99, 99, 99, 99, 99, 99, 99,
99, 99, 99, 99, 99, 99, 99, 99,
99, 99, 99, 99, 99, 99, 99, 99);
begin
{ Set up two quantization tables using the specified scaling }
jpeg_add_quant_table(cinfo, 0, std_luminance_quant_tbl,
scale_factor, force_baseline);
jpeg_add_quant_table(cinfo, 1, std_chrominance_quant_tbl,
scale_factor, force_baseline);
end;
{GLOBAL}
function jpeg_quality_scaling (quality : int) : int;
{ Convert a user-specified quality rating to a percentage scaling factor
for an underlying quantization table, using our recommended scaling curve.
The input 'quality' factor should be 0 (terrible) to 100 (very good). }
begin
{ Safety limit on quality factor. Convert 0 to 1 to avoid zero divide. }
if (quality <= 0) then
quality := 1;
if (quality > 100) then
quality := 100;
{ The basic table is used as-is (scaling 100) for a quality of 50.
Qualities 50..100 are converted to scaling percentage 200 - 2*Q;
note that at Q=100 the scaling is 0, which will cause jpeg_add_quant_table
to make all the table entries 1 (hence, minimum quantization loss).
Qualities 1..50 are converted to scaling percentage 5000/Q. }
if (quality < 50) then
quality := 5000 div quality
else
quality := 200 - quality*2;
jpeg_quality_scaling := quality;
end;
{GLOBAL}
procedure jpeg_set_quality (cinfo : j_compress_ptr;
quality : int;
force_baseline : boolean);
{ Set or change the 'quality' (quantization) setting, using default tables.
This is the standard quality-adjusting entry point for typical user
interfaces; only those who want detailed control over quantization tables
would use the preceding three routines directly. }
begin
{ Convert user 0-100 rating to percentage scaling }
quality := jpeg_quality_scaling(quality);
{ Set up standard quality tables }
jpeg_set_linear_quality(cinfo, quality, force_baseline);
end;
{ Huffman table setup routines }
{LOCAL}
procedure add_huff_table (cinfo : j_compress_ptr;
var htblptr : JHUFF_TBL_PTR;
var bits : array of UINT8;
var val : array of UINT8);
{ Define a Huffman table }
var
nsymbols, len : int;
begin
if (htblptr = NIL) then
htblptr := jpeg_alloc_huff_table(j_common_ptr(cinfo));
{ Copy the number-of-symbols-of-each-code-length counts }
MEMCOPY(@htblptr^.bits, @bits, SIZEOF(htblptr^.bits));
{ Validate the counts. We do this here mainly so we can copy the right
number of symbols from the val[] array, without risking marching off
the end of memory. jchuff.c will do a more thorough test later. }
nsymbols := 0;
for len := 1 to 16 do
Inc(nsymbols, bits[len]);
if (nsymbols < 1) or (nsymbols > 256) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
MEMCOPY(@htblptr^.huffval, @val, nsymbols * SIZEOF(UINT8));
{ Initialize sent_table FALSE so table will be written to JPEG file. }
(htblptr)^.sent_table := FALSE;
end;
{$J+}
{LOCAL}
procedure std_huff_tables (cinfo : j_compress_ptr);
{ Set up the standard Huffman tables (cf. JPEG standard section K.3) }
{ IMPORTANT: these are only valid for 8-bit data precision! }
const bits_dc_luminance : array[0..17-1] of UINT8 =
({ 0-base } 0, 0, 1, 5, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0);
const val_dc_luminance : array[0..11] of UINT8 =
(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11);
const bits_dc_chrominance : array[0..17-1] of UINT8 =
( { 0-base } 0, 0, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 );
const val_dc_chrominance : array[0..11] of UINT8 =
( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 );
const bits_ac_luminance : array[0..17-1] of UINT8 =
( { 0-base } 0, 0, 2, 1, 3, 3, 2, 4, 3, 5, 5, 4, 4, 0, 0, 1, $7d );
const val_ac_luminance : array[0..161] of UINT8 =
( $01, $02, $03, $00, $04, $11, $05, $12,
$21, $31, $41, $06, $13, $51, $61, $07,
$22, $71, $14, $32, $81, $91, $a1, $08,
$23, $42, $b1, $c1, $15, $52, $d1, $f0,
$24, $33, $62, $72, $82, $09, $0a, $16,
$17, $18, $19, $1a, $25, $26, $27, $28,
$29, $2a, $34, $35, $36, $37, $38, $39,
$3a, $43, $44, $45, $46, $47, $48, $49,
$4a, $53, $54, $55, $56, $57, $58, $59,
$5a, $63, $64, $65, $66, $67, $68, $69,
$6a, $73, $74, $75, $76, $77, $78, $79,
$7a, $83, $84, $85, $86, $87, $88, $89,
$8a, $92, $93, $94, $95, $96, $97, $98,
$99, $9a, $a2, $a3, $a4, $a5, $a6, $a7,
$a8, $a9, $aa, $b2, $b3, $b4, $b5, $b6,
$b7, $b8, $b9, $ba, $c2, $c3, $c4, $c5,
$c6, $c7, $c8, $c9, $ca, $d2, $d3, $d4,
$d5, $d6, $d7, $d8, $d9, $da, $e1, $e2,
$e3, $e4, $e5, $e6, $e7, $e8, $e9, $ea,
$f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8,
$f9, $fa );
const bits_ac_chrominance : array[0..17-1] of UINT8 =
( { 0-base } 0, 0, 2, 1, 2, 4, 4, 3, 4, 7, 5, 4, 4, 0, 1, 2, $77 );
const val_ac_chrominance : array[0..161] of UINT8 =
( $00, $01, $02, $03, $11, $04, $05, $21,
$31, $06, $12, $41, $51, $07, $61, $71,
$13, $22, $32, $81, $08, $14, $42, $91,
$a1, $b1, $c1, $09, $23, $33, $52, $f0,
$15, $62, $72, $d1, $0a, $16, $24, $34,
$e1, $25, $f1, $17, $18, $19, $1a, $26,
$27, $28, $29, $2a, $35, $36, $37, $38,
$39, $3a, $43, $44, $45, $46, $47, $48,
$49, $4a, $53, $54, $55, $56, $57, $58,
$59, $5a, $63, $64, $65, $66, $67, $68,
$69, $6a, $73, $74, $75, $76, $77, $78,
$79, $7a, $82, $83, $84, $85, $86, $87,
$88, $89, $8a, $92, $93, $94, $95, $96,
$97, $98, $99, $9a, $a2, $a3, $a4, $a5,
$a6, $a7, $a8, $a9, $aa, $b2, $b3, $b4,
$b5, $b6, $b7, $b8, $b9, $ba, $c2, $c3,
$c4, $c5, $c6, $c7, $c8, $c9, $ca, $d2,
$d3, $d4, $d5, $d6, $d7, $d8, $d9, $da,
$e2, $e3, $e4, $e5, $e6, $e7, $e8, $e9,
$ea, $f2, $f3, $f4, $f5, $f6, $f7, $f8,
$f9, $fa );
begin
add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[0],
bits_dc_luminance, val_dc_luminance);
add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[0],
bits_ac_luminance, val_ac_luminance);
add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[1],
bits_dc_chrominance, val_dc_chrominance);
add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[1],
bits_ac_chrominance, val_ac_chrominance);
end;
{ Default parameter setup for compression.
Applications that don't choose to use this routine must do their
own setup of all these parameters. Alternately, you can call this
to establish defaults and then alter parameters selectively. This
is the recommended approach since, if we add any new parameters,
your code will still work (they'll be set to reasonable defaults). }
{GLOBAL}
procedure jpeg_set_defaults (cinfo : j_compress_ptr);
var
i : int;
begin
{ Safety check to ensure start_compress not called yet. }
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(J_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Allocate comp_info array large enough for maximum component count.
Array is made permanent in case application wants to compress
multiple images at same param settings. }
if (cinfo^.comp_info = NIL) then
cinfo^.comp_info := jpeg_component_info_list_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
MAX_COMPONENTS * SIZEOF(jpeg_component_info)) );
{ Initialize everything not dependent on the color space }
cinfo^.data_precision := BITS_IN_JSAMPLE;
{ Set up two quantization tables using default quality of 75 }
jpeg_set_quality(cinfo, 75, TRUE);
{ Set up two Huffman tables }
std_huff_tables(cinfo);
{ Initialize default arithmetic coding conditioning }
for i := 0 to pred(NUM_ARITH_TBLS) do
begin
cinfo^.arith_dc_L[i] := 0;
cinfo^.arith_dc_U[i] := 1;
cinfo^.arith_ac_K[i] := 5;
end;
{ Default is no multiple-scan output }
cinfo^.scan_info := NIL;
cinfo^.num_scans := 0;
{ Expect normal source image, not raw downsampled data }
cinfo^.raw_data_in := FALSE;
{ Use Huffman coding, not arithmetic coding, by default }
cinfo^.arith_code := FALSE;
{ By default, don't do extra passes to optimize entropy coding }
cinfo^.optimize_coding := FALSE;
{ The standard Huffman tables are only valid for 8-bit data precision.
If the precision is higher, force optimization on so that usable
tables will be computed. This test can be removed if default tables
are supplied that are valid for the desired precision. }
if (cinfo^.data_precision > 8) then
cinfo^.optimize_coding := TRUE;
{ By default, use the simpler non-cosited sampling alignment }
cinfo^.CCIR601_sampling := FALSE;
{ No input smoothing }
cinfo^.smoothing_factor := 0;
{ DCT algorithm preference }
cinfo^.dct_method := JDCT_DEFAULT;
{ No restart markers }
cinfo^.restart_interval := 0;
cinfo^.restart_in_rows := 0;
{ Fill in default JFIF marker parameters. Note that whether the marker
will actually be written is determined by jpeg_set_colorspace.
By default, the library emits JFIF version code 1.01.
An application that wants to emit JFIF 1.02 extension markers should set
JFIF_minor_version to 2. We could probably get away with just defaulting
to 1.02, but there may still be some decoders in use that will complain
about that; saying 1.01 should minimize compatibility problems. }
cinfo^.JFIF_major_version := 1; { Default JFIF version = 1.01 }
cinfo^.JFIF_minor_version := 1;
cinfo^.density_unit := 0; { Pixel size is unknown by default }
cinfo^.X_density := 1; { Pixel aspect ratio is square by default }
cinfo^.Y_density := 1;
{ Choose JPEG colorspace based on input space, set defaults accordingly }
jpeg_default_colorspace(cinfo);
end;
{ Select an appropriate JPEG colorspace for in_color_space. }
{GLOBAL}
procedure jpeg_default_colorspace (cinfo : j_compress_ptr);
begin
case (cinfo^.in_color_space) of
JCS_GRAYSCALE:
jpeg_set_colorspace(cinfo, JCS_GRAYSCALE);
JCS_RGB:
jpeg_set_colorspace(cinfo, JCS_YCbCr);
JCS_YCbCr:
jpeg_set_colorspace(cinfo, JCS_YCbCr);
JCS_CMYK:
jpeg_set_colorspace(cinfo, JCS_CMYK); { By default, no translation }
JCS_YCCK:
jpeg_set_colorspace(cinfo, JCS_YCCK);
JCS_UNKNOWN:
jpeg_set_colorspace(cinfo, JCS_UNKNOWN);
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
end;
end;
{ Set the JPEG colorspace, and choose colorspace-dependent default values. }
{GLOBAL}
procedure jpeg_set_colorspace (cinfo : j_compress_ptr;
colorspace : J_COLOR_SPACE);
{ macro }
procedure SET_COMP(index,id,hsamp,vsamp,quant,dctbl,actbl : int);
begin
with cinfo^.comp_info^[index] do
begin
component_id := (id);
h_samp_factor := (hsamp);
v_samp_factor := (vsamp);
quant_tbl_no := (quant);
dc_tbl_no := (dctbl);
ac_tbl_no := (actbl);
end;
end;
var
ci : int;
begin
{ Safety check to ensure start_compress not called yet. }
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ For all colorspaces, we use Q and Huff tables 0 for luminance components,
tables 1 for chrominance components. }
cinfo^.jpeg_color_space := colorspace;
cinfo^.write_JFIF_header := FALSE; { No marker for non-JFIF colorspaces }
cinfo^.write_Adobe_marker := FALSE; { write no Adobe marker by default }
case (colorspace) of
JCS_GRAYSCALE:
begin
cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker }
cinfo^.num_components := 1;
{ JFIF specifies component ID 1 }
SET_COMP(0, 1, 1,1, 0, 0,0);
end;
JCS_RGB:
begin
cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag RGB }
cinfo^.num_components := 3;
SET_COMP(0, $52 { 'R' }, 1,1, 0, 0,0);
SET_COMP(1, $47 { 'G' }, 1,1, 0, 0,0);
SET_COMP(2, $42 { 'B' }, 1,1, 0, 0,0);
end;
JCS_YCbCr:
begin
cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker }
cinfo^.num_components := 3;
{ JFIF specifies component IDs 1,2,3 }
{ We default to 2x2 subsamples of chrominance }
SET_COMP(0, 1, 2,2, 0, 0,0);
SET_COMP(1, 2, 1,1, 1, 1,1);
SET_COMP(2, 3, 1,1, 1, 1,1);
end;
JCS_CMYK:
begin
cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag CMYK }
cinfo^.num_components := 4;
SET_COMP(0, $43 { 'C' }, 1,1, 0, 0,0);
SET_COMP(1, $4D { 'M' }, 1,1, 0, 0,0);
SET_COMP(2, $59 { 'Y' }, 1,1, 0, 0,0);
SET_COMP(3, $4B { 'K' }, 1,1, 0, 0,0);
end;
JCS_YCCK:
begin
cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag YCCK }
cinfo^.num_components := 4;
SET_COMP(0, 1, 2,2, 0, 0,0);
SET_COMP(1, 2, 1,1, 1, 1,1);
SET_COMP(2, 3, 1,1, 1, 1,1);
SET_COMP(3, 4, 2,2, 0, 0,0);
end;
JCS_UNKNOWN:
begin
cinfo^.num_components := cinfo^.input_components;
if (cinfo^.num_components < 1)
or (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT,
cinfo^.num_components, MAX_COMPONENTS);
for ci := 0 to pred(cinfo^.num_components) do
begin
SET_COMP(ci, ci, 1,1, 0, 0,0);
end;
end;
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
end;
end;
{$ifdef C_PROGRESSIVE_SUPPORTED}
{LOCAL}
function fill_a_scan (scanptr : jpeg_scan_info_ptr;
ci : int; Ss : int;
Se : int; Ah : int;
Al : int) : jpeg_scan_info_ptr;
{ Support routine: generate one scan for specified component }
begin
scanptr^.comps_in_scan := 1;
scanptr^.component_index[0] := ci;
scanptr^.Ss := Ss;
scanptr^.Se := Se;
scanptr^.Ah := Ah;
scanptr^.Al := Al;
Inc(scanptr);
fill_a_scan := scanptr;
end;
{LOCAL}
function fill_scans (scanptr : jpeg_scan_info_ptr;
ncomps : int;
Ss : int; Se : int;
Ah : int; Al : int) : jpeg_scan_info_ptr;
{ Support routine: generate one scan for each component }
var
ci : int;
begin
for ci := 0 to pred(ncomps) do
begin
scanptr^.comps_in_scan := 1;
scanptr^.component_index[0] := ci;
scanptr^.Ss := Ss;
scanptr^.Se := Se;
scanptr^.Ah := Ah;
scanptr^.Al := Al;
Inc(scanptr);
end;
fill_scans := scanptr;
end;
{LOCAL}
function fill_dc_scans (scanptr : jpeg_scan_info_ptr;
ncomps : int;
Ah : int; Al : int) : jpeg_scan_info_ptr;
{ Support routine: generate interleaved DC scan if possible, else N scans }
var
ci : int;
begin
if (ncomps <= MAX_COMPS_IN_SCAN) then
begin
{ Single interleaved DC scan }
scanptr^.comps_in_scan := ncomps;
for ci := 0 to pred(ncomps) do
scanptr^.component_index[ci] := ci;
scanptr^.Ss := 0;
scanptr^.Se := 0;
scanptr^.Ah := Ah;
scanptr^.Al := Al;
Inc(scanptr);
end
else
begin
{ Noninterleaved DC scan for each component }
scanptr := fill_scans(scanptr, ncomps, 0, 0, Ah, Al);
end;
fill_dc_scans := scanptr;
end;
{ Create a recommended progressive-JPEG script.
cinfo^.num_components and cinfo^.jpeg_color_space must be correct. }
{GLOBAL}
procedure jpeg_simple_progression (cinfo : j_compress_ptr);
var
ncomps : int;
nscans : int;
scanptr : jpeg_scan_info_ptr;
begin
ncomps := cinfo^.num_components;
{ Safety check to ensure start_compress not called yet. }
if (cinfo^.global_state <> CSTATE_START) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Figure space needed for script. Calculation must match code below! }
if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then
begin
{ Custom script for YCbCr color images. }
nscans := 10;
end
else
begin
{ All-purpose script for other color spaces. }
if (ncomps > MAX_COMPS_IN_SCAN) then
nscans := 6 * ncomps { 2 DC + 4 AC scans per component }
else
nscans := 2 + 4 * ncomps; { 2 DC scans; 4 AC scans per component }
end;
{ Allocate space for script.
We need to put it in the permanent pool in case the application performs
multiple compressions without changing the settings. To avoid a memory
leak if jpeg_simple_progression is called repeatedly for the same JPEG
object, we try to re-use previously allocated space, and we allocate
enough space to handle YCbCr even if initially asked for grayscale. }
if (cinfo^.script_space = NIL) or (cinfo^.script_space_size < nscans) then
begin
if nscans > 10 then
cinfo^.script_space_size := nscans
else
cinfo^.script_space_size := 10;
cinfo^.script_space := jpeg_scan_info_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
cinfo^.script_space_size * SIZEOF(jpeg_scan_info)) );
end;
scanptr := cinfo^.script_space;
cinfo^.scan_info := scanptr;
cinfo^.num_scans := nscans;
if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then
begin
{ Custom script for YCbCr color images. }
{ Initial DC scan }
scanptr := fill_dc_scans(scanptr, ncomps, 0, 1);
{ Initial AC scan: get some luma data out in a hurry }
scanptr := fill_a_scan(scanptr, 0, 1, 5, 0, 2);
{ Chroma data is too small to be worth expending many scans on }
scanptr := fill_a_scan(scanptr, 2, 1, 63, 0, 1);
scanptr := fill_a_scan(scanptr, 1, 1, 63, 0, 1);
{ Complete spectral selection for luma AC }
scanptr := fill_a_scan(scanptr, 0, 6, 63, 0, 2);
{ Refine next bit of luma AC }
scanptr := fill_a_scan(scanptr, 0, 1, 63, 2, 1);
{ Finish DC successive approximation }
scanptr := fill_dc_scans(scanptr, ncomps, 1, 0);
{ Finish AC successive approximation }
scanptr := fill_a_scan(scanptr, 2, 1, 63, 1, 0);
scanptr := fill_a_scan(scanptr, 1, 1, 63, 1, 0);
{ Luma bottom bit comes last since it's usually largest scan }
scanptr := fill_a_scan(scanptr, 0, 1, 63, 1, 0);
end
else
begin
{ All-purpose script for other color spaces. }
{ Successive approximation first pass }
scanptr := fill_dc_scans(scanptr, ncomps, 0, 1);
scanptr := fill_scans(scanptr, ncomps, 1, 5, 0, 2);
scanptr := fill_scans(scanptr, ncomps, 6, 63, 0, 2);
{ Successive approximation second pass }
scanptr := fill_scans(scanptr, ncomps, 1, 63, 2, 1);
{ Successive approximation final pass }
scanptr := fill_dc_scans(scanptr, ncomps, 1, 0);
scanptr := fill_scans(scanptr, ncomps, 1, 63, 1, 0);
end;
end;
{$endif}
end.

962
Imaging/JpegLib/imjcphuff.pas Normal file
View File

@@ -0,0 +1,962 @@
unit imjcphuff;
{ This file contains Huffman entropy encoding routines for progressive JPEG.
We do not support output suspension in this module, since the library
currently does not allow multiple-scan files to be written with output
suspension. }
{ Original: jcphuff.c; Copyright (C) 1995-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdeferr,
imjerror,
imjutils,
imjcomapi,
imjchuff; { Declarations shared with jchuff.c }
{ Module initialization routine for progressive Huffman entropy encoding. }
{GLOBAL}
procedure jinit_phuff_encoder (cinfo : j_compress_ptr);
implementation
{ Expanded entropy encoder object for progressive Huffman encoding. }
type
phuff_entropy_ptr = ^phuff_entropy_encoder;
phuff_entropy_encoder = record
pub : jpeg_entropy_encoder; { public fields }
{ Mode flag: TRUE for optimization, FALSE for actual data output }
gather_statistics : boolean;
{ Bit-level coding status.
next_output_byte/free_in_buffer are local copies of cinfo^.dest fields.}
next_output_byte : JOCTETptr; { => next byte to write in buffer }
free_in_buffer : size_t; { # of byte spaces remaining in buffer }
put_buffer : INT32; { current bit-accumulation buffer }
put_bits : int; { # of bits now in it }
cinfo : j_compress_ptr; { link to cinfo (needed for dump_buffer) }
{ Coding status for DC components }
last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int;
{ last DC coef for each component }
{ Coding status for AC components }
ac_tbl_no : int; { the table number of the single component }
EOBRUN : uInt; { run length of EOBs }
BE : uInt; { # of buffered correction bits before MCU }
bit_buffer : JBytePtr; { buffer for correction bits (1 per char) }
{ packing correction bits tightly would save some space but cost time... }
restarts_to_go : uInt; { MCUs left in this restart interval }
next_restart_num : int; { next restart number to write (0-7) }
{ Pointers to derived tables (these workspaces have image lifespan).
Since any one scan codes only DC or only AC, we only need one set
of tables, not one for DC and one for AC. }
derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr;
{ Statistics tables for optimization; again, one set is enough }
count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr;
end;
{ MAX_CORR_BITS is the number of bits the AC refinement correction-bit
buffer can hold. Larger sizes may slightly improve compression, but
1000 is already well into the realm of overkill.
The minimum safe size is 64 bits. }
const
MAX_CORR_BITS = 1000; { Max # of correction bits I can buffer }
{ Forward declarations }
{METHODDEF}
function encode_mcu_DC_first (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
forward;
{METHODDEF}
function encode_mcu_AC_first (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
forward;
{METHODDEF}
function encode_mcu_DC_refine (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
forward;
{METHODDEF}
function encode_mcu_AC_refine (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
forward;
{METHODDEF}
procedure finish_pass_phuff (cinfo : j_compress_ptr); forward;
{METHODDEF}
procedure finish_pass_gather_phuff (cinfo : j_compress_ptr); forward;
{ Initialize for a Huffman-compressed scan using progressive JPEG. }
{METHODDEF}
procedure start_pass_phuff (cinfo : j_compress_ptr;
gather_statistics : boolean);
var
entropy : phuff_entropy_ptr;
is_DC_band : boolean;
ci, tbl : int;
compptr : jpeg_component_info_ptr;
begin
tbl := 0;
entropy := phuff_entropy_ptr (cinfo^.entropy);
entropy^.cinfo := cinfo;
entropy^.gather_statistics := gather_statistics;
is_DC_band := (cinfo^.Ss = 0);
{ We assume jcmaster.c already validated the scan parameters. }
{ Select execution routines }
if (cinfo^.Ah = 0) then
begin
if (is_DC_band) then
entropy^.pub.encode_mcu := encode_mcu_DC_first
else
entropy^.pub.encode_mcu := encode_mcu_AC_first;
end
else
begin
if (is_DC_band) then
entropy^.pub.encode_mcu := encode_mcu_DC_refine
else
begin
entropy^.pub.encode_mcu := encode_mcu_AC_refine;
{ AC refinement needs a correction bit buffer }
if (entropy^.bit_buffer = NIL) then
entropy^.bit_buffer := JBytePtr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
MAX_CORR_BITS * SIZEOF(byte)) );
end;
end;
if (gather_statistics) then
entropy^.pub.finish_pass := finish_pass_gather_phuff
else
entropy^.pub.finish_pass := finish_pass_phuff;
{ Only DC coefficients may be interleaved, so cinfo^.comps_in_scan = 1
for AC coefficients. }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Initialize DC predictions to 0 }
entropy^.last_dc_val[ci] := 0;
{ Get table index }
if (is_DC_band) then
begin
if (cinfo^.Ah <> 0) then { DC refinement needs no table }
continue;
tbl := compptr^.dc_tbl_no;
end
else
begin
tbl := compptr^.ac_tbl_no;
entropy^.ac_tbl_no := tbl;
end;
if (gather_statistics) then
begin
{ Check for invalid table index }
{ (make_c_derived_tbl does this in the other path) }
if (tbl < 0) or (tbl >= NUM_HUFF_TBLS) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tbl);
{ Allocate and zero the statistics tables }
{ Note that jpeg_gen_optimal_table expects 257 entries in each table! }
if (entropy^.count_ptrs[tbl] = NIL) then
entropy^.count_ptrs[tbl] := TLongTablePtr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
257 * SIZEOF(long)) );
MEMZERO(entropy^.count_ptrs[tbl], 257 * SIZEOF(long));
end else
begin
{ Compute derived values for Huffman table }
{ We may do this more than once for a table, but it's not expensive }
jpeg_make_c_derived_tbl(cinfo, is_DC_band, tbl,
entropy^.derived_tbls[tbl]);
end;
end;
{ Initialize AC stuff }
entropy^.EOBRUN := 0;
entropy^.BE := 0;
{ Initialize bit buffer to empty }
entropy^.put_buffer := 0;
entropy^.put_bits := 0;
{ Initialize restart stuff }
entropy^.restarts_to_go := cinfo^.restart_interval;
entropy^.next_restart_num := 0;
end;
{LOCAL}
procedure dump_buffer (entropy : phuff_entropy_ptr);
{ Empty the output buffer; we do not support suspension in this module. }
var
dest : jpeg_destination_mgr_ptr;
begin
dest := entropy^.cinfo^.dest;
if (not dest^.empty_output_buffer (entropy^.cinfo)) then
ERREXIT(j_common_ptr(entropy^.cinfo), JERR_CANT_SUSPEND);
{ After a successful buffer dump, must reset buffer pointers }
entropy^.next_output_byte := dest^.next_output_byte;
entropy^.free_in_buffer := dest^.free_in_buffer;
end;
{ Outputting bits to the file }
{ Only the right 24 bits of put_buffer are used; the valid bits are
left-justified in this part. At most 16 bits can be passed to emit_bits
in one call, and we never retain more than 7 bits in put_buffer
between calls, so 24 bits are sufficient. }
{LOCAL}
procedure emit_bits (entropy : phuff_entropy_ptr;
code : uInt;
size : int); {INLINE}
{ Emit some bits, unless we are in gather mode }
var
{register} put_buffer : INT32;
{register} put_bits : int;
var
c : int;
begin
{ This routine is heavily used, so it's worth coding tightly. }
put_buffer := INT32 (code);
put_bits := entropy^.put_bits;
{ if size is 0, caller used an invalid Huffman table entry }
if (size = 0) then
ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE);
if (entropy^.gather_statistics) then
exit; { do nothing if we're only getting stats }
put_buffer := put_buffer and ((INT32(1) shl size) - 1);
{ mask off any extra bits in code }
Inc(put_bits, size); { new number of bits in buffer }
put_buffer := put_buffer shl (24 - put_bits); { align incoming bits }
put_buffer := put_buffer or entropy^.put_buffer;
{ and merge with old buffer contents }
while (put_bits >= 8) do
begin
c := int ((put_buffer shr 16) and $FF);
{emit_byte(entropy, c);}
{ Outputting bytes to the file.
NB: these must be called only when actually outputting,
that is, entropy^.gather_statistics = FALSE. }
{ Emit a byte }
entropy^.next_output_byte^ := JOCTET(c);
Inc(entropy^.next_output_byte);
Dec(entropy^.free_in_buffer);
if (entropy^.free_in_buffer = 0) then
dump_buffer(entropy);
if (c = $FF) then
begin { need to stuff a zero byte? }
{emit_byte(entropy, 0);}
entropy^.next_output_byte^ := JOCTET(0);
Inc(entropy^.next_output_byte);
Dec(entropy^.free_in_buffer);
if (entropy^.free_in_buffer = 0) then
dump_buffer(entropy);
end;
put_buffer := put_buffer shl 8;
Dec(put_bits, 8);
end;
entropy^.put_buffer := put_buffer; { update variables }
entropy^.put_bits := put_bits;
end;
{LOCAL}
procedure flush_bits (entropy : phuff_entropy_ptr);
begin
emit_bits(entropy, $7F, 7); { fill any partial byte with ones }
entropy^.put_buffer := 0; { and reset bit-buffer to empty }
entropy^.put_bits := 0;
end;
{ Emit (or just count) a Huffman symbol. }
{LOCAL}
procedure emit_symbol (entropy : phuff_entropy_ptr;
tbl_no : int;
symbol : int); {INLINE}
var
tbl : c_derived_tbl_ptr;
begin
if (entropy^.gather_statistics) then
Inc(entropy^.count_ptrs[tbl_no]^[symbol])
else
begin
tbl := entropy^.derived_tbls[tbl_no];
emit_bits(entropy, tbl^.ehufco[symbol], tbl^.ehufsi[symbol]);
end;
end;
{ Emit bits from a correction bit buffer. }
{LOCAL}
procedure emit_buffered_bits (entropy : phuff_entropy_ptr;
bufstart : JBytePtr;
nbits : uInt);
var
bufptr : byteptr;
begin
if (entropy^.gather_statistics) then
exit; { no real work }
bufptr := byteptr(bufstart);
while (nbits > 0) do
begin
emit_bits(entropy, uInt(bufptr^), 1);
Inc(bufptr);
Dec(nbits);
end;
end;
{ Emit any pending EOBRUN symbol. }
{LOCAL}
procedure emit_eobrun (entropy : phuff_entropy_ptr);
var
{register} temp, nbits : int;
begin
if (entropy^.EOBRUN > 0) then
begin { if there is any pending EOBRUN }
temp := entropy^.EOBRUN;
nbits := 0;
temp := temp shr 1;
while (temp <> 0) do
begin
Inc(nbits);
temp := temp shr 1;
end;
{ safety check: shouldn't happen given limited correction-bit buffer }
if (nbits > 14) then
ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE);
emit_symbol(entropy, entropy^.ac_tbl_no, nbits shl 4);
if (nbits <> 0) then
emit_bits(entropy, entropy^.EOBRUN, nbits);
entropy^.EOBRUN := 0;
{ Emit any buffered correction bits }
emit_buffered_bits(entropy, entropy^.bit_buffer, entropy^.BE);
entropy^.BE := 0;
end;
end;
{ Emit a restart marker & resynchronize predictions. }
{LOCAL}
procedure emit_restart (entropy : phuff_entropy_ptr;
restart_num : int);
var
ci : int;
begin
emit_eobrun(entropy);
if (not entropy^.gather_statistics) then
begin
flush_bits(entropy);
{emit_byte(entropy, $FF);}
{ Outputting bytes to the file.
NB: these must be called only when actually outputting,
that is, entropy^.gather_statistics = FALSE. }
entropy^.next_output_byte^ := JOCTET($FF);
Inc(entropy^.next_output_byte);
Dec(entropy^.free_in_buffer);
if (entropy^.free_in_buffer = 0) then
dump_buffer(entropy);
{emit_byte(entropy, JPEG_RST0 + restart_num);}
entropy^.next_output_byte^ := JOCTET(JPEG_RST0 + restart_num);
Inc(entropy^.next_output_byte);
Dec(entropy^.free_in_buffer);
if (entropy^.free_in_buffer = 0) then
dump_buffer(entropy);
end;
if (entropy^.cinfo^.Ss = 0) then
begin
{ Re-initialize DC predictions to 0 }
for ci := 0 to pred(entropy^.cinfo^.comps_in_scan) do
entropy^.last_dc_val[ci] := 0;
end
else
begin
{ Re-initialize all AC-related fields to 0 }
entropy^.EOBRUN := 0;
entropy^.BE := 0;
end;
end;
{ MCU encoding for DC initial scan (either spectral selection,
or first pass of successive approximation). }
{METHODDEF}
function encode_mcu_DC_first (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
var
entropy : phuff_entropy_ptr;
{register} temp, temp2 : int;
{register} nbits : int;
blkn, ci : int;
Al : int;
block : JBLOCK_PTR;
compptr : jpeg_component_info_ptr;
ishift_temp : int;
begin
entropy := phuff_entropy_ptr (cinfo^.entropy);
Al := cinfo^.Al;
entropy^.next_output_byte := cinfo^.dest^.next_output_byte;
entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer;
{ Emit restart marker if needed }
if (cinfo^.restart_interval <> 0) then
if (entropy^.restarts_to_go = 0) then
emit_restart(entropy, entropy^.next_restart_num);
{ Encode the MCU data blocks }
for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
begin
block := JBLOCK_PTR(MCU_data[blkn]);
ci := cinfo^.MCU_membership[blkn];
compptr := cinfo^.cur_comp_info[ci];
{ Compute the DC value after the required point transform by Al.
This is simply an arithmetic right shift. }
{temp2 := IRIGHT_SHIFT( int(block^[0]), Al);}
{IRIGHT_SHIFT_IS_UNSIGNED}
ishift_temp := int(block^[0]);
if ishift_temp < 0 then
temp2 := (ishift_temp shr Al) or ((not 0) shl (16-Al))
else
temp2 := ishift_temp shr Al;
{ DC differences are figured on the point-transformed values. }
temp := temp2 - entropy^.last_dc_val[ci];
entropy^.last_dc_val[ci] := temp2;
{ Encode the DC coefficient difference per section G.1.2.1 }
temp2 := temp;
if (temp < 0) then
begin
temp := -temp; { temp is abs value of input }
{ For a negative input, want temp2 := bitwise complement of abs(input) }
{ This code assumes we are on a two's complement machine }
Dec(temp2);
end;
{ Find the number of bits needed for the magnitude of the coefficient }
nbits := 0;
while (temp <> 0) do
begin
Inc(nbits);
temp := temp shr 1;
end;
{ Check for out-of-range coefficient values.
Since we're encoding a difference, the range limit is twice as much. }
if (nbits > MAX_COEF_BITS+1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF);
{ Count/emit the Huffman-coded symbol for the number of bits }
emit_symbol(entropy, compptr^.dc_tbl_no, nbits);
{ Emit that number of bits of the value, if positive, }
{ or the complement of its magnitude, if negative. }
if (nbits <> 0) then { emit_bits rejects calls with size 0 }
emit_bits(entropy, uInt(temp2), nbits);
end;
cinfo^.dest^.next_output_byte := entropy^.next_output_byte;
cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer;
{ Update restart-interval state too }
if (cinfo^.restart_interval <> 0) then
begin
if (entropy^.restarts_to_go = 0) then
begin
entropy^.restarts_to_go := cinfo^.restart_interval;
Inc(entropy^.next_restart_num);
with entropy^ do
next_restart_num := next_restart_num and 7;
end;
Dec(entropy^.restarts_to_go);
end;
encode_mcu_DC_first := TRUE;
end;
{ MCU encoding for AC initial scan (either spectral selection,
or first pass of successive approximation). }
{METHODDEF}
function encode_mcu_AC_first (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
var
entropy : phuff_entropy_ptr;
{register} temp, temp2 : int;
{register} nbits : int;
{register} r, k : int;
Se : int;
Al : int;
block : JBLOCK_PTR;
begin
entropy := phuff_entropy_ptr (cinfo^.entropy);
Se := cinfo^.Se;
Al := cinfo^.Al;
entropy^.next_output_byte := cinfo^.dest^.next_output_byte;
entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer;
{ Emit restart marker if needed }
if (cinfo^.restart_interval <> 0) then
if (entropy^.restarts_to_go = 0) then
emit_restart(entropy, entropy^.next_restart_num);
{ Encode the MCU data block }
block := JBLOCK_PTR(MCU_data[0]);
{ Encode the AC coefficients per section G.1.2.2, fig. G.3 }
r := 0; { r := run length of zeros }
for k := cinfo^.Ss to Se do
begin
temp := (block^[jpeg_natural_order[k]]);
if (temp = 0) then
begin
Inc(r);
continue;
end;
{ We must apply the point transform by Al. For AC coefficients this
is an integer division with rounding towards 0. To do this portably
in C, we shift after obtaining the absolute value; so the code is
interwoven with finding the abs value (temp) and output bits (temp2). }
if (temp < 0) then
begin
temp := -temp; { temp is abs value of input }
temp := temp shr Al; { apply the point transform }
{ For a negative coef, want temp2 := bitwise complement of abs(coef) }
temp2 := not temp;
end
else
begin
temp := temp shr Al; { apply the point transform }
temp2 := temp;
end;
{ Watch out for case that nonzero coef is zero after point transform }
if (temp = 0) then
begin
Inc(r);
continue;
end;
{ Emit any pending EOBRUN }
if (entropy^.EOBRUN > 0) then
emit_eobrun(entropy);
{ if run length > 15, must emit special run-length-16 codes ($F0) }
while (r > 15) do
begin
emit_symbol(entropy, entropy^.ac_tbl_no, $F0);
Dec(r, 16);
end;
{ Find the number of bits needed for the magnitude of the coefficient }
nbits := 0; { there must be at least one 1 bit }
repeat
Inc(nbits);
temp := temp shr 1;
until (temp = 0);
{ Check for out-of-range coefficient values }
if (nbits > MAX_COEF_BITS) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF);
{ Count/emit Huffman symbol for run length / number of bits }
emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + nbits);
{ Emit that number of bits of the value, if positive, }
{ or the complement of its magnitude, if negative. }
emit_bits(entropy, uInt(temp2), nbits);
r := 0; { reset zero run length }
end;
if (r > 0) then
begin { If there are trailing zeroes, }
Inc(entropy^.EOBRUN); { count an EOB }
if (entropy^.EOBRUN = $7FFF) then
emit_eobrun(entropy); { force it out to avoid overflow }
end;
cinfo^.dest^.next_output_byte := entropy^.next_output_byte;
cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer;
{ Update restart-interval state too }
if (cinfo^.restart_interval <> 0) then
begin
if (entropy^.restarts_to_go = 0) then
begin
entropy^.restarts_to_go := cinfo^.restart_interval;
Inc(entropy^.next_restart_num);
with entropy^ do
next_restart_num := next_restart_num and 7;
end;
Dec(entropy^.restarts_to_go);
end;
encode_mcu_AC_first := TRUE;
end;
{ MCU encoding for DC successive approximation refinement scan.
Note: we assume such scans can be multi-component, although the spec
is not very clear on the point. }
{METHODDEF}
function encode_mcu_DC_refine (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
var
entropy : phuff_entropy_ptr;
{register} temp : int;
blkn : int;
Al : int;
block : JBLOCK_PTR;
begin
entropy := phuff_entropy_ptr (cinfo^.entropy);
Al := cinfo^.Al;
entropy^.next_output_byte := cinfo^.dest^.next_output_byte;
entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer;
{ Emit restart marker if needed }
if (cinfo^.restart_interval <> 0) then
if (entropy^.restarts_to_go = 0) then
emit_restart(entropy, entropy^.next_restart_num);
{ Encode the MCU data blocks }
for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
begin
block := JBLOCK_PTR(MCU_data[blkn]);
{ We simply emit the Al'th bit of the DC coefficient value. }
temp := block^[0];
emit_bits(entropy, uInt(temp shr Al), 1);
end;
cinfo^.dest^.next_output_byte := entropy^.next_output_byte;
cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer;
{ Update restart-interval state too }
if (cinfo^.restart_interval <> 0) then
begin
if (entropy^.restarts_to_go = 0) then
begin
entropy^.restarts_to_go := cinfo^.restart_interval;
Inc(entropy^.next_restart_num);
with entropy^ do
next_restart_num := next_restart_num and 7;
end;
Dec(entropy^.restarts_to_go);
end;
encode_mcu_DC_refine := TRUE;
end;
{ MCU encoding for AC successive approximation refinement scan. }
{METHODDEF}
function encode_mcu_AC_refine (cinfo : j_compress_ptr;
const MCU_data: array of JBLOCKROW) : boolean;
var
entropy : phuff_entropy_ptr;
{register} temp : int;
{register} r, k : int;
EOB : int;
BR_buffer : JBytePtr;
BR : uInt;
Se : int;
Al : int;
block : JBLOCK_PTR;
absvalues : array[0..DCTSIZE2-1] of int;
begin
entropy := phuff_entropy_ptr(cinfo^.entropy);
Se := cinfo^.Se;
Al := cinfo^.Al;
entropy^.next_output_byte := cinfo^.dest^.next_output_byte;
entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer;
{ Emit restart marker if needed }
if (cinfo^.restart_interval <> 0) then
if (entropy^.restarts_to_go = 0) then
emit_restart(entropy, entropy^.next_restart_num);
{ Encode the MCU data block }
block := JBLOCK_PTR(MCU_data[0]);
{ It is convenient to make a pre-pass to determine the transformed
coefficients' absolute values and the EOB position. }
EOB := 0;
for k := cinfo^.Ss to Se do
begin
temp := block^[jpeg_natural_order[k]];
{ We must apply the point transform by Al. For AC coefficients this
is an integer division with rounding towards 0. To do this portably
in C, we shift after obtaining the absolute value. }
if (temp < 0) then
temp := -temp; { temp is abs value of input }
temp := temp shr Al; { apply the point transform }
absvalues[k] := temp; { save abs value for main pass }
if (temp = 1) then
EOB := k; { EOB := index of last newly-nonzero coef }
end;
{ Encode the AC coefficients per section G.1.2.3, fig. G.7 }
r := 0; { r := run length of zeros }
BR := 0; { BR := count of buffered bits added now }
BR_buffer := JBytePtr(@(entropy^.bit_buffer^[entropy^.BE]));
{ Append bits to buffer }
for k := cinfo^.Ss to Se do
begin
temp := absvalues[k];
if (temp = 0) then
begin
Inc(r);
continue;
end;
{ Emit any required ZRLs, but not if they can be folded into EOB }
while (r > 15) and (k <= EOB) do
begin
{ emit any pending EOBRUN and the BE correction bits }
emit_eobrun(entropy);
{ Emit ZRL }
emit_symbol(entropy, entropy^.ac_tbl_no, $F0);
Dec(r, 16);
{ Emit buffered correction bits that must be associated with ZRL }
emit_buffered_bits(entropy, BR_buffer, BR);
BR_buffer := entropy^.bit_buffer; { BE bits are gone now }
BR := 0;
end;
{ If the coef was previously nonzero, it only needs a correction bit.
NOTE: a straight translation of the spec's figure G.7 would suggest
that we also need to test r > 15. But if r > 15, we can only get here
if k > EOB, which implies that this coefficient is not 1. }
if (temp > 1) then
begin
{ The correction bit is the next bit of the absolute value. }
BR_buffer^[BR] := byte (temp and 1);
Inc(BR);
continue;
end;
{ Emit any pending EOBRUN and the BE correction bits }
emit_eobrun(entropy);
{ Count/emit Huffman symbol for run length / number of bits }
emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + 1);
{ Emit output bit for newly-nonzero coef }
if (block^[jpeg_natural_order[k]] < 0) then
temp := 0
else
temp := 1;
emit_bits(entropy, uInt(temp), 1);
{ Emit buffered correction bits that must be associated with this code }
emit_buffered_bits(entropy, BR_buffer, BR);
BR_buffer := entropy^.bit_buffer; { BE bits are gone now }
BR := 0;
r := 0; { reset zero run length }
end;
if (r > 0) or (BR > 0) then
begin { If there are trailing zeroes, }
Inc(entropy^.EOBRUN); { count an EOB }
Inc(entropy^.BE, BR); { concat my correction bits to older ones }
{ We force out the EOB if we risk either:
1. overflow of the EOB counter;
2. overflow of the correction bit buffer during the next MCU. }
if (entropy^.EOBRUN = $7FFF) or
(entropy^.BE > (MAX_CORR_BITS-DCTSIZE2+1)) then
emit_eobrun(entropy);
end;
cinfo^.dest^.next_output_byte := entropy^.next_output_byte;
cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer;
{ Update restart-interval state too }
if (cinfo^.restart_interval <> 0) then
begin
if (entropy^.restarts_to_go = 0) then
begin
entropy^.restarts_to_go := cinfo^.restart_interval;
Inc(entropy^.next_restart_num);
with entropy^ do
next_restart_num := next_restart_num and 7;
end;
Dec(entropy^.restarts_to_go);
end;
encode_mcu_AC_refine := TRUE;
end;
{ Finish up at the end of a Huffman-compressed progressive scan. }
{METHODDEF}
procedure finish_pass_phuff (cinfo : j_compress_ptr);
var
entropy : phuff_entropy_ptr;
begin
entropy := phuff_entropy_ptr (cinfo^.entropy);
entropy^.next_output_byte := cinfo^.dest^.next_output_byte;
entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer;
{ Flush out any buffered data }
emit_eobrun(entropy);
flush_bits(entropy);
cinfo^.dest^.next_output_byte := entropy^.next_output_byte;
cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer;
end;
{ Finish up a statistics-gathering pass and create the new Huffman tables. }
{METHODDEF}
procedure finish_pass_gather_phuff (cinfo : j_compress_ptr);
var
entropy : phuff_entropy_ptr;
is_DC_band : boolean;
ci, tbl : int;
compptr : jpeg_component_info_ptr;
htblptr : ^JHUFF_TBL_PTR;
did : array[0..NUM_HUFF_TBLS-1] of boolean;
begin
tbl := 0;
entropy := phuff_entropy_ptr (cinfo^.entropy);
{ Flush out buffered data (all we care about is counting the EOB symbol) }
emit_eobrun(entropy);
is_DC_band := (cinfo^.Ss = 0);
{ It's important not to apply jpeg_gen_optimal_table more than once
per table, because it clobbers the input frequency counts! }
MEMZERO(@did, SIZEOF(did));
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
if (is_DC_band) then
begin
if (cinfo^.Ah <> 0) then { DC refinement needs no table }
continue;
tbl := compptr^.dc_tbl_no;
end
else
begin
tbl := compptr^.ac_tbl_no;
end;
if (not did[tbl]) then
begin
if (is_DC_band) then
htblptr := @(cinfo^.dc_huff_tbl_ptrs[tbl])
else
htblptr := @(cinfo^.ac_huff_tbl_ptrs[tbl]);
if (htblptr^ = NIL) then
htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo));
jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.count_ptrs[tbl]^);
did[tbl] := TRUE;
end;
end;
end;
{ Module initialization routine for progressive Huffman entropy encoding. }
{GLOBAL}
procedure jinit_phuff_encoder (cinfo : j_compress_ptr);
var
entropy : phuff_entropy_ptr;
i : int;
begin
entropy := phuff_entropy_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(phuff_entropy_encoder)) );
cinfo^.entropy := jpeg_entropy_encoder_ptr(entropy);
entropy^.pub.start_pass := start_pass_phuff;
{ Mark tables unallocated }
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
entropy^.derived_tbls[i] := NIL;
entropy^.count_ptrs[i] := NIL;
end;
entropy^.bit_buffer := NIL; { needed only in AC refinement scan }
end;
end.

406
Imaging/JpegLib/imjcprepct.pas Normal file
View File

@@ -0,0 +1,406 @@
unit imjcprepct;
{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the compression preprocessing controller.
This controller manages the color conversion, downsampling,
and edge expansion steps.
Most of the complexity here is associated with buffering input rows
as required by the downsampler. See the comments at the head of
jcsample.c for the downsampler's needs. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude,
imjutils;
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
implementation
{ At present, jcsample.c can request context rows only for smoothing.
In the future, we might also need context rows for CCIR601 sampling
or other more-complex downsampling procedures. The code to support
context rows should be compiled only if needed. }
{$ifdef INPUT_SMOOTHING_SUPPORTED}
{$define CONTEXT_ROWS_SUPPORTED}
{$endif}
{ For the simple (no-context-row) case, we just need to buffer one
row group's worth of pixels for the downsampling step. At the bottom of
the image, we pad to a full row group by replicating the last pixel row.
The downsampler's last output row is then replicated if needed to pad
out to a full iMCU row.
When providing context rows, we must buffer three row groups' worth of
pixels. Three row groups are physically allocated, but the row pointer
arrays are made five row groups high, with the extra pointers above and
below "wrapping around" to point to the last and first real row groups.
This allows the downsampler to access the proper context rows.
At the top and bottom of the image, we create dummy context rows by
copying the first or last real pixel row. This copying could be avoided
by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the
trouble on the compression side. }
{ Private buffer controller object }
type
my_prep_ptr = ^my_prep_controller;
my_prep_controller = record
pub : jpeg_c_prep_controller; { public fields }
{ Downsampling input buffer. This buffer holds color-converted data
until we have enough to do a downsample step. }
color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
rows_to_go : JDIMENSION; { counts rows remaining in source image }
next_buf_row : int; { index of next row to store in color_buf }
{$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case }
this_row_group : int; { starting row index of group to process }
next_buf_stop : int; { downsample when we reach this index }
{$endif}
end; {my_prep_controller;}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_prep (cinfo : j_compress_ptr;
pass_mode : J_BUF_MODE );
var
prep : my_prep_ptr;
begin
prep := my_prep_ptr (cinfo^.prep);
if (pass_mode <> JBUF_PASS_THRU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{ Initialize total-height counter for detecting bottom of image }
prep^.rows_to_go := cinfo^.image_height;
{ Mark the conversion buffer empty }
prep^.next_buf_row := 0;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Preset additional state variables for context mode.
These aren't used in non-context mode, so we needn't test which mode. }
prep^.this_row_group := 0;
{ Set next_buf_stop to stop after two row groups have been read in. }
prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor;
{$endif}
end;
{ Expand an image vertically from height input_rows to height output_rows,
by duplicating the bottom row. }
{LOCAL}
procedure expand_bottom_edge (image_data : JSAMPARRAY;
num_cols : JDIMENSION;
input_rows : int;
output_rows : int);
var
{register} row : int;
begin
for row := input_rows to pred(output_rows) do
begin
jcopy_sample_rows(image_data, input_rows-1, image_data, row,
1, num_cols);
end;
end;
{ Process some data in the simple no-context case.
Preprocessor output data is counted in "row groups". A row group
is defined to be v_samp_factor sample rows of each component.
Downsampling will produce this much data from each max_v_samp_factor
input rows. }
{METHODDEF}
procedure pre_process_data (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
inrows : JDIMENSION;
compptr : jpeg_component_info_ptr;
var
local_input_buf : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
while (in_row_ctr < in_rows_avail) and
(out_row_group_ctr < out_row_groups_avail) do
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row;
{numrows := int( MIN(JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr]));
cinfo^.cconvert^.color_convert (cinfo, local_input_buf,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.next_buf_row),
numrows);
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
{ If at bottom of image, pad to fill the conversion buffer. }
if (prep^.rows_to_go = 0) and
(prep^.next_buf_row < cinfo^.max_v_samp_factor) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, cinfo^.max_v_samp_factor);
end;
prep^.next_buf_row := cinfo^.max_v_samp_factor;
end;
{ If we've filled the conversion buffer, empty it. }
if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (0),
output_buf,
out_row_group_ctr);
prep^.next_buf_row := 0;
Inc(out_row_group_ctr);;
end;
{ If at bottom of image, pad the output to a full iMCU height.
Note we assume the caller is providing a one-iMCU-height output buffer! }
if (prep^.rows_to_go = 0) and
(out_row_group_ctr < out_row_groups_avail) then
begin
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(output_buf^[ci],
compptr^.width_in_blocks * DCTSIZE,
int (out_row_group_ctr) * compptr^.v_samp_factor,
int (out_row_groups_avail) * compptr^.v_samp_factor);
Inc(compptr);
end;
out_row_group_ctr := out_row_groups_avail;
break; { can exit outer loop without test }
end;
end;
end;
{$ifdef CONTEXT_ROWS_SUPPORTED}
{ Process some data in the context case. }
{METHODDEF}
procedure pre_process_context (cinfo : j_compress_ptr;
input_buf : JSAMPARRAY;
var in_row_ctr : JDIMENSION;
in_rows_avail : JDIMENSION;
output_buf : JSAMPIMAGE;
var out_row_group_ctr : JDIMENSION;
out_row_groups_avail : JDIMENSION);
var
prep : my_prep_ptr;
numrows, ci : int;
buf_height : int;
inrows : JDIMENSION;
var
row : int;
begin
prep := my_prep_ptr (cinfo^.prep);
buf_height := cinfo^.max_v_samp_factor * 3;
while (out_row_group_ctr < out_row_groups_avail) do
begin
if (in_row_ctr < in_rows_avail) then
begin
{ Do color conversion to fill the conversion buffer. }
inrows := in_rows_avail - in_row_ctr;
numrows := prep^.next_buf_stop - prep^.next_buf_row;
{numrows := int ( MIN( JDIMENSION(numrows), inrows) );}
if inrows < JDIMENSION(numrows) then
numrows := int(inrows);
cinfo^.cconvert^.color_convert (cinfo,
JSAMPARRAY(@input_buf^[in_row_ctr]),
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION (prep^.next_buf_row),
numrows);
{ Pad at top of image, if first time through }
if (prep^.rows_to_go = cinfo^.image_height) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
for row := 1 to cinfo^.max_v_samp_factor do
begin
jcopy_sample_rows(prep^.color_buf[ci], 0,
prep^.color_buf[ci], -row,
1, cinfo^.image_width);
end;
end;
end;
Inc(in_row_ctr, numrows);
Inc(prep^.next_buf_row, numrows);
Dec(prep^.rows_to_go, numrows);
end
else
begin
{ Return for more data, unless we are at the bottom of the image. }
if (prep^.rows_to_go <> 0) then
break;
{ When at bottom of image, pad to fill the conversion buffer. }
if (prep^.next_buf_row < prep^.next_buf_stop) then
begin
for ci := 0 to pred(cinfo^.num_components) do
begin
expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width,
prep^.next_buf_row, prep^.next_buf_stop);
end;
prep^.next_buf_row := prep^.next_buf_stop;
end;
end;
{ If we've gotten enough data, downsample a row group. }
if (prep^.next_buf_row = prep^.next_buf_stop) then
begin
cinfo^.downsample^.downsample (cinfo,
JSAMPIMAGE(@prep^.color_buf),
JDIMENSION(prep^.this_row_group),
output_buf,
out_row_group_ctr);
Inc(out_row_group_ctr);
{ Advance pointers with wraparound as necessary. }
Inc(prep^.this_row_group, cinfo^.max_v_samp_factor);
if (prep^.this_row_group >= buf_height) then
prep^.this_row_group := 0;
if (prep^.next_buf_row >= buf_height) then
prep^.next_buf_row := 0;
prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor;
end;
end;
end;
{ Create the wrapped-around downsampling input buffer needed for context mode. }
{LOCAL}
procedure create_context_buffer (cinfo : j_compress_ptr);
var
prep : my_prep_ptr;
rgroup_height : int;
ci, i : int;
compptr : jpeg_component_info_ptr;
true_buffer, fake_buffer : JSAMPARRAY;
begin
prep := my_prep_ptr (cinfo^.prep);
rgroup_height := cinfo^.max_v_samp_factor;
{ Grab enough space for fake row pointers for all the components;
we need five row groups' worth of pointers for each component. }
fake_buffer := JSAMPARRAY(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(cinfo^.num_components * 5 * rgroup_height) *
SIZEOF(JSAMPROW)) );
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate the actual buffer space (3 row groups) for this component.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
true_buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION (3 * rgroup_height));
{ Copy true buffer row pointers into the middle of the fake row array }
MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer,
3 * rgroup_height * SIZEOF(JSAMPROW));
{ Fill in the above and below wraparound pointers }
for i := 0 to pred(rgroup_height) do
begin
fake_buffer^[i] := true_buffer^[2 * rgroup_height + i];
fake_buffer^[4 * rgroup_height + i] := true_buffer^[i];
end;
prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]);
Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component }
Inc(compptr);
end;
end;
{$endif} { CONTEXT_ROWS_SUPPORTED }
{ Initialize preprocessing controller. }
{GLOBAL}
procedure jinit_c_prep_controller (cinfo : j_compress_ptr;
need_full_buffer : boolean);
var
prep : my_prep_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
if (need_full_buffer) then { safety check }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
prep := my_prep_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_prep_controller)) );
cinfo^.prep := jpeg_c_prep_controller_ptr(prep);
prep^.pub.start_pass := start_pass_prep;
{ Allocate the color conversion buffer.
We make the buffer wide enough to allow the downsampler to edge-expand
horizontally within the buffer, if it so chooses. }
if (cinfo^.downsample^.need_context_rows) then
begin
{ Set up to provide context rows }
{$ifdef CONTEXT_ROWS_SUPPORTED}
prep^.pub.pre_process_data := pre_process_context;
create_context_buffer(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
{ No context, just make it tall enough for one row group }
prep^.pub.pre_process_data := pre_process_data;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE *
cinfo^.max_h_samp_factor) div compptr^.h_samp_factor),
JDIMENSION(cinfo^.max_v_samp_factor) );
Inc(compptr);
end;
end;
end;
end.

631
Imaging/JpegLib/imjcsample.pas Normal file
View File

@@ -0,0 +1,631 @@
unit imjcsample;
{ This file contains downsampling routines.
Downsampling input data is counted in "row groups". A row group
is defined to be max_v_samp_factor pixel rows of each component,
from which the downsampler produces v_samp_factor sample rows.
A single row group is processed in each call to the downsampler module.
The downsampler is responsible for edge-expansion of its output data
to fill an integral number of DCT blocks horizontally. The source buffer
may be modified if it is helpful for this purpose (the source buffer is
allocated wide enough to correspond to the desired output width).
The caller (the prep controller) is responsible for vertical padding.
The downsampler may request "context rows" by setting need_context_rows
during startup. In this case, the input arrays will contain at least
one row group's worth of pixels above and below the passed-in data;
the caller will create dummy rows at image top and bottom by replicating
the first or last real pixel row.
An excellent reference for image resampling is
Digital Image Warping, George Wolberg, 1990.
Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7.
The downsampling algorithm used here is a simple average of the source
pixels covered by the output pixel. The hi-falutin sampling literature
refers to this as a "box filter". In general the characteristics of a box
filter are not very good, but for the specific cases we normally use (1:1
and 2:1 ratios) the box is equivalent to a "triangle filter" which is not
nearly so bad. If you intend to use other sampling ratios, you'd be well
advised to improve this code.
A simple input-smoothing capability is provided. This is mainly intended
for cleaning up color-dithered GIF input files (if you find it inadequate,
we suggest using an external filtering program such as pnmconvol). When
enabled, each input pixel P is replaced by a weighted sum of itself and its
eight neighbors. P's weight is 1-8*SF and each neighbor's weight is SF,
where SF := (smoothing_factor / 1024).
Currently, smoothing is only supported for 2h2v sampling factors. }
{ Original: jcsample.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjdeferr,
imjerror,
imjpeglib;
{ Module initialization routine for downsampling.
Note that we must select a routine for each component. }
{GLOBAL}
procedure jinit_downsampler (cinfo : j_compress_ptr);
implementation
{ Pointer to routine to downsample a single component }
type
downsample1_ptr = procedure(cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
{ Private subobject }
type
my_downsample_ptr = ^my_downsampler;
my_downsampler = record
pub : jpeg_downsampler; { public fields }
{ Downsampling method pointers, one per component }
methods : array[0..MAX_COMPONENTS-1] of downsample1_ptr;
end;
{ Initialize for a downsampling pass. }
{METHODDEF}
procedure start_pass_downsample (cinfo : j_compress_ptr);
begin
{ no work for now }
end;
{ Expand a component horizontally from width input_cols to width output_cols,
by duplicating the rightmost samples. }
{LOCAL}
procedure expand_right_edge (image_data : JSAMPARRAY;
num_rows : int;
input_cols : JDIMENSION;
output_cols : JDIMENSION);
var
{register} ptr : JSAMPLE_PTR;
{register} pixval : JSAMPLE;
{register} count : int;
row : int;
numcols : int;
begin
numcols := int (output_cols - input_cols);
if (numcols > 0) then
begin
for row := 0 to pred(num_rows) do
begin
ptr := JSAMPLE_PTR(@(image_data^[row]^[input_cols-1]));
pixval := ptr^; { don't need GETJSAMPLE() here }
for count := pred(numcols) downto 0 do
begin
Inc(ptr);
ptr^ := pixval;
end;
end;
end;
end;
{ Do downsampling for a whole row group (all components).
In this version we simply downsample each component independently. }
{METHODDEF}
procedure sep_downsample (cinfo : j_compress_ptr;
input_buf : JSAMPIMAGE;
in_row_index : JDIMENSION;
output_buf : JSAMPIMAGE;
out_row_group_index : JDIMENSION);
var
downsample : my_downsample_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
in_ptr, out_ptr : JSAMPARRAY;
begin
downsample := my_downsample_ptr (cinfo^.downsample);
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
in_ptr := JSAMPARRAY(@ input_buf^[ci]^[in_row_index]);
out_ptr := JSAMPARRAY(@ output_buf^[ci]^
[out_row_group_index * JDIMENSION(compptr^.v_samp_factor)]);
downsample^.methods[ci] (cinfo, compptr, in_ptr, out_ptr);
Inc(compptr);
end;
end;
{ Downsample pixel values of a single component.
One row group is processed per call.
This version handles arbitrary integral sampling ratios, without smoothing.
Note that this version is not actually used for customary sampling ratios. }
{METHODDEF}
procedure int_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
var
inrow, outrow, h_expand, v_expand, numpix, numpix2, h, v : int;
outcol, outcol_h : JDIMENSION; { outcol_h = outcol*h_expand }
output_cols : JDIMENSION;
inptr,
outptr : JSAMPLE_PTR;
outvalue : INT32;
begin
output_cols := compptr^.width_in_blocks * DCTSIZE;
h_expand := cinfo^.max_h_samp_factor div compptr^.h_samp_factor;
v_expand := cinfo^.max_v_samp_factor div compptr^.v_samp_factor;
numpix := h_expand * v_expand;
numpix2 := numpix div 2;
{ Expand input data enough to let all the output samples be generated
by the standard loop. Special-casing padded output would be more
efficient. }
expand_right_edge(input_data, cinfo^.max_v_samp_factor,
cinfo^.image_width, output_cols * JDIMENSION(h_expand));
inrow := 0;
for outrow := 0 to pred(compptr^.v_samp_factor) do
begin
outptr := JSAMPLE_PTR(output_data^[outrow]);
outcol_h := 0;
for outcol := 0 to pred(output_cols) do
begin
outvalue := 0;
for v := 0 to pred(v_expand) do
begin
inptr := @(input_data^[inrow+v]^[outcol_h]);
for h := 0 to pred(h_expand) do
begin
Inc(outvalue, INT32 (GETJSAMPLE(inptr^)) );
Inc(inptr);
end;
end;
outptr^ := JSAMPLE ((outvalue + numpix2) div numpix);
Inc(outptr);
Inc(outcol_h, h_expand);
end;
Inc(inrow, v_expand);
end;
end;
{ Downsample pixel values of a single component.
This version handles the special case of a full-size component,
without smoothing. }
{METHODDEF}
procedure fullsize_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
begin
{ Copy the data }
jcopy_sample_rows(input_data, 0, output_data, 0,
cinfo^.max_v_samp_factor, cinfo^.image_width);
{ Edge-expand }
expand_right_edge(output_data, cinfo^.max_v_samp_factor,
cinfo^.image_width, compptr^.width_in_blocks * DCTSIZE);
end;
{ Downsample pixel values of a single component.
This version handles the common case of 2:1 horizontal and 1:1 vertical,
without smoothing.
A note about the "bias" calculations: when rounding fractional values to
integer, we do not want to always round 0.5 up to the next integer.
If we did that, we'd introduce a noticeable bias towards larger values.
Instead, this code is arranged so that 0.5 will be rounded up or down at
alternate pixel locations (a simple ordered dither pattern). }
{METHODDEF}
procedure h2v1_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
var
outrow : int;
outcol : JDIMENSION;
output_cols : JDIMENSION;
{register} inptr, outptr : JSAMPLE_PTR;
{register} bias : int;
begin
output_cols := compptr^.width_in_blocks * DCTSIZE;
{ Expand input data enough to let all the output samples be generated
by the standard loop. Special-casing padded output would be more
efficient. }
expand_right_edge(input_data, cinfo^.max_v_samp_factor,
cinfo^.image_width, output_cols * 2);
for outrow := 0 to pred(compptr^.v_samp_factor) do
begin
outptr := JSAMPLE_PTR(output_data^[outrow]);
inptr := JSAMPLE_PTR(input_data^[outrow]);
bias := 0; { bias := 0,1,0,1,... for successive samples }
for outcol := 0 to pred(output_cols) do
begin
outptr^ := JSAMPLE ((GETJSAMPLE(inptr^) +
GETJSAMPLE(JSAMPROW(inptr)^[1]) + bias) shr 1);
Inc(outptr);
bias := bias xor 1; { 0=>1, 1=>0 }
Inc(inptr, 2);
end;
end;
end;
{ Downsample pixel values of a single component.
This version handles the standard case of 2:1 horizontal and 2:1 vertical,
without smoothing. }
{METHODDEF}
procedure h2v2_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
var
inrow, outrow : int;
outcol : JDIMENSION;
output_cols : JDIMENSION;
{register} inptr0, inptr1, outptr : JSAMPLE_PTR;
{register} bias : int;
begin
output_cols := compptr^.width_in_blocks * DCTSIZE;
{ Expand input data enough to let all the output samples be generated
by the standard loop. Special-casing padded output would be more
efficient. }
expand_right_edge(input_data, cinfo^.max_v_samp_factor,
cinfo^.image_width, output_cols * 2);
inrow := 0;
for outrow := 0 to pred(compptr^.v_samp_factor) do
begin
outptr := JSAMPLE_PTR(output_data^[outrow]);
inptr0 := JSAMPLE_PTR(input_data^[inrow]);
inptr1 := JSAMPLE_PTR(input_data^[inrow+1]);
bias := 1; { bias := 1,2,1,2,... for successive samples }
for outcol := 0 to pred(output_cols) do
begin
outptr^ := JSAMPLE ((GETJSAMPLE(inptr0^) +
GETJSAMPLE(JSAMPROW(inptr0)^[1]) +
GETJSAMPLE(inptr1^) +
GETJSAMPLE(JSAMPROW(inptr1)^[1]) + bias) shr 2);
Inc(outptr);
bias := bias xor 3; { 1=>2, 2=>1 }
Inc(inptr0, 2);
Inc(inptr1, 2);
end;
Inc(inrow, 2);
end;
end;
{$ifdef INPUT_SMOOTHING_SUPPORTED}
{ Downsample pixel values of a single component.
This version handles the standard case of 2:1 horizontal and 2:1 vertical,
with smoothing. One row of context is required. }
{METHODDEF}
procedure h2v2_smooth_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
var
inrow, outrow : int;
colctr : JDIMENSION;
output_cols : JDIMENSION;
{register} inptr0, inptr1, above_ptr, below_ptr, outptr : JSAMPLE_PTR;
membersum, neighsum, memberscale, neighscale : INT32;
var
prev_input_data : JSAMPARRAY;
prev_inptr0, prev_inptr1, prev_above_ptr, prev_below_ptr : JSAMPLE_PTR;
begin
output_cols := compptr^.width_in_blocks * DCTSIZE;
{ Expand input data enough to let all the output samples be generated
by the standard loop. Special-casing padded output would be more
efficient. }
prev_input_data := input_data;
Dec(JSAMPROW_PTR(prev_input_data));
expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2,
cinfo^.image_width, output_cols * 2);
{ We don't bother to form the individual "smoothed" input pixel values;
we can directly compute the output which is the average of the four
smoothed values. Each of the four member pixels contributes a fraction
(1-8*SF) to its own smoothed image and a fraction SF to each of the three
other smoothed pixels, therefore a total fraction (1-5*SF)/4 to the final
output. The four corner-adjacent neighbor pixels contribute a fraction
SF to just one smoothed pixel, or SF/4 to the final output; while the
eight edge-adjacent neighbors contribute SF to each of two smoothed
pixels, or SF/2 overall. In order to use integer arithmetic, these
factors are scaled by 2^16 := 65536.
Also recall that SF := smoothing_factor / 1024. }
memberscale := 16384 - cinfo^.smoothing_factor * 80; { scaled (1-5*SF)/4 }
neighscale := cinfo^.smoothing_factor * 16; { scaled SF/4 }
inrow := 0;
for outrow := 0 to pred(compptr^.v_samp_factor) do
begin
outptr := JSAMPLE_PTR(output_data^[outrow]);
inptr0 := JSAMPLE_PTR(input_data^[inrow]);
inptr1 := JSAMPLE_PTR(input_data^[inrow+1]);
above_ptr := JSAMPLE_PTR(input_data^[inrow-1]);
below_ptr := JSAMPLE_PTR(input_data^[inrow+2]);
{ Special case for first column: pretend column -1 is same as column 0 }
membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) +
GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]);
neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) +
GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) +
GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) +
GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]);
Inc(neighsum, neighsum);
Inc(neighsum, GETJSAMPLE(above_ptr^) +
GETJSAMPLE(JSAMPROW(above_ptr)^[2]) +
GETJSAMPLE(below_ptr^) +
GETJSAMPLE(JSAMPROW(below_ptr)^[2]) );
membersum := membersum * memberscale + neighsum * neighscale;
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
Inc(outptr);
prev_inptr0 := inptr0;
prev_inptr1 := inptr1;
Inc(prev_inptr0);
Inc(prev_inptr1);
Inc(inptr0, 2);
Inc(inptr1, 2);
prev_above_ptr := above_ptr;
prev_below_ptr := below_ptr;
Inc(above_ptr, 2);
Inc(below_ptr, 2);
Inc(prev_above_ptr, 1);
Inc(prev_below_ptr, 1);
for colctr := pred(output_cols - 2) downto 0 do
begin
{ sum of pixels directly mapped to this output element }
membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) +
GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]);
{ sum of edge-neighbor pixels }
neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) +
GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) +
GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) +
GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]);
{ The edge-neighbors count twice as much as corner-neighbors }
Inc(neighsum, neighsum);
{ Add in the corner-neighbors }
Inc(neighsum, GETJSAMPLE(prev_above_ptr^) +
GETJSAMPLE(JSAMPROW(above_ptr)^[2]) +
GETJSAMPLE(prev_below_ptr^) +
GETJSAMPLE(JSAMPROW(below_ptr)^[2]) );
{ form final output scaled up by 2^16 }
membersum := membersum * memberscale + neighsum * neighscale;
{ round, descale and output it }
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
Inc(outptr);
Inc(inptr0, 2);
Inc(inptr1, 2);
Inc(prev_inptr0, 2);
Inc(prev_inptr1, 2);
Inc(above_ptr, 2);
Inc(below_ptr, 2);
Inc(prev_above_ptr, 2);
Inc(prev_below_ptr, 2);
end;
{ Special case for last column }
membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) +
GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]);
neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) +
GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) +
GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) +
GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]);
Inc(neighsum, neighsum);
Inc(neighsum, GETJSAMPLE(prev_above_ptr^) +
GETJSAMPLE(JSAMPROW(above_ptr)^[1]) +
GETJSAMPLE(prev_below_ptr^) +
GETJSAMPLE(JSAMPROW(below_ptr)^[1]) );
membersum := membersum * memberscale + neighsum * neighscale;
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
Inc(inrow, 2);
end;
end;
{ Downsample pixel values of a single component.
This version handles the special case of a full-size component,
with smoothing. One row of context is required. }
{METHODDEF}
procedure fullsize_smooth_downsample (cinfo : j_compress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
output_data : JSAMPARRAY);
var
outrow : int;
colctr : JDIMENSION;
output_cols : JDIMENSION;
{register} inptr, above_ptr, below_ptr, outptr : JSAMPLE_PTR;
membersum, neighsum, memberscale, neighscale : INT32;
colsum, lastcolsum, nextcolsum : int;
var
prev_input_data : JSAMPARRAY;
begin
output_cols := compptr^.width_in_blocks * DCTSIZE;
{ Expand input data enough to let all the output samples be generated
by the standard loop. Special-casing padded output would be more
efficient. }
prev_input_data := input_data;
Dec(JSAMPROW_PTR(prev_input_data));
expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2,
cinfo^.image_width, output_cols);
{ Each of the eight neighbor pixels contributes a fraction SF to the
smoothed pixel, while the main pixel contributes (1-8*SF). In order
to use integer arithmetic, these factors are multiplied by 2^16 := 65536.
Also recall that SF := smoothing_factor / 1024. }
memberscale := long(65536) - cinfo^.smoothing_factor * long(512); { scaled 1-8*SF }
neighscale := cinfo^.smoothing_factor * 64; { scaled SF }
for outrow := 0 to pred(compptr^.v_samp_factor) do
begin
outptr := JSAMPLE_PTR(output_data^[outrow]);
inptr := JSAMPLE_PTR(input_data^[outrow]);
above_ptr := JSAMPLE_PTR(input_data^[outrow-1]);
below_ptr := JSAMPLE_PTR(input_data^[outrow+1]);
{ Special case for first column }
colsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) +
GETJSAMPLE(inptr^);
Inc(above_ptr);
Inc(below_ptr);
membersum := GETJSAMPLE(inptr^);
Inc(inptr);
nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) +
GETJSAMPLE(inptr^);
neighsum := colsum + (colsum - membersum) + nextcolsum;
membersum := membersum * memberscale + neighsum * neighscale;
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
Inc(outptr);
lastcolsum := colsum; colsum := nextcolsum;
for colctr := pred(output_cols - 2) downto 0 do
begin
membersum := GETJSAMPLE(inptr^);
Inc(inptr);
Inc(above_ptr);
Inc(below_ptr);
nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) +
GETJSAMPLE(inptr^);
neighsum := lastcolsum + (colsum - membersum) + nextcolsum;
membersum := membersum * memberscale + neighsum * neighscale;
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
Inc(outptr);
lastcolsum := colsum; colsum := nextcolsum;
end;
{ Special case for last column }
membersum := GETJSAMPLE(inptr^);
neighsum := lastcolsum + (colsum - membersum) + colsum;
membersum := membersum * memberscale + neighsum * neighscale;
outptr^ := JSAMPLE ((membersum + 32768) shr 16);
end;
end;
{$endif} { INPUT_SMOOTHING_SUPPORTED }
{ Module initialization routine for downsampling.
Note that we must select a routine for each component. }
{GLOBAL}
procedure jinit_downsampler (cinfo : j_compress_ptr);
var
downsample : my_downsample_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
smoothok : boolean;
begin
smoothok := TRUE;
downsample := my_downsample_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_downsampler)) );
cinfo^.downsample := jpeg_downsampler_ptr (downsample);
downsample^.pub.start_pass := start_pass_downsample;
downsample^.pub.downsample := sep_downsample;
downsample^.pub.need_context_rows := FALSE;
if (cinfo^.CCIR601_sampling) then
ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL);
{ Verify we can handle the sampling factors, and set up method pointers }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
if (compptr^.h_samp_factor = cinfo^.max_h_samp_factor) and
(compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then
begin
{$ifdef INPUT_SMOOTHING_SUPPORTED}
if (cinfo^.smoothing_factor <> 0) then
begin
downsample^.methods[ci] := fullsize_smooth_downsample;
downsample^.pub.need_context_rows := TRUE;
end
else
{$endif}
downsample^.methods[ci] := fullsize_downsample;
end
else
if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and
(compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then
begin
smoothok := FALSE;
downsample^.methods[ci] := h2v1_downsample;
end
else
if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and
(compptr^.v_samp_factor * 2 = cinfo^.max_v_samp_factor) then
begin
{$ifdef INPUT_SMOOTHING_SUPPORTED}
if (cinfo^.smoothing_factor <> 0) then
begin
downsample^.methods[ci] := h2v2_smooth_downsample;
downsample^.pub.need_context_rows := TRUE;
end
else
{$endif}
downsample^.methods[ci] := h2v2_downsample;
end
else
if ((cinfo^.max_h_samp_factor mod compptr^.h_samp_factor) = 0) and
((cinfo^.max_v_samp_factor mod compptr^.v_samp_factor) = 0) then
begin
smoothok := FALSE;
downsample^.methods[ci] := int_downsample;
end
else
ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL);
Inc(compptr);
end;
{$ifdef INPUT_SMOOTHING_SUPPORTED}
if (cinfo^.smoothing_factor <> 0) and (not smoothok) then
TRACEMS(j_common_ptr(cinfo), 0, JTRC_SMOOTH_NOTIMPL);
{$endif}
end;
end.

505
Imaging/JpegLib/imjdapimin.pas Normal file
View File

@@ -0,0 +1,505 @@
unit imjdapimin;
{$N+} { Nomssi: cinfo^.output_gamma }
{ This file contains application interface code for the decompression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-decompression case or the
transcoding-only case.
Most of the routines intended to be called directly by an application
are in this file or in jdapistd.c. But also see jcomapi.c for routines
shared by compression and decompression, and jdtrans.c for the transcoding
case. }
{ Original : jdapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjmemmgr, imjdmarker, imjdinput, imjcomapi;
{ Nomssi }
procedure jpeg_create_decompress(cinfo : j_decompress_ptr);
{ Initialization of a JPEG decompression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr;
version : int;
structsize : size_t);
{ Destruction of a JPEG decompression object }
{GLOBAL}
procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr);
{ Decompression startup: read start of JPEG datastream to see what's there.
Need only initialize JPEG object and supply a data source before calling.
This routine will read as far as the first SOS marker (ie, actual start of
compressed data), and will save all tables and parameters in the JPEG
object. It will also initialize the decompression parameters to default
values, and finally return JPEG_HEADER_OK. On return, the application may
adjust the decompression parameters and then call jpeg_start_decompress.
(Or, if the application only wanted to determine the image parameters,
the data need not be decompressed. In that case, call jpeg_abort or
jpeg_destroy to release any temporary space.)
If an abbreviated (tables only) datastream is presented, the routine will
return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then
re-use the JPEG object to read the abbreviated image datastream(s).
It is unnecessary (but OK) to call jpeg_abort in this case.
The JPEG_SUSPENDED return code only occurs if the data source module
requests suspension of the decompressor. In this case the application
should load more source data and then re-call jpeg_read_header to resume
processing.
If a non-suspending data source is used and require_image is TRUE, then the
return code need not be inspected since only JPEG_HEADER_OK is possible.
This routine is now just a front end to jpeg_consume_input, with some
extra error checking. }
{GLOBAL}
function jpeg_read_header (cinfo : j_decompress_ptr;
require_image : boolean) : int;
{ Consume data in advance of what the decompressor requires.
This can be called at any time once the decompressor object has
been created and a data source has been set up.
This routine is essentially a state machine that handles a couple
of critical state-transition actions, namely initial setup and
transition from header scanning to ready-for-start_decompress.
All the actual input is done via the input controller's consume_input
method. }
{GLOBAL}
function jpeg_consume_input (cinfo : j_decompress_ptr) : int;
{ Have we finished reading the input file? }
{GLOBAL}
function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean;
{ Is there more than one scan? }
{GLOBAL}
function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean;
{ Finish JPEG decompression.
This will normally just verify the file trailer and release temp storage.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean;
implementation
procedure jpeg_create_decompress(cinfo : j_decompress_ptr);
begin
jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION,
size_t(sizeof(jpeg_decompress_struct)));
end;
{ Initialization of a JPEG decompression object.
The error manager must already be set up (in case memory manager fails). }
{GLOBAL}
procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr;
version : int;
structsize : size_t);
var
i : int;
var
err : jpeg_error_mgr_ptr;
client_data : voidp;
begin
{ Guard against version mismatches between library and caller. }
cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called }
if (version <> JPEG_LIB_VERSION) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version);
if (structsize <> SIZEOF(jpeg_decompress_struct)) then
ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE,
int(SIZEOF(jpeg_decompress_struct)), int(structsize));
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
begin
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
MEMZERO(j_common_ptr(cinfo), SIZEOF(jpeg_decompress_struct));
cinfo^.err := err;
cinfo^.client_data := client_data;
end;
cinfo^.is_decompressor := TRUE;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));
{ Zero out pointers to permanent structures. }
cinfo^.progress := NIL;
cinfo^.src := NIL;
for i := 0 to pred(NUM_QUANT_TBLS) do
cinfo^.quant_tbl_ptrs[i] := NIL;
for i := 0 to pred(NUM_HUFF_TBLS) do
begin
cinfo^.dc_huff_tbl_ptrs[i] := NIL;
cinfo^.ac_huff_tbl_ptrs[i] := NIL;
end;
{ Initialize marker processor so application can override methods
for COM, APPn markers before calling jpeg_read_header. }
cinfo^.marker_list := NIL;
jinit_marker_reader(cinfo);
{ And initialize the overall input controller. }
jinit_input_controller(cinfo);
{ OK, I'm ready }
cinfo^.global_state := DSTATE_START;
end;
{ Destruction of a JPEG decompression object }
{GLOBAL}
procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr);
begin
jpeg_destroy(j_common_ptr(cinfo)); { use common routine }
end;
{ Abort processing of a JPEG decompression operation,
but don't destroy the object itself. }
{GLOBAL}
procedure jpeg_abort_decompress (cinfo : j_decompress_ptr);
begin
jpeg_abort(j_common_ptr(cinfo)); { use common routine }
end;
{ Set default decompression parameters. }
{LOCAL}
procedure default_decompress_parms (cinfo : j_decompress_ptr);
var
cid0 : int;
cid1 : int;
cid2 : int;
begin
{ Guess the input colorspace, and set output colorspace accordingly. }
{ (Wish JPEG committee had provided a real way to specify this...) }
{ Note application may override our guesses. }
case (cinfo^.num_components) of
1: begin
cinfo^.jpeg_color_space := JCS_GRAYSCALE;
cinfo^.out_color_space := JCS_GRAYSCALE;
end;
3: begin
if (cinfo^.saw_JFIF_marker) then
begin
cinfo^.jpeg_color_space := JCS_YCbCr; { JFIF implies YCbCr }
end
else
if (cinfo^.saw_Adobe_marker) then
begin
case (cinfo^.Adobe_transform) of
0: cinfo^.jpeg_color_space := JCS_RGB;
1: cinfo^.jpeg_color_space := JCS_YCbCr;
else
begin
WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform);
cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr }
end;
end;
end
else
begin
{ Saw no special markers, try to guess from the component IDs }
cid0 := cinfo^.comp_info^[0].component_id;
cid1 := cinfo^.comp_info^[1].component_id;
cid2 := cinfo^.comp_info^[2].component_id;
if (cid0 = 1) and (cid1 = 2) and (cid2 = 3) then
cinfo^.jpeg_color_space := JCS_YCbCr { assume JFIF w/out marker }
else
if (cid0 = 82) and (cid1 = 71) and (cid2 = 66) then
cinfo^.jpeg_color_space := JCS_RGB { ASCII 'R', 'G', 'B' }
else
begin
{$IFDEF DEBUG}
TRACEMS3(j_common_ptr(cinfo), 1, JTRC_UNKNOWN_IDS, cid0, cid1, cid2);
{$ENDIF}
cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr }
end;
end;
{ Always guess RGB is proper output colorspace. }
cinfo^.out_color_space := JCS_RGB;
end;
4: begin
if (cinfo^.saw_Adobe_marker) then
begin
case (cinfo^.Adobe_transform) of
0: cinfo^.jpeg_color_space := JCS_CMYK;
2: cinfo^.jpeg_color_space := JCS_YCCK;
else
begin
WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform);
cinfo^.jpeg_color_space := JCS_YCCK; { assume it's YCCK }
end;
end;
end
else
begin
{ No special markers, assume straight CMYK. }
cinfo^.jpeg_color_space := JCS_CMYK;
end;
cinfo^.out_color_space := JCS_CMYK;
end;
else
begin
cinfo^.jpeg_color_space := JCS_UNKNOWN;
cinfo^.out_color_space := JCS_UNKNOWN;
end;
end;
{ Set defaults for other decompression parameters. }
cinfo^.scale_num := 1; { 1:1 scaling }
cinfo^.scale_denom := 1;
cinfo^.output_gamma := 1.0;
cinfo^.buffered_image := FALSE;
cinfo^.raw_data_out := FALSE;
cinfo^.dct_method := JDCT_DEFAULT;
cinfo^.do_fancy_upsampling := TRUE;
cinfo^.do_block_smoothing := TRUE;
cinfo^.quantize_colors := FALSE;
{ We set these in case application only sets quantize_colors. }
cinfo^.dither_mode := JDITHER_FS;
{$ifdef QUANT_2PASS_SUPPORTED}
cinfo^.two_pass_quantize := TRUE;
{$else}
cinfo^.two_pass_quantize := FALSE;
{$endif}
cinfo^.desired_number_of_colors := 256;
cinfo^.colormap := NIL;
{ Initialize for no mode change in buffered-image mode. }
cinfo^.enable_1pass_quant := FALSE;
cinfo^.enable_external_quant := FALSE;
cinfo^.enable_2pass_quant := FALSE;
end;
{ Decompression startup: read start of JPEG datastream to see what's there.
Need only initialize JPEG object and supply a data source before calling.
This routine will read as far as the first SOS marker (ie, actual start of
compressed data), and will save all tables and parameters in the JPEG
object. It will also initialize the decompression parameters to default
values, and finally return JPEG_HEADER_OK. On return, the application may
adjust the decompression parameters and then call jpeg_start_decompress.
(Or, if the application only wanted to determine the image parameters,
the data need not be decompressed. In that case, call jpeg_abort or
jpeg_destroy to release any temporary space.)
If an abbreviated (tables only) datastream is presented, the routine will
return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then
re-use the JPEG object to read the abbreviated image datastream(s).
It is unnecessary (but OK) to call jpeg_abort in this case.
The JPEG_SUSPENDED return code only occurs if the data source module
requests suspension of the decompressor. In this case the application
should load more source data and then re-call jpeg_read_header to resume
processing.
If a non-suspending data source is used and require_image is TRUE, then the
return code need not be inspected since only JPEG_HEADER_OK is possible.
This routine is now just a front end to jpeg_consume_input, with some
extra error checking. }
{GLOBAL}
function jpeg_read_header (cinfo : j_decompress_ptr;
require_image : boolean) : int;
var
retcode : int;
begin
if (cinfo^.global_state <> DSTATE_START) and
(cinfo^.global_state <> DSTATE_INHEADER) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
retcode := jpeg_consume_input(cinfo);
case (retcode) of
JPEG_REACHED_SOS:
retcode := JPEG_HEADER_OK;
JPEG_REACHED_EOI:
begin
if (require_image) then { Complain if application wanted an image }
ERREXIT(j_common_ptr(cinfo), JERR_NO_IMAGE);
{ Reset to start state; it would be safer to require the application to
call jpeg_abort, but we can't change it now for compatibility reasons.
A side effect is to free any temporary memory (there shouldn't be any). }
jpeg_abort(j_common_ptr(cinfo)); { sets state := DSTATE_START }
retcode := JPEG_HEADER_TABLES_ONLY;
end;
JPEG_SUSPENDED: ; { no work }
end;
jpeg_read_header := retcode;
end;
{ Consume data in advance of what the decompressor requires.
This can be called at any time once the decompressor object has
been created and a data source has been set up.
This routine is essentially a state machine that handles a couple
of critical state-transition actions, namely initial setup and
transition from header scanning to ready-for-start_decompress.
All the actual input is done via the input controller's consume_input
method. }
{GLOBAL}
function jpeg_consume_input (cinfo : j_decompress_ptr) : int;
var
retcode : int;
begin
retcode := JPEG_SUSPENDED;
{ NB: every possible DSTATE value should be listed in this switch }
if (cinfo^.global_state) = DSTATE_START then
begin {work around the FALLTHROUGH}
{ Start-of-datastream actions: reset appropriate modules }
cinfo^.inputctl^.reset_input_controller (cinfo);
{ Initialize application's data source module }
cinfo^.src^.init_source (cinfo);
cinfo^.global_state := DSTATE_INHEADER;
end;
case (cinfo^.global_state) of
DSTATE_START,
DSTATE_INHEADER:
begin
retcode := cinfo^.inputctl^.consume_input (cinfo);
if (retcode = JPEG_REACHED_SOS) then
begin { Found SOS, prepare to decompress }
{ Set up default parameters based on header data }
default_decompress_parms(cinfo);
{ Set global state: ready for start_decompress }
cinfo^.global_state := DSTATE_READY;
end;
end;
DSTATE_READY:
{ Can't advance past first SOS until start_decompress is called }
retcode := JPEG_REACHED_SOS;
DSTATE_PRELOAD,
DSTATE_PRESCAN,
DSTATE_SCANNING,
DSTATE_RAW_OK,
DSTATE_BUFIMAGE,
DSTATE_BUFPOST,
DSTATE_STOPPING:
retcode := cinfo^.inputctl^.consume_input (cinfo);
else
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end;
jpeg_consume_input := retcode;
end;
{ Have we finished reading the input file? }
{GLOBAL}
function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean;
begin
{ Check for valid jpeg object }
if (cinfo^.global_state < DSTATE_START) or
(cinfo^.global_state > DSTATE_STOPPING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
jpeg_input_complete := cinfo^.inputctl^.eoi_reached;
end;
{ Is there more than one scan? }
{GLOBAL}
function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean;
begin
{ Only valid after jpeg_read_header completes }
if (cinfo^.global_state < DSTATE_READY) or
(cinfo^.global_state > DSTATE_STOPPING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
jpeg_has_multiple_scans := cinfo^.inputctl^.has_multiple_scans;
end;
{ Finish JPEG decompression.
This will normally just verify the file trailer and release temp storage.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean;
begin
if ((cinfo^.global_state = DSTATE_SCANNING) or
(cinfo^.global_state = DSTATE_RAW_OK) and (not cinfo^.buffered_image)) then
begin
{ Terminate final pass of non-buffered mode }
if (cinfo^.output_scanline < cinfo^.output_height) then
ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA);
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.global_state := DSTATE_STOPPING;
end
else
if (cinfo^.global_state = DSTATE_BUFIMAGE) then
begin
{ Finishing after a buffered-image operation }
cinfo^.global_state := DSTATE_STOPPING;
end
else
if (cinfo^.global_state <> DSTATE_STOPPING) then
begin
{ STOPPING := repeat call after a suspension, anything else is error }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end;
{ Read until EOI }
while (not cinfo^.inputctl^.eoi_reached) do
begin
if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then
begin
jpeg_finish_decompress := FALSE; { Suspend, come back later }
exit;
end;
end;
{ Do final cleanup }
cinfo^.src^.term_source (cinfo);
{ We can use jpeg_abort to release memory and reset global_state }
jpeg_abort(j_common_ptr(cinfo));
jpeg_finish_decompress := TRUE;
end;
end.

377
Imaging/JpegLib/imjdapistd.pas Normal file
View File

@@ -0,0 +1,377 @@
unit imjdapistd;
{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains application interface code for the decompression half
of the JPEG library. These are the "standard" API routines that are
used in the normal full-decompression case. They are not used by a
transcoding-only application. Note that if an application links in
jpeg_start_decompress, it will end up linking in the entire decompressor.
We thus must separate this file from jdapimin.c to avoid linking the
whole decompression library into a transcoder. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdmaster;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
implementation
{ Forward declarations }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward;
{ Decompression initialization.
jpeg_read_header must be completed before calling this.
If a multipass operating mode was selected, this will do all but the
last pass, and thus may take a great deal of time.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean;
var
retcode : int;
begin
if (cinfo^.global_state = DSTATE_READY) then
begin
{ First call: initialize master control, select active modules }
jinit_master_decompress(cinfo);
if (cinfo^.buffered_image) then
begin
{ No more work here; expecting jpeg_start_output next }
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_start_decompress := TRUE;
exit;
end;
cinfo^.global_state := DSTATE_PRELOAD;
end;
if (cinfo^.global_state = DSTATE_PRELOAD) then
begin
{ If file has multiple scans, absorb them all into the coef buffer }
if (cinfo^.inputctl^.has_multiple_scans) then
begin
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
while TRUE do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
{ Absorb some more input }
retcode := cinfo^.inputctl^.consume_input (cinfo);
if (retcode = JPEG_SUSPENDED) then
begin
jpeg_start_decompress := FALSE;
exit;
end;
if (retcode = JPEG_REACHED_EOI) then
break;
{ Advance progress counter if appropriate }
if (cinfo^.progress <> NIL) and
((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then
begin
Inc(cinfo^.progress^.pass_counter);
if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then
begin
{ jdmaster underestimated number of scans; ratchet up one scan }
Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows));
end;
end;
end;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end;
cinfo^.output_scan_number := cinfo^.input_scan_number;
end
else
if (cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Perform any dummy output passes, and set up for the final pass }
jpeg_start_decompress := output_pass_setup(cinfo);
end;
{ Set up for an output pass, and perform any dummy pass(es) needed.
Common subroutine for jpeg_start_decompress and jpeg_start_output.
Entry: global_state := DSTATE_PRESCAN only if previously suspended.
Exit: If done, returns TRUE and sets global_state for proper output mode.
If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. }
{LOCAL}
function output_pass_setup (cinfo : j_decompress_ptr) : boolean;
var
last_scanline : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_PRESCAN) then
begin
{ First call: do pass setup }
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
cinfo^.global_state := DSTATE_PRESCAN;
end;
{ Loop over any required dummy passes }
while (cinfo^.master^.is_dummy_pass) do
begin
{$ifdef QUANT_2PASS_SUPPORTED}
{ Crank through the dummy pass }
while (cinfo^.output_scanline < cinfo^.output_height) do
begin
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
last_scanline := cinfo^.output_scanline;
cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL),
cinfo^.output_scanline, {var}
JDIMENSION(0));
if (cinfo^.output_scanline = last_scanline) then
begin
output_pass_setup := FALSE; { No progress made, must suspend }
exit;
end;
end;
{ Finish up dummy pass, and set up for another one }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.master^.prepare_for_output_pass (cinfo);
cinfo^.output_scanline := 0;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { QUANT_2PASS_SUPPORTED }
end;
{ Ready for application to drive output pass through
jpeg_read_scanlines or jpeg_read_raw_data. }
if cinfo^.raw_data_out then
cinfo^.global_state := DSTATE_RAW_OK
else
cinfo^.global_state := DSTATE_SCANNING;
output_pass_setup := TRUE;
end;
{ Read some scanlines of data from the JPEG decompressor.
The return value will be the number of lines actually read.
This may be less than the number requested in several cases,
including bottom of image, data source suspension, and operating
modes that emit multiple scanlines at a time.
Note: we warn about excess calls to jpeg_read_scanlines() since
this likely signals an application programmer error. However,
an oversize buffer (max_lines > scanlines remaining) is not an error. }
{GLOBAL}
function jpeg_read_scanlines (cinfo : j_decompress_ptr;
scanlines : JSAMPARRAY;
max_lines : JDIMENSION) : JDIMENSION;
var
row_ctr : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_SCANNING) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_scanlines := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Process some data }
row_ctr := 0;
cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines);
Inc(cinfo^.output_scanline, row_ctr);
jpeg_read_scanlines := row_ctr;
end;
{ Alternate entry point to read raw data.
Processes exactly one iMCU row per call, unless suspended. }
{GLOBAL}
function jpeg_read_raw_data (cinfo : j_decompress_ptr;
data : JSAMPIMAGE;
max_lines : JDIMENSION) : JDIMENSION;
var
lines_per_iMCU_row : JDIMENSION;
begin
if (cinfo^.global_state <> DSTATE_RAW_OK) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.output_scanline >= cinfo^.output_height) then
begin
WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA);
jpeg_read_raw_data := 0;
exit;
end;
{ Call progress monitor hook if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.pass_counter := long (cinfo^.output_scanline);
cinfo^.progress^.pass_limit := long (cinfo^.output_height);
cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ Verify that at least one iMCU row can be returned. }
lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size;
if (max_lines < lines_per_iMCU_row) then
ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE);
{ Decompress directly into user's buffer. }
if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then
begin
jpeg_read_raw_data := 0; { suspension forced, can do nothing more }
exit;
end;
{ OK, we processed one iMCU row. }
Inc(cinfo^.output_scanline, lines_per_iMCU_row);
jpeg_read_raw_data := lines_per_iMCU_row;
end;
{ Additional entry points for buffered-image mode. }
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Initialize for an output pass in buffered-image mode. }
{GLOBAL}
function jpeg_start_output (cinfo : j_decompress_ptr;
scan_number : int) : boolean;
begin
if (cinfo^.global_state <> DSTATE_BUFIMAGE) and
(cinfo^.global_state <> DSTATE_PRESCAN) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{ Limit scan number to valid range }
if (scan_number <= 0) then
scan_number := 1;
if (cinfo^.inputctl^.eoi_reached) and
(scan_number > cinfo^.input_scan_number) then
scan_number := cinfo^.input_scan_number;
cinfo^.output_scan_number := scan_number;
{ Perform any dummy output passes, and set up for the real pass }
jpeg_start_output := output_pass_setup(cinfo);
end;
{ Finish up after an output pass in buffered-image mode.
Returns FALSE if suspended. The return value need be inspected only if
a suspending data source is used. }
{GLOBAL}
function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean;
begin
if ((cinfo^.global_state = DSTATE_SCANNING) or
(cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then
begin
{ Terminate this pass. }
{ We do not require the whole pass to have been completed. }
cinfo^.master^.finish_output_pass (cinfo);
cinfo^.global_state := DSTATE_BUFPOST;
end
else
if (cinfo^.global_state <> DSTATE_BUFPOST) then
begin
{ BUFPOST := repeat call after a suspension, anything else is error }
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
end;
{ Read markers looking for SOS or EOI }
while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and
(not cinfo^.inputctl^.eoi_reached) do
begin
if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then
begin
jpeg_finish_output := FALSE; { Suspend, come back later }
exit;
end;
end;
cinfo^.global_state := DSTATE_BUFIMAGE;
jpeg_finish_output := TRUE;
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end.

895
Imaging/JpegLib/imjdcoefct.pas Normal file
View File

@@ -0,0 +1,895 @@
unit imjdcoefct;
{ This file contains the coefficient buffer controller for decompression.
This controller is the top level of the JPEG decompressor proper.
The coefficient buffer lies between entropy decoding and inverse-DCT steps.
In buffered-image mode, this controller is the interface between
input-oriented processing and output-oriented processing.
Also, the input side (only) is used when reading a file for transcoding. }
{ Original: jdcoefct.c ; Copyright (C) 1994-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjutils,
imjpeglib;
{GLOBAL}
procedure jinit_d_coef_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
implementation
{ Block smoothing is only applicable for progressive JPEG, so: }
{$ifndef D_PROGRESSIVE_SUPPORTED}
{$undef BLOCK_SMOOTHING_SUPPORTED}
{$endif}
{ Private buffer controller object }
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
const
SAVED_COEFS = 6; { we save coef_bits[0..5] }
type
Latch = array[0..SAVED_COEFS-1] of int;
Latch_ptr = ^Latch;
{$endif}
type
my_coef_ptr = ^my_coef_controller;
my_coef_controller = record
pub : jpeg_d_coef_controller; { public fields }
{ These variables keep track of the current location of the input side. }
{ cinfo^.input_iMCU_row is also used for this. }
MCU_ctr : JDIMENSION; { counts MCUs processed in current row }
MCU_vert_offset : int; { counts MCU rows within iMCU row }
MCU_rows_per_iMCU_row : int; { number of such rows needed }
{ The output side's location is represented by cinfo^.output_iMCU_row. }
{ In single-pass modes, it's sufficient to buffer just one MCU.
We allocate a workspace of D_MAX_BLOCKS_IN_MCU coefficient blocks,
and let the entropy decoder write into that workspace each time.
(On 80x86, the workspace is FAR even though it's not really very big;
this is to keep the module interfaces unchanged when a large coefficient
buffer is necessary.)
In multi-pass modes, this array points to the current MCU's blocks
within the virtual arrays; it is used only by the input side. }
MCU_buffer : array[0..D_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ In multi-pass modes, we need a virtual block array for each component. }
whole_image : jvirt_barray_tbl;
{$endif}
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
{ When doing block smoothing, we latch coefficient Al values here }
coef_bits_latch : Latch_Ptr;
{$endif}
end;
{ Forward declarations }
{METHODDEF}
function decompress_onepass (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int; forward;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{METHODDEF}
function decompress_data (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int; forward;
{$endif}
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
{LOCAL}
function smoothing_ok (cinfo : j_decompress_ptr) : boolean; forward;
{METHODDEF}
function decompress_smooth_data (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int; forward;
{$endif}
{LOCAL}
procedure start_iMCU_row (cinfo : j_decompress_ptr);
{ Reset within-iMCU-row counters for a new row (input side) }
var
coef : my_coef_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
{ In an interleaved scan, an MCU row is the same as an iMCU row.
In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows.
But at the bottom of the image, process only what's left. }
if (cinfo^.comps_in_scan > 1) then
begin
coef^.MCU_rows_per_iMCU_row := 1;
end
else
begin
if (cinfo^.input_iMCU_row < (cinfo^.total_iMCU_rows-1)) then
coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor
else
coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height;
end;
coef^.MCU_ctr := 0;
coef^.MCU_vert_offset := 0;
end;
{ Initialize for an input processing pass. }
{METHODDEF}
procedure start_input_pass (cinfo : j_decompress_ptr);
begin
cinfo^.input_iMCU_row := 0;
start_iMCU_row(cinfo);
end;
{ Initialize for an output processing pass. }
{METHODDEF}
procedure start_output_pass (cinfo : j_decompress_ptr);
var
coef : my_coef_ptr;
begin
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
coef := my_coef_ptr (cinfo^.coef);
{ If multipass, check to see whether to use block smoothing on this pass }
if (coef^.pub.coef_arrays <> NIL) then
begin
if (cinfo^.do_block_smoothing) and smoothing_ok(cinfo) then
coef^.pub.decompress_data := decompress_smooth_data
else
coef^.pub.decompress_data := decompress_data;
end;
{$endif}
cinfo^.output_iMCU_row := 0;
end;
{ Decompress and return some data in the single-pass case.
Always attempts to emit one fully interleaved MCU row ("iMCU" row).
Input and output must run in lockstep since we have only a one-MCU buffer.
Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED.
NB: output_buf contains a plane for each component in image,
which we index according to the component's SOF position.}
{METHODDEF}
function decompress_onepass (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int;
var
coef : my_coef_ptr;
MCU_col_num : JDIMENSION; { index of current MCU within row }
last_MCU_col : JDIMENSION;
last_iMCU_row : JDIMENSION;
blkn, ci, xindex, yindex, yoffset, useful_width : int;
output_ptr : JSAMPARRAY;
start_col, output_col : JDIMENSION;
compptr : jpeg_component_info_ptr;
inverse_DCT : inverse_DCT_method_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
last_MCU_col := cinfo^.MCUs_per_row - 1;
last_iMCU_row := cinfo^.total_iMCU_rows - 1;
{ Loop to process as much as one whole iMCU row }
for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do
begin
for MCU_col_num := coef^.MCU_ctr to last_MCU_col do
begin
{ Try to fetch an MCU. Entropy decoder expects buffer to be zeroed. }
jzero_far( coef^.MCU_buffer[0],
size_t (cinfo^.blocks_in_MCU * SIZEOF(JBLOCK)));
if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then
begin
{ Suspension forced; update state counters and exit }
coef^.MCU_vert_offset := yoffset;
coef^.MCU_ctr := MCU_col_num;
decompress_onepass := JPEG_SUSPENDED;
exit;
end;
{ Determine where data should go in output_buf and do the IDCT thing.
We skip dummy blocks at the right and bottom edges (but blkn gets
incremented past them!). Note the inner loop relies on having
allocated the MCU_buffer[] blocks sequentially. }
blkn := 0; { index of current DCT block within MCU }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Don't bother to IDCT an uninteresting component. }
if (not compptr^.component_needed) then
begin
Inc(blkn, compptr^.MCU_blocks);
continue;
end;
inverse_DCT := cinfo^.idct^.inverse_DCT[compptr^.component_index];
if (MCU_col_num < last_MCU_col) then
useful_width := compptr^.MCU_width
else
useful_width := compptr^.last_col_width;
output_ptr := JSAMPARRAY(@ output_buf^[compptr^.component_index]^
[yoffset * compptr^.DCT_scaled_size]);
start_col := LongInt(MCU_col_num) * compptr^.MCU_sample_width;
for yindex := 0 to pred(compptr^.MCU_height) do
begin
if (cinfo^.input_iMCU_row < last_iMCU_row) or
(yoffset+yindex < compptr^.last_row_height) then
begin
output_col := start_col;
for xindex := 0 to pred(useful_width) do
begin
inverse_DCT (cinfo, compptr,
JCOEFPTR(coef^.MCU_buffer[blkn+xindex]),
output_ptr, output_col);
Inc(output_col, compptr^.DCT_scaled_size);
end;
end;
Inc(blkn, compptr^.MCU_width);
Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size);
end;
end;
end;
{ Completed an MCU row, but perhaps not an iMCU row }
coef^.MCU_ctr := 0;
end;
{ Completed the iMCU row, advance counters for next one }
Inc(cinfo^.output_iMCU_row);
Inc(cinfo^.input_iMCU_row);
if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then
begin
start_iMCU_row(cinfo);
decompress_onepass := JPEG_ROW_COMPLETED;
exit;
end;
{ Completed the scan }
cinfo^.inputctl^.finish_input_pass (cinfo);
decompress_onepass := JPEG_SCAN_COMPLETED;
end;
{ Dummy consume-input routine for single-pass operation. }
{METHODDEF}
function dummy_consume_data (cinfo : j_decompress_ptr) : int;
begin
dummy_consume_data := JPEG_SUSPENDED; { Always indicate nothing was done }
end;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Consume input data and store it in the full-image coefficient buffer.
We read as much as one fully interleaved MCU row ("iMCU" row) per call,
ie, v_samp_factor block rows for each component in the scan.
Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED.}
{METHODDEF}
function consume_data (cinfo : j_decompress_ptr) : int;
var
coef : my_coef_ptr;
MCU_col_num : JDIMENSION; { index of current MCU within row }
blkn, ci, xindex, yindex, yoffset : int;
start_col : JDIMENSION;
buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY;
buffer_ptr : JBLOCKROW;
compptr : jpeg_component_info_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
{ Align the virtual buffers for the components used in this scan. }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
buffer[ci] := cinfo^.mem^.access_virt_barray
(j_common_ptr (cinfo), coef^.whole_image[compptr^.component_index],
LongInt(cinfo^.input_iMCU_row) * compptr^.v_samp_factor,
JDIMENSION (compptr^.v_samp_factor), TRUE);
{ Note: entropy decoder expects buffer to be zeroed,
but this is handled automatically by the memory manager
because we requested a pre-zeroed array. }
end;
{ Loop to process one whole iMCU row }
for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do
begin
for MCU_col_num := coef^.MCU_ctr to pred(cinfo^.MCUs_per_row) do
begin
{ Construct list of pointers to DCT blocks belonging to this MCU }
blkn := 0; { index of current DCT block within MCU }
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
start_col := LongInt(MCU_col_num) * compptr^.MCU_width;
for yindex := 0 to pred(compptr^.MCU_height) do
begin
buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]);
for xindex := 0 to pred(compptr^.MCU_width) do
begin
coef^.MCU_buffer[blkn] := buffer_ptr;
Inc(blkn);
Inc(JBLOCK_PTR(buffer_ptr));
end;
end;
end;
{ Try to fetch the MCU. }
if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then
begin
{ Suspension forced; update state counters and exit }
coef^.MCU_vert_offset := yoffset;
coef^.MCU_ctr := MCU_col_num;
consume_data := JPEG_SUSPENDED;
exit;
end;
end;
{ Completed an MCU row, but perhaps not an iMCU row }
coef^.MCU_ctr := 0;
end;
{ Completed the iMCU row, advance counters for next one }
Inc(cinfo^.input_iMCU_row);
if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then
begin
start_iMCU_row(cinfo);
consume_data := JPEG_ROW_COMPLETED;
exit;
end;
{ Completed the scan }
cinfo^.inputctl^.finish_input_pass (cinfo);
consume_data := JPEG_SCAN_COMPLETED;
end;
{ Decompress and return some data in the multi-pass case.
Always attempts to emit one fully interleaved MCU row ("iMCU" row).
Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED.
NB: output_buf contains a plane for each component in image. }
{METHODDEF}
function decompress_data (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int;
var
coef : my_coef_ptr;
last_iMCU_row : JDIMENSION;
block_num : JDIMENSION;
ci, block_row, block_rows : int;
buffer : JBLOCKARRAY;
buffer_ptr : JBLOCKROW;
output_ptr : JSAMPARRAY;
output_col : JDIMENSION;
compptr : jpeg_component_info_ptr;
inverse_DCT : inverse_DCT_method_ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
last_iMCU_row := cinfo^.total_iMCU_rows - 1;
{ Force some input to be done if we are getting ahead of the input. }
while (cinfo^.input_scan_number < cinfo^.output_scan_number) or
((cinfo^.input_scan_number = cinfo^.output_scan_number) and
(LongInt(cinfo^.input_iMCU_row) <= cinfo^.output_iMCU_row)) do
begin
if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then
begin
decompress_data := JPEG_SUSPENDED;
exit;
end;
end;
{ OK, output from the virtual arrays. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Don't bother to IDCT an uninteresting component. }
if (not compptr^.component_needed) then
continue;
{ Align the virtual buffer for this component. }
buffer := cinfo^.mem^.access_virt_barray
(j_common_ptr (cinfo), coef^.whole_image[ci],
cinfo^.output_iMCU_row * compptr^.v_samp_factor,
JDIMENSION (compptr^.v_samp_factor), FALSE);
{ Count non-dummy DCT block rows in this iMCU row. }
if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then
block_rows := compptr^.v_samp_factor
else
begin
{ NB: can't use last_row_height here; it is input-side-dependent! }
block_rows := int(LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor);
if (block_rows = 0) then
block_rows := compptr^.v_samp_factor;
end;
inverse_DCT := cinfo^.idct^.inverse_DCT[ci];
output_ptr := output_buf^[ci];
{ Loop over all DCT blocks to be processed. }
for block_row := 0 to pred(block_rows) do
begin
buffer_ptr := buffer^[block_row];
output_col := 0;
for block_num := 0 to pred(compptr^.width_in_blocks) do
begin
inverse_DCT (cinfo, compptr, JCOEFPTR (buffer_ptr),
output_ptr, output_col);
Inc(JBLOCK_PTR(buffer_ptr));
Inc(output_col, compptr^.DCT_scaled_size);
end;
Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size);
end;
Inc(compptr);
end;
Inc(cinfo^.output_iMCU_row);
if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then
begin
decompress_data := JPEG_ROW_COMPLETED;
exit;
end;
decompress_data := JPEG_SCAN_COMPLETED;
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
{ This code applies interblock smoothing as described by section K.8
of the JPEG standard: the first 5 AC coefficients are estimated from
the DC values of a DCT block and its 8 neighboring blocks.
We apply smoothing only for progressive JPEG decoding, and only if
the coefficients it can estimate are not yet known to full precision. }
{ Natural-order array positions of the first 5 zigzag-order coefficients }
const
Q01_POS = 1;
Q10_POS = 8;
Q20_POS = 16;
Q11_POS = 9;
Q02_POS = 2;
{ Determine whether block smoothing is applicable and safe.
We also latch the current states of the coef_bits[] entries for the
AC coefficients; otherwise, if the input side of the decompressor
advances into a new scan, we might think the coefficients are known
more accurately than they really are. }
{LOCAL}
function smoothing_ok (cinfo : j_decompress_ptr) : boolean;
var
coef : my_coef_ptr;
smoothing_useful : boolean;
ci, coefi : int;
compptr : jpeg_component_info_ptr;
qtable : JQUANT_TBL_PTR;
coef_bits : coef_bits_ptr;
coef_bits_latch : Latch_Ptr;
begin
coef := my_coef_ptr (cinfo^.coef);
smoothing_useful := FALSE;
if (not cinfo^.progressive_mode) or (cinfo^.coef_bits = NIL) then
begin
smoothing_ok := FALSE;
exit;
end;
{ Allocate latch area if not already done }
if (coef^.coef_bits_latch = NIL) then
coef^.coef_bits_latch := Latch_Ptr(
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
cinfo^.num_components *
(SAVED_COEFS * SIZEOF(int))) );
coef_bits_latch := (coef^.coef_bits_latch);
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ All components' quantization values must already be latched. }
qtable := compptr^.quant_table;
if (qtable = NIL) then
begin
smoothing_ok := FALSE;
exit;
end;
{ Verify DC & first 5 AC quantizers are nonzero to avoid zero-divide. }
if (qtable^.quantval[0] = 0) or
(qtable^.quantval[Q01_POS] = 0) or
(qtable^.quantval[Q10_POS] = 0) or
(qtable^.quantval[Q20_POS] = 0) or
(qtable^.quantval[Q11_POS] = 0) or
(qtable^.quantval[Q02_POS] = 0) then
begin
smoothing_ok := FALSE;
exit;
end;
{ DC values must be at least partly known for all components. }
coef_bits := @cinfo^.coef_bits^[ci]; { Nomssi }
if (coef_bits^[0] < 0) then
begin
smoothing_ok := FALSE;
exit;
end;
{ Block smoothing is helpful if some AC coefficients remain inaccurate. }
for coefi := 1 to 5 do
begin
coef_bits_latch^[coefi] := coef_bits^[coefi];
if (coef_bits^[coefi] <> 0) then
smoothing_useful := TRUE;
end;
Inc(coef_bits_latch {SAVED_COEFS});
Inc(compptr);
end;
smoothing_ok := smoothing_useful;
end;
{ Variant of decompress_data for use when doing block smoothing. }
{METHODDEF}
function decompress_smooth_data (cinfo : j_decompress_ptr;
output_buf : JSAMPIMAGE) : int;
var
coef : my_coef_ptr;
last_iMCU_row : JDIMENSION;
block_num, last_block_column : JDIMENSION;
ci, block_row, block_rows, access_rows : int;
buffer : JBLOCKARRAY;
buffer_ptr, prev_block_row, next_block_row : JBLOCKROW;
output_ptr : JSAMPARRAY;
output_col : JDIMENSION;
compptr : jpeg_component_info_ptr;
inverse_DCT : inverse_DCT_method_ptr;
first_row, last_row : boolean;
workspace : JBLOCK;
coef_bits : Latch_Ptr; { coef_bits_ptr; }
quanttbl : JQUANT_TBL_PTR;
Q00,Q01,Q02,Q10,Q11,Q20, num : INT32;
DC1,DC2,DC3,DC4,DC5,DC6,DC7,DC8,DC9 : int;
Al, pred : int;
var
delta : JDIMENSION;
begin
coef := my_coef_ptr (cinfo^.coef);
last_iMCU_row := cinfo^.total_iMCU_rows - 1;
{ Force some input to be done if we are getting ahead of the input. }
while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and
(not cinfo^.inputctl^.eoi_reached) do
begin
if (cinfo^.input_scan_number = cinfo^.output_scan_number) then
begin
{ If input is working on current scan, we ordinarily want it to
have completed the current row. But if input scan is DC,
we want it to keep one row ahead so that next block row's DC
values are up to date. }
if (cinfo^.Ss = 0) then
delta := 1
else
delta := 0;
if (LongInt(cinfo^.input_iMCU_row) > cinfo^.output_iMCU_row+LongInt(delta)) then
break;
end;
if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then
begin
decompress_smooth_data := JPEG_SUSPENDED;
exit;
end;
end;
{ OK, output from the virtual arrays. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to (cinfo^.num_components-1) do
begin
{ Don't bother to IDCT an uninteresting component. }
if (not compptr^.component_needed) then
continue;
{ Count non-dummy DCT block rows in this iMCU row. }
if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then
begin
block_rows := compptr^.v_samp_factor;
access_rows := block_rows * 2; { this and next iMCU row }
last_row := FALSE;
end
else
begin
{ NB: can't use last_row_height here; it is input-side-dependent! }
block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor;
if (block_rows = 0) then
block_rows := compptr^.v_samp_factor;
access_rows := block_rows; { this iMCU row only }
last_row := TRUE;
end;
{ Align the virtual buffer for this component. }
if (cinfo^.output_iMCU_row > 0) then
begin
Inc(access_rows, compptr^.v_samp_factor); { prior iMCU row too }
buffer := cinfo^.mem^.access_virt_barray
(j_common_ptr (cinfo), coef^.whole_image[ci],
(cinfo^.output_iMCU_row - 1) * compptr^.v_samp_factor,
JDIMENSION (access_rows), FALSE);
Inc(JBLOCKROW_PTR(buffer), compptr^.v_samp_factor); { point to current iMCU row }
first_row := FALSE;
end
else
begin
buffer := cinfo^.mem^.access_virt_barray
(j_common_ptr (cinfo), coef^.whole_image[ci],
JDIMENSION (0), JDIMENSION (access_rows), FALSE);
first_row := TRUE;
end;
{ Fetch component-dependent info }
coef_bits := coef^.coef_bits_latch;
Inc(coef_bits, ci); { ci * SAVED_COEFS}
quanttbl := compptr^.quant_table;
Q00 := quanttbl^.quantval[0];
Q01 := quanttbl^.quantval[Q01_POS];
Q10 := quanttbl^.quantval[Q10_POS];
Q20 := quanttbl^.quantval[Q20_POS];
Q11 := quanttbl^.quantval[Q11_POS];
Q02 := quanttbl^.quantval[Q02_POS];
inverse_DCT := cinfo^.idct^.inverse_DCT[ci];
output_ptr := output_buf^[ci];
{ Loop over all DCT blocks to be processed. }
for block_row := 0 to (block_rows-1) do
begin
buffer_ptr := buffer^[block_row];
if (first_row) and (block_row = 0) then
prev_block_row := buffer_ptr
else
prev_block_row := buffer^[block_row-1];
if (last_row) and (block_row = block_rows-1) then
next_block_row := buffer_ptr
else
next_block_row := buffer^[block_row+1];
{ We fetch the surrounding DC values using a sliding-register approach.
Initialize all nine here so as to do the right thing on narrow pics.}
DC3 := int(prev_block_row^[0][0]);
DC2 := DC3;
DC1 := DC2;
DC6 := int(buffer_ptr^[0][0]);
DC5 := DC6;
DC4 := DC5;
DC9 := int(next_block_row^[0][0]);
DC8 := DC9;
DC7 := DC8 ;
output_col := 0;
last_block_column := compptr^.width_in_blocks - 1;
for block_num := 0 to last_block_column do
begin
{ Fetch current DCT block into workspace so we can modify it. }
jcopy_block_row(buffer_ptr, JBLOCKROW (@workspace), JDIMENSION(1));
{ Update DC values }
if (block_num < last_block_column) then
begin
DC3 := int (prev_block_row^[1][0]);
DC6 := int (buffer_ptr^[1][0]);
DC9 := int (next_block_row^[1][0]);
end;
{ Compute coefficient estimates per K.8.
An estimate is applied only if coefficient is still zero,
and is not known to be fully accurate. }
{ AC01 }
Al := coef_bits^[1];
if (Al <> 0) and (workspace[1] = 0) then
begin
num := 36 * Q00 * (DC4 - DC6);
if (num >= 0) then
begin
pred := int (((Q01 shl 7) + num) div (Q01 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
end
else
begin
pred := int (((Q01 shl 7) - num) div (Q01 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
pred := -pred;
end;
workspace[1] := JCOEF (pred);
end;
{ AC10 }
Al := coef_bits^[2];
if (Al <> 0) and (workspace[8] = 0) then
begin
num := 36 * Q00 * (DC2 - DC8);
if (num >= 0) then
begin
pred := int (((Q10 shl 7) + num) div (Q10 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
end
else
begin
pred := int (((Q10 shl 7) - num) div (Q10 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
pred := -pred;
end;
workspace[8] := JCOEF (pred);
end;
{ AC20 }
Al := coef_bits^[3];
if (Al <> 0) and (workspace[16] = 0) then
begin
num := 9 * Q00 * (DC2 + DC8 - 2*DC5);
if (num >= 0) then
begin
pred := int (((Q20 shl 7) + num) div (Q20 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
end
else
begin
pred := int (((Q20 shl 7) - num) div (Q20 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
pred := -pred;
end;
workspace[16] := JCOEF (pred);
end;
{ AC11 }
Al := coef_bits^[4];
if (Al <> 0) and (workspace[9] = 0) then
begin
num := 5 * Q00 * (DC1 - DC3 - DC7 + DC9);
if (num >= 0) then
begin
pred := int (((Q11 shl 7) + num) div (Q11 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
end
else
begin
pred := int (((Q11 shl 7) - num) div (Q11 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
pred := -pred;
end;
workspace[9] := JCOEF (pred);
end;
{ AC02 }
Al := coef_bits^[5];
if (Al <> 0) and (workspace[2] = 0) then
begin
num := 9 * Q00 * (DC4 + DC6 - 2*DC5);
if (num >= 0) then
begin
pred := int (((Q02 shl 7) + num) div (Q02 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
end
else
begin
pred := int (((Q02 shl 7) - num) div (Q02 shl 8));
if (Al > 0) and (pred >= (1 shl Al)) then
pred := (1 shl Al)-1;
pred := -pred;
end;
workspace[2] := JCOEF (pred);
end;
{ OK, do the IDCT }
inverse_DCT (cinfo, compptr, JCOEFPTR (@workspace),
output_ptr, output_col);
{ Advance for next column }
DC1 := DC2; DC2 := DC3;
DC4 := DC5; DC5 := DC6;
DC7 := DC8; DC8 := DC9;
Inc(JBLOCK_PTR(buffer_ptr));
Inc(JBLOCK_PTR(prev_block_row));
Inc(JBLOCK_PTR(next_block_row));
Inc(output_col, compptr^.DCT_scaled_size);
end;
Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size);
end;
Inc(compptr);
end;
Inc(cinfo^.output_iMCU_row);
if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then
begin
decompress_smooth_data := JPEG_ROW_COMPLETED;
exit;
end;
decompress_smooth_data := JPEG_SCAN_COMPLETED;
end;
{$endif} { BLOCK_SMOOTHING_SUPPORTED }
{ Initialize coefficient buffer controller. }
{GLOBAL}
procedure jinit_d_coef_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
var
coef : my_coef_ptr;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
var
ci, access_rows : int;
compptr : jpeg_component_info_ptr;
{$endif}
var
buffer : JBLOCK_PTR;
i : int;
begin
coef := my_coef_ptr(
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
SIZEOF(my_coef_controller)) );
cinfo^.coef := jpeg_d_coef_controller_ptr(coef);
coef^.pub.start_input_pass := start_input_pass;
coef^.pub.start_output_pass := start_output_pass;
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
coef^.coef_bits_latch := NIL;
{$endif}
{ Create the coefficient buffer. }
if (need_full_buffer) then
begin
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Allocate a full-image virtual array for each component, }
{ padded to a multiple of samp_factor DCT blocks in each direction. }
{ Note we ask for a pre-zeroed array. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
access_rows := compptr^.v_samp_factor;
{$ifdef BLOCK_SMOOTHING_SUPPORTED}
{ If block smoothing could be used, need a bigger window }
if (cinfo^.progressive_mode) then
access_rows := access_rows * 3;
{$endif}
coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray
(j_common_ptr (cinfo), JPOOL_IMAGE, TRUE,
JDIMENSION (jround_up( long(compptr^.width_in_blocks),
long(compptr^.h_samp_factor) )),
JDIMENSION (jround_up( long(compptr^.height_in_blocks),
long(compptr^.v_samp_factor) )),
JDIMENSION (access_rows));
Inc(compptr);
end;
coef^.pub.consume_data := consume_data;
coef^.pub.decompress_data := decompress_data;
coef^.pub.coef_arrays := @(coef^.whole_image);
{ link to virtual arrays }
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
{ We only need a single-MCU buffer. }
buffer := JBLOCK_PTR (
cinfo^.mem^.alloc_large (j_common_ptr (cinfo), JPOOL_IMAGE,
D_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) );
for i := 0 to pred(D_MAX_BLOCKS_IN_MCU) do
begin
coef^.MCU_buffer[i] := JBLOCKROW(buffer);
Inc(buffer);
end;
coef^.pub.consume_data := dummy_consume_data;
coef^.pub.decompress_data := decompress_onepass;
coef^.pub.coef_arrays := NIL; { flag for no virtual arrays }
end;
end;
end.

501
Imaging/JpegLib/imjdcolor.pas Normal file
View File

@@ -0,0 +1,501 @@
unit imjdcolor;
{ This file contains output colorspace conversion routines. }
{ Original: jdcolor.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjdeferr,
imjerror,
imjpeglib;
{ Module initialization routine for output colorspace conversion. }
{GLOBAL}
procedure jinit_color_deconverter (cinfo : j_decompress_ptr);
implementation
{ Private subobject }
type
int_Color_Table = array[0..MAXJSAMPLE+1-1] of int;
int_table_ptr = ^int_Color_Table;
INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32;
INT32_table_ptr = ^INT32_Color_Table;
type
my_cconvert_ptr = ^my_color_deconverter;
my_color_deconverter = record
pub : jpeg_color_deconverter; { public fields }
{ Private state for YCC^.RGB conversion }
Cr_r_tab : int_table_ptr; { => table for Cr to R conversion }
Cb_b_tab : int_table_ptr; { => table for Cb to B conversion }
Cr_g_tab : INT32_table_ptr; { => table for Cr to G conversion }
Cb_g_tab : INT32_table_ptr; { => table for Cb to G conversion }
end;
{*************** YCbCr ^. RGB conversion: most common case *************}
{ YCbCr is defined per CCIR 601-1, except that Cb and Cr are
normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5.
The conversion equations to be implemented are therefore
R = Y + 1.40200 * Cr
G = Y - 0.34414 * Cb - 0.71414 * Cr
B = Y + 1.77200 * Cb
where Cb and Cr represent the incoming values less CENTERJSAMPLE.
(These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.)
To avoid floating-point arithmetic, we represent the fractional constants
as integers scaled up by 2^16 (about 4 digits precision); we have to divide
the products by 2^16, with appropriate rounding, to get the correct answer.
Notice that Y, being an integral input, does not contribute any fraction
so it need not participate in the rounding.
For even more speed, we avoid doing any multiplications in the inner loop
by precalculating the constants times Cb and Cr for all possible values.
For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table);
for 12-bit samples it is still acceptable. It's not very reasonable for
16-bit samples, but if you want lossless storage you shouldn't be changing
colorspace anyway.
The Cr=>R and Cb=>B values can be rounded to integers in advance; the
values for the G calculation are left scaled up, since we must add them
together before rounding. }
const
SCALEBITS = 16; { speediest right-shift on some machines }
ONE_HALF = (INT32(1) shl (SCALEBITS-1));
{ Initialize tables for YCC->RGB colorspace conversion. }
{LOCAL}
procedure build_ycc_rgb_table (cinfo : j_decompress_ptr);
const
FIX_1_40200 = INT32(Round( 1.40200 * (1 shl SCALEBITS)));
FIX_1_77200 = INT32(Round( 1.77200 * (1 shl SCALEBITS)));
FIX_0_71414 = INT32(Round( 0.71414 * (1 shl SCALEBITS)));
FIX_0_34414 = INT32(Round( 0.34414 * (1 shl SCALEBITS)));
var
cconvert : my_cconvert_ptr;
i : int;
x : INT32;
var
shift_temp : INT32;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
cconvert^.Cr_r_tab := int_table_ptr(
cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(int)) );
cconvert^.Cb_b_tab := int_table_ptr (
cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(int)) );
cconvert^.Cr_g_tab := INT32_table_ptr (
cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(INT32)) );
cconvert^.Cb_g_tab := INT32_table_ptr (
cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(INT32)) );
x := -CENTERJSAMPLE;
for i := 0 to MAXJSAMPLE do
begin
{ i is the actual input pixel value, in the range 0..MAXJSAMPLE }
{ The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE }
{ Cr=>R value is nearest int to 1.40200 * x }
shift_temp := FIX_1_40200 * x + ONE_HALF;
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cconvert^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cconvert^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS);
{ Cb=>B value is nearest int to 1.77200 * x }
shift_temp := FIX_1_77200 * x + ONE_HALF;
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cconvert^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cconvert^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS);
{ Cr=>G value is scaled-up -0.71414 * x }
cconvert^.Cr_g_tab^[i] := (- FIX_0_71414 ) * x;
{ Cb=>G value is scaled-up -0.34414 * x }
{ We also add in ONE_HALF so that need not do it in inner loop }
cconvert^.Cb_g_tab^[i] := (- FIX_0_34414 ) * x + ONE_HALF;
Inc(x);
end;
end;
{ Convert some rows of samples to the output colorspace.
Note that we change from noninterleaved, one-plane-per-component format
to interleaved-pixel format. The output buffer is therefore three times
as wide as the input buffer.
A starting row offset is provided only for the input buffer. The caller
can easily adjust the passed output_buf value to accommodate any row
offset required on that side. }
{METHODDEF}
procedure ycc_rgb_convert (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
input_row : JDIMENSION;
output_buf : JSAMPARRAY;
num_rows : int);
var
cconvert : my_cconvert_ptr;
{register} y, cb, cr : int;
{register} outptr : JSAMPROW;
{register} inptr0, inptr1, inptr2 : JSAMPROW;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
{ copy these pointers into registers if possible }
{register} range_limit : range_limit_table_ptr;
{register} Crrtab : int_table_ptr;
{register} Cbbtab : int_table_ptr;
{register} Crgtab : INT32_table_ptr;
{register} Cbgtab : INT32_table_ptr;
var
shift_temp : INT32;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
num_cols := cinfo^.output_width;
range_limit := cinfo^.sample_range_limit;
Crrtab := cconvert^.Cr_r_tab;
Cbbtab := cconvert^.Cb_b_tab;
Crgtab := cconvert^.Cr_g_tab;
Cbgtab := cconvert^.Cb_g_tab;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr0 := input_buf^[0]^[input_row];
inptr1 := input_buf^[1]^[input_row];
inptr2 := input_buf^[2]^[input_row];
Inc(input_row);
outptr := output_buf^[0];
Inc(JSAMPROW_PTR(output_buf));
for col := 0 to pred(num_cols) do
begin
y := GETJSAMPLE(inptr0^[col]);
cb := GETJSAMPLE(inptr1^[col]);
cr := GETJSAMPLE(inptr2^[col]);
{ Range-limiting is essential due to noise introduced by DCT losses. }
outptr^[RGB_RED] := range_limit^[y + Crrtab^[cr]];
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
outptr^[RGB_GREEN] := range_limit^[y + int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))]
else
outptr^[RGB_GREEN] := range_limit^[y + int(shift_temp shr SCALEBITS)];
outptr^[RGB_BLUE] := range_limit^[y + Cbbtab^[cb]];
Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE);
end;
end;
end;
{*************** Cases other than YCbCr -> RGB *************}
{ Color conversion for no colorspace change: just copy the data,
converting from separate-planes to interleaved representation. }
{METHODDEF}
procedure null_convert (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
input_row : JDIMENSION;
output_buf : JSAMPARRAY;
num_rows : int);
var
{register} inptr,
outptr : JSAMPLE_PTR;
{register} count : JDIMENSION;
{register} num_components : int;
num_cols : JDIMENSION;
ci : int;
begin
num_components := cinfo^.num_components;
num_cols := cinfo^.output_width;
while (num_rows > 0) do
begin
Dec(num_rows);
for ci := 0 to pred(num_components) do
begin
inptr := JSAMPLE_PTR(input_buf^[ci]^[input_row]);
outptr := JSAMPLE_PTR(@(output_buf^[0]^[ci]));
for count := pred(num_cols) downto 0 do
begin
outptr^ := inptr^; { needn't bother with GETJSAMPLE() here }
Inc(inptr);
Inc(outptr, num_components);
end;
end;
Inc(input_row);
Inc(JSAMPROW_PTR(output_buf));
end;
end;
{ Color conversion for grayscale: just copy the data.
This also works for YCbCr -> grayscale conversion, in which
we just copy the Y (luminance) component and ignore chrominance. }
{METHODDEF}
procedure grayscale_convert (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
input_row : JDIMENSION;
output_buf : JSAMPARRAY;
num_rows : int);
begin
jcopy_sample_rows(input_buf^[0], int(input_row), output_buf, 0,
num_rows, cinfo^.output_width);
end;
{ Convert grayscale to RGB: just duplicate the graylevel three times.
This is provided to support applications that don't want to cope
with grayscale as a separate case. }
{METHODDEF}
procedure gray_rgb_convert (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
input_row : JDIMENSION;
output_buf : JSAMPARRAY;
num_rows : int);
var
{register} inptr, outptr : JSAMPLE_PTR;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
begin
num_cols := cinfo^.output_width;
while (num_rows > 0) do
begin
inptr := JSAMPLE_PTR(input_buf^[0]^[input_row]);
Inc(input_row);
outptr := JSAMPLE_PTR(@output_buf^[0]);
Inc(JSAMPROW_PTR(output_buf));
for col := 0 to pred(num_cols) do
begin
{ We can dispense with GETJSAMPLE() here }
JSAMPROW(outptr)^[RGB_RED] := inptr^;
JSAMPROW(outptr)^[RGB_GREEN] := inptr^;
JSAMPROW(outptr)^[RGB_BLUE] := inptr^;
Inc(inptr);
Inc(outptr, RGB_PIXELSIZE);
end;
Dec(num_rows);
end;
end;
{ Adobe-style YCCK -> CMYK conversion.
We convert YCbCr to R=1-C, G=1-M, and B=1-Y using the same
conversion as above, while passing K (black) unchanged.
We assume build_ycc_rgb_table has been called. }
{METHODDEF}
procedure ycck_cmyk_convert (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
input_row : JDIMENSION;
output_buf : JSAMPARRAY;
num_rows : int);
var
cconvert : my_cconvert_ptr;
{register} y, cb, cr : int;
{register} outptr : JSAMPROW;
{register} inptr0, inptr1, inptr2, inptr3 : JSAMPROW;
{register} col : JDIMENSION;
num_cols : JDIMENSION;
{ copy these pointers into registers if possible }
{register} range_limit : range_limit_table_ptr;
{register} Crrtab : int_table_ptr;
{register} Cbbtab : int_table_ptr;
{register} Crgtab : INT32_table_ptr;
{register} Cbgtab : INT32_table_ptr;
var
shift_temp : INT32;
begin
cconvert := my_cconvert_ptr (cinfo^.cconvert);
num_cols := cinfo^.output_width;
{ copy these pointers into registers if possible }
range_limit := cinfo^.sample_range_limit;
Crrtab := cconvert^.Cr_r_tab;
Cbbtab := cconvert^.Cb_b_tab;
Crgtab := cconvert^.Cr_g_tab;
Cbgtab := cconvert^.Cb_g_tab;
while (num_rows > 0) do
begin
Dec(num_rows);
inptr0 := input_buf^[0]^[input_row];
inptr1 := input_buf^[1]^[input_row];
inptr2 := input_buf^[2]^[input_row];
inptr3 := input_buf^[3]^[input_row];
Inc(input_row);
outptr := output_buf^[0];
Inc(JSAMPROW_PTR(output_buf));
for col := 0 to pred(num_cols) do
begin
y := GETJSAMPLE(inptr0^[col]);
cb := GETJSAMPLE(inptr1^[col]);
cr := GETJSAMPLE(inptr2^[col]);
{ Range-limiting is essential due to noise introduced by DCT losses. }
outptr^[0] := range_limit^[MAXJSAMPLE - (y + Crrtab^[cr])]; { red }
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then
outptr^[1] := range_limit^[MAXJSAMPLE - (y + int(
(shift_temp shr SCALEBITS) or ((not INT32(0)) shl (32-SCALEBITS))
) )]
else
outptr^[1] := range_limit^[MAXJSAMPLE - { green }
(y + int(shift_temp shr SCALEBITS) )];
outptr^[2] := range_limit^[MAXJSAMPLE - (y + Cbbtab^[cb])]; { blue }
{ K passes through unchanged }
outptr^[3] := inptr3^[col]; { don't need GETJSAMPLE here }
Inc(JSAMPLE_PTR(outptr), 4);
end;
end;
end;
{ Empty method for start_pass. }
{METHODDEF}
procedure start_pass_dcolor (cinfo : j_decompress_ptr);
begin
{ no work needed }
end;
{ Module initialization routine for output colorspace conversion. }
{GLOBAL}
procedure jinit_color_deconverter (cinfo : j_decompress_ptr);
var
cconvert : my_cconvert_ptr;
ci : int;
begin
cconvert := my_cconvert_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_color_deconverter)) );
cinfo^.cconvert := jpeg_color_deconverter_ptr (cconvert);
cconvert^.pub.start_pass := start_pass_dcolor;
{ Make sure num_components agrees with jpeg_color_space }
case (cinfo^.jpeg_color_space) of
JCS_GRAYSCALE:
if (cinfo^.num_components <> 1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
JCS_RGB,
JCS_YCbCr:
if (cinfo^.num_components <> 3) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
JCS_CMYK,
JCS_YCCK:
if (cinfo^.num_components <> 4) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
else { JCS_UNKNOWN can be anything }
if (cinfo^.num_components < 1) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
end;
{ Set out_color_components and conversion method based on requested space.
Also clear the component_needed flags for any unused components,
so that earlier pipeline stages can avoid useless computation. }
case (cinfo^.out_color_space) of
JCS_GRAYSCALE:
begin
cinfo^.out_color_components := 1;
if (cinfo^.jpeg_color_space = JCS_GRAYSCALE)
or (cinfo^.jpeg_color_space = JCS_YCbCr) then
begin
cconvert^.pub.color_convert := grayscale_convert;
{ For color -> grayscale conversion, only the
Y (0) component is needed }
for ci := 1 to pred(cinfo^.num_components) do
cinfo^.comp_info^[ci].component_needed := FALSE;
end
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_RGB:
begin
cinfo^.out_color_components := RGB_PIXELSIZE;
if (cinfo^.jpeg_color_space = JCS_YCbCr) then
begin
cconvert^.pub.color_convert := ycc_rgb_convert;
build_ycc_rgb_table(cinfo);
end
else
if (cinfo^.jpeg_color_space = JCS_GRAYSCALE) then
begin
cconvert^.pub.color_convert := gray_rgb_convert;
end
else
if (cinfo^.jpeg_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then
begin
cconvert^.pub.color_convert := null_convert;
end
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
JCS_CMYK:
begin
cinfo^.out_color_components := 4;
if (cinfo^.jpeg_color_space = JCS_YCCK) then
begin
cconvert^.pub.color_convert := ycck_cmyk_convert;
build_ycc_rgb_table(cinfo);
end
else
if (cinfo^.jpeg_color_space = JCS_CMYK) then
begin
cconvert^.pub.color_convert := null_convert;
end
else
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
else
begin { Permit null conversion to same output space }
if (cinfo^.out_color_space = cinfo^.jpeg_color_space) then
begin
cinfo^.out_color_components := cinfo^.num_components;
cconvert^.pub.color_convert := null_convert;
end
else { unsupported non-null conversion }
ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL);
end;
end;
if (cinfo^.quantize_colors) then
cinfo^.output_components := 1 { single colormapped output component }
else
cinfo^.output_components := cinfo^.out_color_components;
end;
end.

109
Imaging/JpegLib/imjdct.pas Normal file
View File

@@ -0,0 +1,109 @@
unit imjdct;
{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This include file contains common declarations for the forward and
inverse DCT modules. These declarations are private to the DCT managers
(jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms.
The individual DCT algorithms are kept in separate files to ease
machine-dependent tuning (e.g., assembly coding). }
interface
{$I imjconfig.inc}
uses
imjmorecfg;
{ A forward DCT routine is given a pointer to a work area of type DCTELEM[];
the DCT is to be performed in-place in that buffer. Type DCTELEM is int
for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT
implementations use an array of type FAST_FLOAT, instead.)
The DCT inputs are expected to be signed (range +-CENTERJSAMPLE).
The DCT outputs are returned scaled up by a factor of 8; they therefore
have a range of +-8K for 8-bit data, +-128K for 12-bit data. This
convention improves accuracy in integer implementations and saves some
work in floating-point ones.
Quantization of the output coefficients is done by jcdctmgr.c. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
DCTELEM = int; { 16 or 32 bits is fine }
{$else}
type { must have 32 bits }
DCTELEM = INT32;
{$endif}
type
jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1;
DCTELEM_FIELD = array[jTDctElem] of DCTELEM;
DCTELEM_FIELD_PTR = ^DCTELEM_FIELD;
DCTELEMPTR = ^DCTELEM;
type
forward_DCT_method_ptr = procedure(var data : array of DCTELEM);
float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT);
{ An inverse DCT routine is given a pointer to the input JBLOCK and a pointer
to an output sample array. The routine must dequantize the input data as
well as perform the IDCT; for dequantization, it uses the multiplier table
pointed to by compptr->dct_table. The output data is to be placed into the
sample array starting at a specified column. (Any row offset needed will
be applied to the array pointer before it is passed to the IDCT code.)
Note that the number of samples emitted by the IDCT routine is
DCT_scaled_size * DCT_scaled_size. }
{ typedef inverse_DCT_method_ptr is declared in jpegint.h }
{ Each IDCT routine has its own ideas about the best dct_table element type. }
type
ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster }
{$ifdef BITS_IN_JSAMPLE_IS_8}
type
IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster }
const
IFAST_SCALE_BITS = 2; { fractional bits in scale factors }
{$else}
type
IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers }
const
IFAST_SCALE_BITS = 13; { fractional bits in scale factors }
{$endif}
type
FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type }
const
RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples }
type
jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1;
ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE;
ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD;
ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE;
jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1;
FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE;
FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD;
FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE;
jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1;
IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE;
IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD;
IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE;
type
jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1;
FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT;
FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD;
FAST_FLOAT_PTR = ^FAST_FLOAT;
implementation
end.

330
Imaging/JpegLib/imjddctmgr.pas Normal file
View File

@@ -0,0 +1,330 @@
unit imjddctmgr;
{ Original : jddctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the inverse-DCT management logic.
This code selects a particular IDCT implementation to be used,
and it performs related housekeeping chores. No code in this file
is executed per IDCT step, only during output pass setup.
Note that the IDCT routines are responsible for performing coefficient
dequantization as well as the IDCT proper. This module sets up the
dequantization multiplier table needed by the IDCT routine. }
interface
{$I imjconfig.inc}
{$N+}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjpeglib,
imjdct, { Private declarations for DCT subsystem }
imjidctfst,
{$IFDEF BASM}
imjidctasm,
{$ELSE}
imjidctint,
{$ENDIF}
imjidctflt,
imjidctred;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
implementation
{ The decompressor input side (jdinput.c) saves away the appropriate
quantization table for each component at the start of the first scan
involving that component. (This is necessary in order to correctly
decode files that reuse Q-table slots.)
When we are ready to make an output pass, the saved Q-table is converted
to a multiplier table that will actually be used by the IDCT routine.
The multiplier table contents are IDCT-method-dependent. To support
application changes in IDCT method between scans, we can remake the
multiplier tables if necessary.
In buffered-image mode, the first output pass may occur before any data
has been seen for some components, and thus before their Q-tables have
been saved away. To handle this case, multiplier tables are preset
to zeroes; the result of the IDCT will be a neutral gray level. }
{ Private subobject for this module }
type
my_idct_ptr = ^my_idct_controller;
my_idct_controller = record
pub : jpeg_inverse_dct; { public fields }
{ This array contains the IDCT method code that each multiplier table
is currently set up for, or -1 if it's not yet set up.
The actual multiplier tables are pointed to by dct_table in the
per-component comp_info structures. }
cur_method : array[0..MAX_COMPONENTS-1] of int;
end; {my_idct_controller;}
{ Allocated multiplier tables: big enough for any supported variant }
type
multiplier_table = record
case byte of
0:(islow_array : array[0..DCTSIZE2-1] of ISLOW_MULT_TYPE);
{$ifdef DCT_IFAST_SUPPORTED}
1:(ifast_array : array[0..DCTSIZE2-1] of IFAST_MULT_TYPE);
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
2:(float_array : array[0..DCTSIZE2-1] of FLOAT_MULT_TYPE);
{$endif}
end;
{ The current scaled-IDCT routines require ISLOW-style multiplier tables,
so be sure to compile that code if either ISLOW or SCALING is requested. }
{$ifdef DCT_ISLOW_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$else}
{$ifdef IDCT_SCALING_SUPPORTED}
{$define PROVIDE_ISLOW_TABLES}
{$endif}
{$endif}
{ Prepare for an output pass.
Here we select the proper IDCT routine for each component and build
a matching multiplier table. }
{METHODDEF}
procedure start_pass (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci, i : int;
compptr : jpeg_component_info_ptr;
method : J_DCT_METHOD;
method_ptr : inverse_DCT_method_ptr;
qtbl : JQUANT_TBL_PTR;
{$ifdef PROVIDE_ISLOW_TABLES}
var
ismtbl : ISLOW_MULT_TYPE_FIELD_PTR;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
const
CONST_BITS = 14;
const
aanscales : array[0..DCTSIZE2-1] of INT16 =
({ precomputed values scaled up by 14 bits }
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270,
21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906,
19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315,
16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520,
12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552,
8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446,
4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247);
var
ifmtbl : IFAST_MULT_TYPE_FIELD_PTR;
{SHIFT_TEMPS}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
const
aanscalefactor : array[0..DCTSIZE-1] of double =
(1.0, 1.387039845, 1.306562965, 1.175875602,
1.0, 0.785694958, 0.541196100, 0.275899379);
var
fmtbl : FLOAT_MULT_TYPE_FIELD_PTR;
row, col : int;
{$endif}
begin
idct := my_idct_ptr (cinfo^.idct);
method := J_DCT_METHOD(0);
method_ptr := NIL;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Select the proper IDCT routine for this component's scaling }
case (compptr^.DCT_scaled_size) of
{$ifdef IDCT_SCALING_SUPPORTED}
1:begin
method_ptr := jpeg_idct_1x1;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
2:begin
method_ptr := jpeg_idct_2x2;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
4:begin
method_ptr := jpeg_idct_4x4;
method := JDCT_ISLOW; { jidctred uses islow-style table }
end;
{$endif}
DCTSIZE:
case (cinfo^.dct_method) of
{$ifdef DCT_ISLOW_SUPPORTED}
JDCT_ISLOW:
begin
method_ptr := @jpeg_idct_islow;
method := JDCT_ISLOW;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
method_ptr := @jpeg_idct_ifast;
method := JDCT_IFAST;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
method_ptr := @jpeg_idct_float;
method := JDCT_FLOAT;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
end;
else
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_DCTSIZE, compptr^.DCT_scaled_size);
end;
idct^.pub.inverse_DCT[ci] := method_ptr;
{ Create multiplier table from quant table.
However, we can skip this if the component is uninteresting
or if we already built the table. Also, if no quant table
has yet been saved for the component, we leave the
multiplier table all-zero; we'll be reading zeroes from the
coefficient controller's buffer anyway. }
if (not compptr^.component_needed) or (idct^.cur_method[ci] = int(method)) then
continue;
qtbl := compptr^.quant_table;
if (qtbl = NIL) then { happens if no data yet for component }
continue;
idct^.cur_method[ci] := int(method);
case (method) of
{$ifdef PROVIDE_ISLOW_TABLES}
JDCT_ISLOW:
begin
{ For LL&M IDCT method, multipliers are equal to raw quantization
coefficients, but are stored as ints to ensure access efficiency. }
ismtbl := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ismtbl^[i] := ISLOW_MULT_TYPE (qtbl^.quantval[i]);
end;
end;
{$endif}
{$ifdef DCT_IFAST_SUPPORTED}
JDCT_IFAST:
begin
{ For AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7
For integer operation, the multiplier table is to be scaled by
IFAST_SCALE_BITS. }
ifmtbl := IFAST_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
for i := 0 to pred(DCTSIZE2) do
begin
ifmtbl^[i] := IFAST_MULT_TYPE(
DESCALE( INT32 (qtbl^.quantval[i]) * INT32 (aanscales[i]),
CONST_BITS-IFAST_SCALE_BITS) );
end;
end;
{$endif}
{$ifdef DCT_FLOAT_SUPPORTED}
JDCT_FLOAT:
begin
{ For float AA&N IDCT method, multipliers are equal to quantization
coefficients scaled by scalefactor[row]*scalefactor[col], where
scalefactor[0] := 1
scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 }
fmtbl := FLOAT_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
i := 0;
for row := 0 to pred(DCTSIZE) do
begin
for col := 0 to pred(DCTSIZE) do
begin
fmtbl^[i] := {FLOAT_MULT_TYPE} (
{double} qtbl^.quantval[i] *
aanscalefactor[row] * aanscalefactor[col] );
Inc(i);
end;
end;
end;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
break;
end;
Inc(compptr);
end;
end;
{ Initialize IDCT manager. }
{GLOBAL}
procedure jinit_inverse_dct (cinfo : j_decompress_ptr);
var
idct : my_idct_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
begin
idct := my_idct_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_idct_controller)) );
cinfo^.idct := jpeg_inverse_dct_ptr (idct);
idct^.pub.start_pass := start_pass;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Allocate and pre-zero a multiplier table for each component }
compptr^.dct_table :=
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(multiplier_table));
MEMZERO(compptr^.dct_table, SIZEOF(multiplier_table));
{ Mark multiplier table not yet set up for any method }
idct^.cur_method[ci] := -1;
Inc(compptr);
end;
end;
end.

497
Imaging/JpegLib/imjdeferr.pas Normal file
View File

@@ -0,0 +1,497 @@
unit imjdeferr;
{ This file defines the error and message codes for the cjpeg/djpeg
applications. These strings are not needed as part of the JPEG library
proper.
Edit this file to add new codes, or to translate the message strings to
some other language. }
{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ To define the enum list of message codes, include this file without
defining macro JMESSAGE. To create a message string table, include it
again with a suitable JMESSAGE definition (see jerror.c for an example). }
{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. }
{ This file contains software version identification. }
const
JVERSION = '6a 7-Feb-96';
JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane';
JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali';
{ Create the message string table.
We do this from the master message list in jerror.h by re-reading
jerror.h with a suitable definition for macro JMESSAGE.
The message table is made an external symbol just in case any applications
want to refer to it directly. }
type
J_MESSAGE_CODE =(
JMSG_NOMESSAGE,
JERR_ARITH_NOTIMPL,
JERR_BAD_ALIGN_TYPE,
JERR_BAD_ALLOC_CHUNK,
JERR_BAD_BUFFER_MODE,
JERR_BAD_COMPONENT_ID,
JERR_BAD_DCT_COEF,
JERR_BAD_DCTSIZE,
JERR_BAD_HUFF_TABLE,
JERR_BAD_IN_COLORSPACE,
JERR_BAD_J_COLORSPACE,
JERR_BAD_LENGTH,
JERR_BAD_LIB_VERSION,
JERR_BAD_MCU_SIZE,
JERR_BAD_POOL_ID,
JERR_BAD_PRECISION,
JERR_BAD_PROGRESSION,
JERR_BAD_PROG_SCRIPT,
JERR_BAD_SAMPLING,
JERR_BAD_SCAN_SCRIPT,
JERR_BAD_STATE,
JERR_BAD_STRUCT_SIZE,
JERR_BAD_VIRTUAL_ACCESS,
JERR_BUFFER_SIZE,
JERR_CANT_SUSPEND,
JERR_CCIR601_NOTIMPL,
JERR_COMPONENT_COUNT,
JERR_CONVERSION_NOTIMPL,
JERR_DAC_INDEX,
JERR_DAC_VALUE,
JERR_DHT_COUNTS,
JERR_DHT_INDEX,
JERR_DQT_INDEX,
JERR_EMPTY_IMAGE,
JERR_EMS_READ,
JERR_EMS_WRITE,
JERR_EOI_EXPECTED,
JERR_FILE_READ,
JERR_FILE_WRITE,
JERR_FRACT_SAMPLE_NOTIMPL,
JERR_HUFF_CLEN_OVERFLOW,
JERR_HUFF_MISSING_CODE,
JERR_IMAGE_TOO_BIG,
JERR_INPUT_EMPTY,
JERR_INPUT_EOF,
JERR_MISMATCHED_QUANT_TABLE,
JERR_MISSING_DATA,
JERR_MODE_CHANGE,
JERR_NOTIMPL,
JERR_NOT_COMPILED,
JERR_NO_BACKING_STORE,
JERR_NO_HUFF_TABLE,
JERR_NO_IMAGE,
JERR_NO_QUANT_TABLE,
JERR_NO_SOI,
JERR_OUT_OF_MEMORY,
JERR_QUANT_COMPONENTS,
JERR_QUANT_FEW_COLORS,
JERR_QUANT_MANY_COLORS,
JERR_SOF_DUPLICATE,
JERR_SOF_NO_SOS,
JERR_SOF_UNSUPPORTED,
JERR_SOI_DUPLICATE,
JERR_SOS_NO_SOF,
JERR_TFILE_CREATE,
JERR_TFILE_READ,
JERR_TFILE_SEEK,
JERR_TFILE_WRITE,
JERR_TOO_LITTLE_DATA,
JERR_UNKNOWN_MARKER,
JERR_VIRTUAL_BUG,
JERR_WIDTH_OVERFLOW,
JERR_XMS_READ,
JERR_XMS_WRITE,
JMSG_COPYRIGHT,
JMSG_VERSION,
JTRC_16BIT_TABLES,
JTRC_ADOBE,
JTRC_APP0,
JTRC_APP14,
JTRC_DAC,
JTRC_DHT,
JTRC_DQT,
JTRC_DRI,
JTRC_EMS_CLOSE,
JTRC_EMS_OPEN,
JTRC_EOI,
JTRC_HUFFBITS,
JTRC_JFIF,
JTRC_JFIF_BADTHUMBNAILSIZE,
JTRC_JFIF_EXTENSION,
JTRC_JFIF_THUMBNAIL,
JTRC_MISC_MARKER,
JTRC_PARMLESS_MARKER,
JTRC_QUANTVALS,
JTRC_QUANT_3_NCOLORS,
JTRC_QUANT_NCOLORS,
JTRC_QUANT_SELECTED,
JTRC_RECOVERY_ACTION,
JTRC_RST,
JTRC_SMOOTH_NOTIMPL,
JTRC_SOF,
JTRC_SOF_COMPONENT,
JTRC_SOI,
JTRC_SOS,
JTRC_SOS_COMPONENT,
JTRC_SOS_PARAMS,
JTRC_TFILE_CLOSE,
JTRC_TFILE_OPEN,
JTRC_THUMB_JPEG,
JTRC_THUMB_PALETTE,
JTRC_THUMB_RGB,
JTRC_UNKNOWN_IDS,
JTRC_XMS_CLOSE,
JTRC_XMS_OPEN,
JWRN_ADOBE_XFORM,
JWRN_BOGUS_PROGRESSION,
JWRN_EXTRANEOUS_DATA,
JWRN_HIT_MARKER,
JWRN_HUFF_BAD_CODE,
JWRN_JFIF_MAJOR,
JWRN_JPEG_EOF,
JWRN_MUST_RESYNC,
JWRN_NOT_SEQUENTIAL,
JWRN_TOO_MUCH_DATA,
JMSG_FIRSTADDONCODE, { Must be first entry! }
{$ifdef BMP_SUPPORTED}
JERR_BMP_BADCMAP, { Unsupported BMP colormap format }
JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported }
JERR_BMP_BADHEADER, { Invalid BMP file: bad header length }
JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 }
JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB }
JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported }
JERR_BMP_NOT, { Not a BMP file - does not start with BM }
JTRC_BMP, { %dx%d 24-bit BMP image }
JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped BMP image }
JTRC_BMP_OS2, { %dx%d 24-bit OS2 BMP image }
JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image }
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
JERR_GIF_BUG, { GIF output got confused }
JERR_GIF_CODESIZE, { Bogus GIF codesize %d }
JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB }
JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file }
JERR_GIF_NOT, { Not a GIF file }
JTRC_GIF, { %dx%dx%d GIF image }
JTRC_GIF_BADVERSION,
{ Warning: unexpected GIF version number '%c%c%c' }
JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x }
JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input }
JWRN_GIF_BADDATA, { Corrupt data in GIF file }
JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring }
JWRN_GIF_ENDCODE, { Premature end of GIF image }
JWRN_GIF_NOMOREDATA, { Ran out of GIF bits }
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB }
JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file }
JERR_PPM_NOT, { Not a PPM file }
JTRC_PGM, { %dx%d PGM image }
JTRC_PGM_TEXT, { %dx%d text PGM image }
JTRC_PPM, { %dx%d PPM image }
JTRC_PPM_TEXT, { %dx%d text PPM image }
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
JERR_RLE_BADERROR, { Bogus error code from RLE library }
JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB }
JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE }
JERR_RLE_EMPTY, { Empty RLE file }
JERR_RLE_EOF, { Premature EOF in RLE header }
JERR_RLE_MEM, { Insufficient memory for RLE header }
JERR_RLE_NOT, { Not an RLE file }
JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE }
JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup }
JTRC_RLE, { %dx%d full-color RLE file }
JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d }
JTRC_RLE_GRAY, { %dx%d grayscale RLE file }
JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d }
JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d }
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
JERR_TGA_BADCMAP, { Unsupported Targa colormap format }
JERR_TGA_BADPARMS, { Invalid or unsupported Targa file }
JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB }
JTRC_TGA, { %dx%d RGB Targa image }
JTRC_TGA_GRAY, { %dx%d grayscale Targa image }
JTRC_TGA_MAPPED, { %dx%d colormapped Targa image }
{$else}
JERR_TGA_NOTCOMP, { Targa support was not compiled }
{$endif} { TARGA_SUPPORTED }
JERR_BAD_CMAP_FILE,
{ Color map file is invalid or of unsupported format }
JERR_TOO_MANY_COLORS,
{ Output file format cannot handle %d colormap entries }
JERR_UNGETC_FAILED, { ungetc failed }
{$ifdef TARGA_SUPPORTED}
JERR_UNKNOWN_FORMAT,
{ Unrecognized input file format --- perhaps you need -targa }
{$else}
JERR_UNKNOWN_FORMAT, { Unrecognized input file format }
{$endif}
JERR_UNSUPPORTED_FORMAT, { Unsupported output file format }
JMSG_LASTADDONCODE
);
const
JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE;
type
msg_table = Array[J_MESSAGE_CODE] of string[80];
const
jpeg_std_message_table : msg_table = (
{ JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! }
{ For maintenance convenience, list is alphabetical by message code name }
{ JERR_ARITH_NOTIMPL }
'Sorry, there are legal restrictions on arithmetic coding',
{ JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix',
{ JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK is wrong, please fix',
{ JERR_BAD_BUFFER_MODE } 'Bogus buffer control mode',
{ JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS',
{ JERR_BAD_DCT_COEF } 'DCT coefficient out of range',
{ JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported',
{ JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition',
{ JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace',
{ JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace',
{ JERR_BAD_LENGTH } 'Bogus marker length',
{ JERR_BAD_LIB_VERSION }
'Wrong JPEG library version: library is %d, caller expects %d',
{ JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan',
{ JERR_BAD_POOL_ID } 'Invalid memory pool code %d',
{ JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d',
{ JERR_BAD_PROGRESSION }
'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d',
{ JERR_BAD_PROG_SCRIPT }
'Invalid progressive parameters at scan script entry %d',
{ JERR_BAD_SAMPLING } 'Bogus sampling factors',
{ JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d',
{ JERR_BAD_STATE } 'Improper call to JPEG library in state %d',
{ JERR_BAD_STRUCT_SIZE }
'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d',
{ JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access',
{ JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small',
{ JERR_CANT_SUSPEND } 'Suspension not allowed here',
{ JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet',
{ JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d',
{ JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request',
{ JERR_DAC_INDEX } 'Bogus DAC index %d',
{ JERR_DAC_VALUE } 'Bogus DAC value $%x',
{ JERR_DHT_COUNTS } 'Bogus DHT counts',
{ JERR_DHT_INDEX } 'Bogus DHT index %d',
{ JERR_DQT_INDEX } 'Bogus DQT index %d',
{ JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)',
{ JERR_EMS_READ } 'Read from EMS failed',
{ JERR_EMS_WRITE } 'Write to EMS failed',
{ JERR_EOI_EXPECTED } 'Didn''t expect more than one scan',
{ JERR_FILE_READ } 'Input file read error',
{ JERR_FILE_WRITE } 'Output file write error --- out of disk space?',
{ JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet',
{ JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow',
{ JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry',
{ JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels',
{ JERR_INPUT_EMPTY } 'Empty input file',
{ JERR_INPUT_EOF } 'Premature end of input file',
{ JERR_MISMATCHED_QUANT_TABLE }
'Cannot transcode due to multiple use of quantization table %d',
{ JERR_MISSING_DATA } 'Scan script does not transmit all data',
{ JERR_MODE_CHANGE } 'Invalid color quantization mode change',
{ JERR_NOTIMPL } 'Not implemented yet',
{ JERR_NOT_COMPILED } 'Requested feature was omitted at compile time',
{ JERR_NO_BACKING_STORE } 'Backing store not supported',
{ JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined',
{ JERR_NO_IMAGE } 'JPEG datastream contains no image',
{ JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined',
{ JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x',
{ JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)',
{ JERR_QUANT_COMPONENTS }
'Cannot quantize more than %d color components',
{ JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors',
{ JERR_QUANT_MANY_COLORS } 'Cannot quantize to more than %d colors',
{ JERR_SOF_DUPLICATE } 'Invalid JPEG file structure: two SOF markers',
{ JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker',
{ JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x',
{ JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers',
{ JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF',
{ JERR_TFILE_CREATE } 'Failed to create temporary file %s',
{ JERR_TFILE_READ } 'Read failed on temporary file',
{ JERR_TFILE_SEEK } 'Seek failed on temporary file',
{ JERR_TFILE_WRITE }
'Write failed on temporary file --- out of disk space?',
{ JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines',
{ JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x',
{ JERR_VIRTUAL_BUG } 'Virtual array controller messed up',
{ JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation',
{ JERR_XMS_READ } 'Read from XMS failed',
{ JERR_XMS_WRITE } 'Write to XMS failed',
{ JMSG_COPYRIGHT } JCOPYRIGHT,
{ JMSG_VERSION } JVERSION,
{ JTRC_16BIT_TABLES }
'Caution: quantization tables are too coarse for baseline JPEG',
{ JTRC_ADOBE }
'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d',
{ JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d',
{ JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d',
{ JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x',
{ JTRC_DHT } 'Define Huffman Table $%02x',
{ JTRC_DQT } 'Define Quantization Table %d precision %d',
{ JTRC_DRI } 'Define Restart Interval %d',
{ JTRC_EMS_CLOSE } 'Freed EMS handle %d',
{ JTRC_EMS_OPEN } 'Obtained EMS handle %d',
{ JTRC_EOI } 'End Of Image',
{ JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d',
{ JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d',
{ JTRC_JFIF_BADTHUMBNAILSIZE }
'Warning: thumbnail image size does not match data length %d',
{ JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u',
{ JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image',
{ JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d',
{ JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x',
{ JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d',
{ JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors',
{ JTRC_QUANT_NCOLORS } 'Quantizing to %d colors',
{ JTRC_QUANT_SELECTED } 'Selected %d colors for quantization',
{ JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d',
{ JTRC_RST } 'RST%d',
{ JTRC_SMOOTH_NOTIMPL }
'Smoothing not supported with nonstandard sampling ratios',
{ JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d',
{ JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d',
{ JTRC_SOI } 'Start of Image',
{ JTRC_SOS } 'Start Of Scan: %d components',
{ JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d',
{ JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d',
{ JTRC_TFILE_CLOSE } 'Closed temporary file %s',
{ JTRC_TFILE_OPEN } 'Opened temporary file %s',
{ JTRC_THUMB_JPEG }
'JFIF extension marker: JPEG-compressed thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_PALETTE }
'JFIF extension marker: palette thumbnail image, length %u',
{ JMESSAGE(JTRC_THUMB_RGB }
'JFIF extension marker: RGB thumbnail image, length %u',
{ JTRC_UNKNOWN_IDS }
'Unrecognized component IDs %d %d %d, assuming YCbCr',
{ JTRC_XMS_CLOSE } 'Freed XMS handle %d',
{ JTRC_XMS_OPEN } 'Obtained XMS handle %d',
{ JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d',
{ JWRN_BOGUS_PROGRESSION }
'Inconsistent progression sequence for component %d coefficient %d',
{ JWRN_EXTRANEOUS_DATA }
'Corrupt JPEG data: %d extraneous bytes before marker $%02x',
{ JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment',
{ JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code',
{ JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d',
{ JWRN_JPEG_EOF } 'Premature end of JPEG file',
{ JWRN_MUST_RESYNC }
'Corrupt JPEG data: found marker $%02x instead of RST%d',
{ JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG',
{ JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines',
{ JMSG_FIRSTADDONCODE } '', { Must be first entry! }
{$ifdef BMP_SUPPORTED}
{ JERR_BMP_BADCMAP } 'Unsupported BMP colormap format',
{ JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported',
{ JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length',
{ JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1',
{ JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB',
{ JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported',
{ JERR_BMP_NOT } 'Not a BMP file - does not start with BM',
{ JTRC_BMP } '%dx%d 24-bit BMP image',
{ JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped BMP image',
{ JTRC_BMP_OS2 } '%dx%d 24-bit OS2 BMP image',
{ JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image',
{$endif} { BMP_SUPPORTED }
{$ifdef GIF_SUPPORTED}
{ JERR_GIF_BUG } 'GIF output got confused',
{ JERR_GIF_CODESIZE } 'Bogus GIF codesize %d',
{ JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB',
{ JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file',
{ JERR_GIF_NOT } 'Not a GIF file',
{ JTRC_GIF } '%dx%dx%d GIF image',
{ JTRC_GIF_BADVERSION }
'Warning: unexpected GIF version number "%c%c%c"',
{ JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x',
{ JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input',
{ JWRN_GIF_BADDATA } 'Corrupt data in GIF file',
{ JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring',
{ JWRN_GIF_ENDCODE } 'Premature end of GIF image',
{ JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits',
{$endif} { GIF_SUPPORTED }
{$ifdef PPM_SUPPORTED}
{ JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB',
{ JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file',
{ JERR_PPM_NOT } 'Not a PPM file',
{ JTRC_PGM } '%dx%d PGM image',
{ JTRC_PGM_TEXT } '%dx%d text PGM image',
{ JTRC_PPM } '%dx%d PPM image',
{ JTRC_PPM_TEXT } '%dx%d text PPM image',
{$endif} { PPM_SUPPORTED }
{$ifdef RLE_SUPPORTED}
{ JERR_RLE_BADERROR } 'Bogus error code from RLE library',
{ JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB',
{ JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE',
{ JERR_RLE_EMPTY } 'Empty RLE file',
{ JERR_RLE_EOF } 'Premature EOF in RLE header',
{ JERR_RLE_MEM } 'Insufficient memory for RLE header',
{ JERR_RLE_NOT } 'Not an RLE file',
{ JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE',
{ JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup',
{ JTRC_RLE } '%dx%d full-color RLE file',
{ JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d',
{ JTRC_RLE_GRAY } '%dx%d grayscale RLE file',
{ JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d',
{ JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d',
{$endif} { RLE_SUPPORTED }
{$ifdef TARGA_SUPPORTED}
{ JERR_TGA_BADCMAP } 'Unsupported Targa colormap format',
{ JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file',
{ JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB',
{ JTRC_TGA } '%dx%d RGB Targa image',
{ JTRC_TGA_GRAY } '%dx%d grayscale Targa image',
{ JTRC_TGA_MAPPED } '%dx%d colormapped Targa image',
{$else}
{ JERR_TGA_NOTCOMP } 'Targa support was not compiled',
{$endif} { TARGA_SUPPORTED }
{ JERR_BAD_CMAP_FILE }
'Color map file is invalid or of unsupported format',
{ JERR_TOO_MANY_COLORS }
'Output file format cannot handle %d colormap entries',
{ JERR_UNGETC_FAILED } 'ungetc failed',
{$ifdef TARGA_SUPPORTED}
{ JERR_UNKNOWN_FORMAT }
'Unrecognized input file format --- perhaps you need -targa',
{$else}
{ JERR_UNKNOWN_FORMAT } 'Unrecognized input file format',
{$endif}
{ JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format',
{ JMSG_LASTADDONCODE } '');
implementation
end.

1204
Imaging/JpegLib/imjdhuff.pas Normal file
View File

File diff suppressed because it is too large Load Diff

416
Imaging/JpegLib/imjdinput.pas Normal file
View File

@@ -0,0 +1,416 @@
unit imjdinput;
{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains input control logic for the JPEG decompressor.
These routines are concerned with controlling the decompressor's input
processing (marker reading and coefficient decoding). The actual input
reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjpeglib,
imjdeferr,
imjerror,
imjinclude, imjutils;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
implementation
{ Private state }
type
my_inputctl_ptr = ^my_input_controller;
my_input_controller = record
pub : jpeg_input_controller; { public fields }
inheaders : boolean; { TRUE until first SOS is reached }
end; {my_input_controller;}
{ Forward declarations }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int; forward;
{ Routines to calculate various quantities related to the size of the image. }
{LOCAL}
procedure initial_setup (cinfo : j_decompress_ptr);
{ Called once, when first SOS marker is reached }
var
ci : int;
compptr : jpeg_component_info_ptr;
begin
{ Make sure image isn't bigger than I can handle }
if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or
(long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then
ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION));
{ For now, precision must match compiled-in value... }
if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision);
{ Check that number of components won't exceed internal array sizes }
if (cinfo^.num_components > MAX_COMPONENTS) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components,
MAX_COMPONENTS);
{ Compute maximum sampling factors; check factor validity }
cinfo^.max_h_samp_factor := 1;
cinfo^.max_v_samp_factor := 1;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or
(compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING);
{cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor,
compptr^.h_samp_factor);
cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor,
compptr^.v_samp_factor);}
if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then
cinfo^.max_h_samp_factor := compptr^.h_samp_factor;
if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then
cinfo^.max_v_samp_factor := compptr^.v_samp_factor;
Inc(compptr);
end;
{ We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE.
In the full decompressor, this will be overridden by jdmaster.c;
but in the transcoder, jdmaster.c is not used, so we must do it here. }
cinfo^.min_DCT_scaled_size := DCTSIZE;
{ Compute dimensions of components }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
compptr^.DCT_scaled_size := DCTSIZE;
{ Size in DCT blocks }
compptr^.width_in_blocks := JDIMENSION(
jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor),
long(cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.height_in_blocks := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor * DCTSIZE)) );
{ downsampled_width and downsampled_height will also be overridden by
jdmaster.c if we are doing full decompression. The transcoder library
doesn't use these values, but the calling application might. }
{ Size in samples }
compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor),
long (cinfo^.max_h_samp_factor)) );
compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor),
long (cinfo^.max_v_samp_factor)) );
{ Mark component needed, until color conversion says otherwise }
compptr^.component_needed := TRUE;
{ Mark no quantization table yet saved for component }
compptr^.quant_table := NIL;
Inc(compptr);
end;
{ Compute number of fully interleaved MCU rows. }
cinfo^.total_iMCU_rows := JDIMENSION(
jdiv_round_up(long(cinfo^.image_height),
long(cinfo^.max_v_samp_factor*DCTSIZE)) );
{ Decide whether file contains multiple scans }
if (cinfo^.comps_in_scan < cinfo^.num_components) or
(cinfo^.progressive_mode) then
cinfo^.inputctl^.has_multiple_scans := TRUE
else
cinfo^.inputctl^.has_multiple_scans := FALSE;
end;
{LOCAL}
procedure per_scan_setup (cinfo : j_decompress_ptr);
{ Do computations that are needed before processing a JPEG scan }
{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker }
var
ci, mcublks, tmp : int;
compptr : jpeg_component_info_ptr;
begin
if (cinfo^.comps_in_scan = 1) then
begin
{ Noninterleaved (single-component) scan }
compptr := cinfo^.cur_comp_info[0];
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := compptr^.width_in_blocks;
cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks;
{ For noninterleaved scan, always one block per MCU }
compptr^.MCU_width := 1;
compptr^.MCU_height := 1;
compptr^.MCU_blocks := 1;
compptr^.MCU_sample_width := compptr^.DCT_scaled_size;
compptr^.last_col_width := 1;
{ For noninterleaved scans, it is convenient to define last_row_height
as the number of block rows present in the last iMCU row. }
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor);
if (tmp = 0) then
tmp := compptr^.v_samp_factor;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
cinfo^.blocks_in_MCU := 1;
cinfo^.MCU_membership[0] := 0;
end
else
begin
{ Interleaved (multi-component) scan }
if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then
ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan,
MAX_COMPS_IN_SCAN);
{ Overall image size in MCUs }
cinfo^.MCUs_per_row := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width),
long (cinfo^.max_h_samp_factor*DCTSIZE)) );
cinfo^.MCU_rows_in_scan := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height),
long (cinfo^.max_v_samp_factor*DCTSIZE)) );
cinfo^.blocks_in_MCU := 0;
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ Sampling factors give # of blocks of component in each MCU }
compptr^.MCU_width := compptr^.h_samp_factor;
compptr^.MCU_height := compptr^.v_samp_factor;
compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height;
compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size;
{ Figure number of non-dummy blocks in last MCU column & row }
tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width);
if (tmp = 0) then
tmp := compptr^.MCU_width;
compptr^.last_col_width := tmp;
tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height);
if (tmp = 0) then
tmp := compptr^.MCU_height;
compptr^.last_row_height := tmp;
{ Prepare array describing MCU composition }
mcublks := compptr^.MCU_blocks;
if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE);
while (mcublks > 0) do
begin
Dec(mcublks);
cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci;
Inc(cinfo^.blocks_in_MCU);
end;
end;
end;
end;
{ Save away a copy of the Q-table referenced by each component present
in the current scan, unless already saved during a prior scan.
In a multiple-scan JPEG file, the encoder could assign different components
the same Q-table slot number, but change table definitions between scans
so that each component uses a different Q-table. (The IJG encoder is not
currently capable of doing this, but other encoders might.) Since we want
to be able to dequantize all the components at the end of the file, this
means that we have to save away the table actually used for each component.
We do this by copying the table at the start of the first scan containing
the component.
The JPEG spec prohibits the encoder from changing the contents of a Q-table
slot between scans of a component using that slot. If the encoder does so
anyway, this decoder will simply use the Q-table values that were current
at the start of the first scan for the component.
The decompressor output side looks only at the saved quant tables,
not at the current Q-table slots. }
{LOCAL}
procedure latch_quant_tables (cinfo : j_decompress_ptr);
var
ci, qtblno : int;
compptr : jpeg_component_info_ptr;
qtbl : JQUANT_TBL_PTR;
begin
for ci := 0 to pred(cinfo^.comps_in_scan) do
begin
compptr := cinfo^.cur_comp_info[ci];
{ No work if we already saved Q-table for this component }
if (compptr^.quant_table <> NIL) then
continue;
{ Make sure specified quantization table is present }
qtblno := compptr^.quant_tbl_no;
if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or
(cinfo^.quant_tbl_ptrs[qtblno] = NIL) then
ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno);
{ OK, save away the quantization table }
qtbl := JQUANT_TBL_PTR(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(JQUANT_TBL)) );
MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL));
compptr^.quant_table := qtbl;
end;
end;
{ Initialize the input modules to read a scan of compressed data.
The first call to this is done by jdmaster.c after initializing
the entire decompressor (during jpeg_start_decompress).
Subsequent calls come from consume_markers, below. }
{METHODDEF}
procedure start_input_pass (cinfo : j_decompress_ptr);
begin
per_scan_setup(cinfo);
latch_quant_tables(cinfo);
cinfo^.entropy^.start_pass (cinfo);
cinfo^.coef^.start_input_pass (cinfo);
cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data;
end;
{ Finish up after inputting a compressed-data scan.
This is called by the coefficient controller after it's read all
the expected data of the scan. }
{METHODDEF}
procedure finish_input_pass (cinfo : j_decompress_ptr);
begin
cinfo^.inputctl^.consume_input := consume_markers;
end;
{ Read JPEG markers before, between, or after compressed-data scans.
Change state as necessary when a new scan is reached.
Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI.
The consume_input method pointer points either here or to the
coefficient controller's consume_data routine, depending on whether
we are reading a compressed data segment or inter-segment markers. }
{METHODDEF}
function consume_markers (cinfo : j_decompress_ptr) : int;
var
val : int;
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further }
begin
consume_markers := JPEG_REACHED_EOI;
exit;
end;
val := cinfo^.marker^.read_markers (cinfo);
case (val) of
JPEG_REACHED_SOS: { Found SOS }
begin
if (inputctl^.inheaders) then
begin { 1st SOS }
initial_setup(cinfo);
inputctl^.inheaders := FALSE;
{ Note: start_input_pass must be called by jdmaster.c
before any more input can be consumed. jdapimin.c is
responsible for enforcing this sequencing. }
end
else
begin { 2nd or later SOS marker }
if (not inputctl^.pub.has_multiple_scans) then
ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! }
start_input_pass(cinfo);
end;
end;
JPEG_REACHED_EOI: { Found EOI }
begin
inputctl^.pub.eoi_reached := TRUE;
if (inputctl^.inheaders) then
begin { Tables-only datastream, apparently }
if (cinfo^.marker^.saw_SOF) then
ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS);
end
else
begin
{ Prevent infinite loop in coef ctlr's decompress_data routine
if user set output_scan_number larger than number of scans. }
if (cinfo^.output_scan_number > cinfo^.input_scan_number) then
cinfo^.output_scan_number := cinfo^.input_scan_number;
end;
end;
JPEG_SUSPENDED:;
end;
consume_markers := val;
end;
{ Reset state to begin a fresh datastream. }
{METHODDEF}
procedure reset_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
inputctl := my_inputctl_ptr (cinfo^.inputctl);
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
{ Reset other modules }
cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo));
cinfo^.marker^.reset_marker_reader (cinfo);
{ Reset progression state -- would be cleaner if entropy decoder did this }
cinfo^.coef_bits := NIL;
end;
{ Initialize the input controller module.
This is called only once, when the decompression object is created. }
{GLOBAL}
procedure jinit_input_controller (cinfo : j_decompress_ptr);
var
inputctl : my_inputctl_ptr;
begin
{ Create subobject in permanent pool }
inputctl := my_inputctl_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
SIZEOF(my_input_controller)) );
cinfo^.inputctl := jpeg_input_controller_ptr(inputctl);
{ Initialize method pointers }
inputctl^.pub.consume_input := consume_markers;
inputctl^.pub.reset_input_controller := reset_input_controller;
inputctl^.pub.start_input_pass := start_input_pass;
inputctl^.pub.finish_input_pass := finish_input_pass;
{ Initialize state: can't use reset_input_controller since we don't
want to try to reset other modules yet. }
inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better }
inputctl^.pub.eoi_reached := FALSE;
inputctl^.inheaders := TRUE;
end;
end.

610
Imaging/JpegLib/imjdmainct.pas Normal file
View File

@@ -0,0 +1,610 @@
unit imjdmainct;
{ This file is part of the Independent JPEG Group's software.
For conditions of distribution and use, see the accompanying README file.
This file contains the main buffer controller for decompression.
The main buffer lies between the JPEG decompressor proper and the
post-processor; it holds downsampled data in the JPEG colorspace.
Note that this code is bypassed in raw-data mode, since the application
supplies the equivalent of the main buffer in that case. }
{ Original: jdmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ In the current system design, the main buffer need never be a full-image
buffer; any full-height buffers will be found inside the coefficient or
postprocessing controllers. Nonetheless, the main controller is not
trivial. Its responsibility is to provide context rows for upsampling/
rescaling, and doing this in an efficient fashion is a bit tricky.
Postprocessor input data is counted in "row groups". A row group
is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size)
sample rows of each component. (We require DCT_scaled_size values to be
chosen such that these numbers are integers. In practice DCT_scaled_size
values will likely be powers of two, so we actually have the stronger
condition that DCT_scaled_size / min_DCT_scaled_size is an integer.)
Upsampling will typically produce max_v_samp_factor pixel rows from each
row group (times any additional scale factor that the upsampler is
applying).
The coefficient controller will deliver data to us one iMCU row at a time;
each iMCU row contains v_samp_factor * DCT_scaled_size sample rows, or
exactly min_DCT_scaled_size row groups. (This amount of data corresponds
to one row of MCUs when the image is fully interleaved.) Note that the
number of sample rows varies across components, but the number of row
groups does not. Some garbage sample rows may be included in the last iMCU
row at the bottom of the image.
Depending on the vertical scaling algorithm used, the upsampler may need
access to the sample row(s) above and below its current input row group.
The upsampler is required to set need_context_rows TRUE at global
selection
time if so. When need_context_rows is FALSE, this controller can simply
obtain one iMCU row at a time from the coefficient controller and dole it
out as row groups to the postprocessor.
When need_context_rows is TRUE, this controller guarantees that the buffer
passed to postprocessing contains at least one row group's worth of samples
above and below the row group(s) being processed. Note that the context
rows "above" the first passed row group appear at negative row offsets in
the passed buffer. At the top and bottom of the image, the required
context rows are manufactured by duplicating the first or last real sample
row; this avoids having special cases in the upsampling inner loops.
The amount of context is fixed at one row group just because that's a
convenient number for this controller to work with. The existing
upsamplers really only need one sample row of context. An upsampler
supporting arbitrary output rescaling might wish for more than one row
group of context when shrinking the image; tough, we don't handle that.
(This is justified by the assumption that downsizing will be handled mostly
by adjusting the DCT_scaled_size values, so that the actual scale factor at
the upsample step needn't be much less than one.)
To provide the desired context, we have to retain the last two row groups
of one iMCU row while reading in the next iMCU row. (The last row group
can't be processed until we have another row group for its below-context,
and so we have to save the next-to-last group too for its above-context.)
We could do this most simply by copying data around in our buffer, but
that'd be very slow. We can avoid copying any data by creating a rather
strange pointer structure. Here's how it works. We allocate a workspace
consisting of M+2 row groups (where M = min_DCT_scaled_size is the number
of row groups per iMCU row). We create two sets of redundant pointers to
the workspace. Labeling the physical row groups 0 to M+1, the synthesized
pointer lists look like this:
M+1 M-1
master pointer --> 0 master pointer --> 0
1 1
... ...
M-3 M-3
M-2 M
M-1 M+1
M M-2
M+1 M-1
0 0
We read alternate iMCU rows using each master pointer; thus the last two
row groups of the previous iMCU row remain un-overwritten in the workspace.
The pointer lists are set up so that the required context rows appear to
be adjacent to the proper places when we pass the pointer lists to the
upsampler.
The above pictures describe the normal state of the pointer lists.
At top and bottom of the image, we diddle the pointer lists to duplicate
the first or last sample row as necessary (this is cheaper than copying
sample rows around).
This scheme breaks down if M < 2, ie, min_DCT_scaled_size is 1. In that
situation each iMCU row provides only one row group so the buffering logic
must be different (eg, we must read two iMCU rows before we can emit the
first row group). For now, we simply do not support providing context
rows when min_DCT_scaled_size is 1. That combination seems unlikely to
be worth providing --- if someone wants a 1/8th-size preview, they probably
want it quick and dirty, so a context-free upsampler is sufficient. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
{$ifdef QUANT_2PASS_SUPPORTED}
imjquant2,
{$endif}
imjdeferr,
imjerror,
imjpeglib;
{GLOBAL}
procedure jinit_d_main_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_main_ptr = ^my_main_controller;
my_main_controller = record
pub : jpeg_d_main_controller; { public fields }
{ Pointer to allocated workspace (M or M+2 row groups). }
buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
buffer_full : boolean; { Have we gotten an iMCU row from decoder? }
rowgroup_ctr : JDIMENSION ; { counts row groups output to postprocessor }
{ Remaining fields are only used in the context case. }
{ These are the master pointers to the funny-order pointer lists. }
xbuffer : array[0..2-1] of JSAMPIMAGE; { pointers to weird pointer lists }
whichptr : int; { indicates which pointer set is now in use }
context_state : int; { process_data state machine status }
rowgroups_avail : JDIMENSION; { row groups available to postprocessor }
iMCU_row_ctr : JDIMENSION; { counts iMCU rows to detect image top/bot }
end; { my_main_controller; }
{ context_state values: }
const
CTX_PREPARE_FOR_IMCU = 0; { need to prepare for MCU row }
CTX_PROCESS_IMCU = 1; { feeding iMCU to postprocessor }
CTX_POSTPONED_ROW = 2; { feeding postponed row group }
{ Forward declarations }
{METHODDEF}
procedure process_data_simple_main(cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{METHODDEF}
procedure process_data_context_main (cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF}
procedure process_data_crank_post (cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$endif}
{LOCAL}
procedure alloc_funny_pointers (cinfo : j_decompress_ptr);
{ Allocate space for the funny pointer lists.
This is done only once, not once per pass. }
var
main : my_main_ptr;
ci, rgroup : int;
M : int;
compptr : jpeg_component_info_ptr;
xbuf : JSAMPARRAY;
begin
main := my_main_ptr (cinfo^.main);
M := cinfo^.min_DCT_scaled_size;
{ Get top-level space for component array pointers.
We alloc both arrays with one call to save a few cycles. }
main^.xbuffer[0] := JSAMPIMAGE (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
cinfo^.num_components * 2 * SIZEOF(JSAMPARRAY)) );
main^.xbuffer[1] := JSAMPIMAGE(@( main^.xbuffer[0]^[cinfo^.num_components] ));
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size; { height of a row group of component }
{ Get space for pointer lists --- M+4 row groups in each list.
We alloc both pointer lists with one call to save a few cycles. }
xbuf := JSAMPARRAY (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
2 * (rgroup * (M + 4)) * SIZEOF(JSAMPROW)) );
Inc(JSAMPROW_PTR(xbuf), rgroup); { want one row group at negative offsets }
main^.xbuffer[0]^[ci] := xbuf;
Inc(JSAMPROW_PTR(xbuf), rgroup * (M + 4));
main^.xbuffer[1]^[ci] := xbuf;
Inc(compptr);
end;
end;
{LOCAL}
procedure make_funny_pointers (cinfo : j_decompress_ptr);
{ Create the funny pointer lists discussed in the comments above.
The actual workspace is already allocated (in main^.buffer),
and the space for the pointer lists is allocated too.
This routine just fills in the curiously ordered lists.
This will be repeated at the beginning of each pass. }
var
main : my_main_ptr;
ci, i, rgroup : int;
M : int;
compptr : jpeg_component_info_ptr;
buf, xbuf0, xbuf1 : JSAMPARRAY;
var
help_xbuf0 : JSAMPARRAY; { work around negative offsets }
begin
main := my_main_ptr (cinfo^.main);
M := cinfo^.min_DCT_scaled_size;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size; { height of a row group of component }
xbuf0 := main^.xbuffer[0]^[ci];
xbuf1 := main^.xbuffer[1]^[ci];
{ First copy the workspace pointers as-is }
buf := main^.buffer[ci];
for i := 0 to pred(rgroup * (M + 2)) do
begin
xbuf0^[i] := buf^[i];
xbuf1^[i] := buf^[i];
end;
{ In the second list, put the last four row groups in swapped order }
for i := 0 to pred(rgroup * 2) do
begin
xbuf1^[rgroup*(M-2) + i] := buf^[rgroup*M + i];
xbuf1^[rgroup*M + i] := buf^[rgroup*(M-2) + i];
end;
{ The wraparound pointers at top and bottom will be filled later
(see set_wraparound_pointers, below). Initially we want the "above"
pointers to duplicate the first actual data line. This only needs
to happen in xbuffer[0]. }
help_xbuf0 := xbuf0;
Dec(JSAMPROW_PTR(help_xbuf0), rgroup);
for i := 0 to pred(rgroup) do
begin
{xbuf0^[i - rgroup] := xbuf0^[0];}
help_xbuf0^[i] := xbuf0^[0];
end;
Inc(compptr);
end;
end;
{LOCAL}
procedure set_wraparound_pointers (cinfo : j_decompress_ptr);
{ Set up the "wraparound" pointers at top and bottom of the pointer lists.
This changes the pointer list state from top-of-image to the normal state. }
var
main : my_main_ptr;
ci, i, rgroup : int;
M : int;
compptr : jpeg_component_info_ptr;
xbuf0, xbuf1 : JSAMPARRAY;
var
help_xbuf0,
help_xbuf1 : JSAMPARRAY; { work around negative offsets }
begin
main := my_main_ptr (cinfo^.main);
M := cinfo^.min_DCT_scaled_size;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size; { height of a row group of component }
xbuf0 := main^.xbuffer[0]^[ci];
xbuf1 := main^.xbuffer[1]^[ci];
help_xbuf0 := xbuf0;
Dec(JSAMPROW_PTR(help_xbuf0), rgroup);
help_xbuf1 := xbuf1;
Dec(JSAMPROW_PTR(help_xbuf1), rgroup);
for i := 0 to pred(rgroup) do
begin
{xbuf0^[i - rgroup] := xbuf0^[rgroup*(M+1) + i];
xbuf1^[i - rgroup] := xbuf1^[rgroup*(M+1) + i];}
help_xbuf0^[i] := xbuf0^[rgroup*(M+1) + i];
help_xbuf1^[i] := xbuf1^[rgroup*(M+1) + i];
xbuf0^[rgroup*(M+2) + i] := xbuf0^[i];
xbuf1^[rgroup*(M+2) + i] := xbuf1^[i];
end;
Inc(compptr);
end;
end;
{LOCAL}
procedure set_bottom_pointers (cinfo : j_decompress_ptr);
{ Change the pointer lists to duplicate the last sample row at the bottom
of the image. whichptr indicates which xbuffer holds the final iMCU row.
Also sets rowgroups_avail to indicate number of nondummy row groups in row. }
var
main : my_main_ptr;
ci, i, rgroup, iMCUheight, rows_left : int;
compptr : jpeg_component_info_ptr;
xbuf : JSAMPARRAY;
begin
main := my_main_ptr (cinfo^.main);
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Count sample rows in one iMCU row and in one row group }
iMCUheight := compptr^.v_samp_factor * compptr^.DCT_scaled_size;
rgroup := iMCUheight div cinfo^.min_DCT_scaled_size;
{ Count nondummy sample rows remaining for this component }
rows_left := int (compptr^.downsampled_height mod JDIMENSION (iMCUheight));
if (rows_left = 0) then
rows_left := iMCUheight;
{ Count nondummy row groups. Should get same answer for each component,
so we need only do it once. }
if (ci = 0) then
begin
main^.rowgroups_avail := JDIMENSION ((rows_left-1) div rgroup + 1);
end;
{ Duplicate the last real sample row rgroup*2 times; this pads out the
last partial rowgroup and ensures at least one full rowgroup of context. }
xbuf := main^.xbuffer[main^.whichptr]^[ci];
for i := 0 to pred(rgroup * 2) do
begin
xbuf^[rows_left + i] := xbuf^[rows_left-1];
end;
Inc(compptr);
end;
end;
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_main (cinfo : j_decompress_ptr;
pass_mode : J_BUF_MODE);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
case (pass_mode) of
JBUF_PASS_THRU:
begin
if (cinfo^.upsample^.need_context_rows) then
begin
main^.pub.process_data := process_data_context_main;
make_funny_pointers(cinfo); { Create the xbuffer[] lists }
main^.whichptr := 0; { Read first iMCU row into xbuffer[0] }
main^.context_state := CTX_PREPARE_FOR_IMCU;
main^.iMCU_row_ctr := 0;
end
else
begin
{ Simple case with no context needed }
main^.pub.process_data := process_data_simple_main;
end;
main^.buffer_full := FALSE; { Mark buffer empty }
main^.rowgroup_ctr := 0;
end;
{$ifdef QUANT_2PASS_SUPPORTED}
JBUF_CRANK_DEST:
{ For last pass of 2-pass quantization, just crank the postprocessor }
main^.pub.process_data := process_data_crank_post;
{$endif}
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
end;
{ Process some data.
This handles the simple case where no context is required. }
{METHODDEF}
procedure process_data_simple_main (cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
main : my_main_ptr;
rowgroups_avail : JDIMENSION;
var
main_buffer_ptr : JSAMPIMAGE;
begin
main := my_main_ptr (cinfo^.main);
main_buffer_ptr := JSAMPIMAGE(@(main^.buffer));
{ Read input data if we haven't filled the main buffer yet }
if (not main^.buffer_full) then
begin
if (cinfo^.coef^.decompress_data (cinfo, main_buffer_ptr)=0) then
exit; { suspension forced, can do nothing more }
main^.buffer_full := TRUE; { OK, we have an iMCU row to work with }
end;
{ There are always min_DCT_scaled_size row groups in an iMCU row. }
rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size);
{ Note: at the bottom of the image, we may pass extra garbage row groups
to the postprocessor. The postprocessor has to check for bottom
of image anyway (at row resolution), so no point in us doing it too. }
{ Feed the postprocessor }
cinfo^.post^.post_process_data (cinfo, main_buffer_ptr,
main^.rowgroup_ctr, rowgroups_avail,
output_buf, out_row_ctr, out_rows_avail);
{ Has postprocessor consumed all the data yet? If so, mark buffer empty }
if (main^.rowgroup_ctr >= rowgroups_avail) then
begin
main^.buffer_full := FALSE;
main^.rowgroup_ctr := 0;
end;
end;
{ Process some data.
This handles the case where context rows must be provided. }
{METHODDEF}
procedure process_data_context_main (cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
main : my_main_ptr;
begin
main := my_main_ptr (cinfo^.main);
{ Read input data if we haven't filled the main buffer yet }
if (not main^.buffer_full) then
begin
if (cinfo^.coef^.decompress_data (cinfo,
main^.xbuffer[main^.whichptr])=0) then
exit; { suspension forced, can do nothing more }
main^.buffer_full := TRUE; { OK, we have an iMCU row to work with }
Inc(main^.iMCU_row_ctr); { count rows received }
end;
{ Postprocessor typically will not swallow all the input data it is handed
in one call (due to filling the output buffer first). Must be prepared
to exit and restart. This switch lets us keep track of how far we got.
Note that each case falls through to the next on successful completion. }
case (main^.context_state) of
CTX_POSTPONED_ROW:
begin
{ Call postprocessor using previously set pointers for postponed row }
cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr],
main^.rowgroup_ctr, main^.rowgroups_avail,
output_buf, out_row_ctr, out_rows_avail);
if (main^.rowgroup_ctr < main^.rowgroups_avail) then
exit; { Need to suspend }
main^.context_state := CTX_PREPARE_FOR_IMCU;
if (out_row_ctr >= out_rows_avail) then
exit; { Postprocessor exactly filled output buf }
end;
end;
case (main^.context_state) of
CTX_POSTPONED_ROW,
CTX_PREPARE_FOR_IMCU: {FALLTHROUGH}
begin
{ Prepare to process first M-1 row groups of this iMCU row }
main^.rowgroup_ctr := 0;
main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size - 1);
{ Check for bottom of image: if so, tweak pointers to "duplicate"
the last sample row, and adjust rowgroups_avail to ignore padding rows. }
if (main^.iMCU_row_ctr = cinfo^.total_iMCU_rows) then
set_bottom_pointers(cinfo);
main^.context_state := CTX_PROCESS_IMCU;
end;
end;
case (main^.context_state) of
CTX_POSTPONED_ROW,
CTX_PREPARE_FOR_IMCU, {FALLTHROUGH}
CTX_PROCESS_IMCU:
begin
{ Call postprocessor using previously set pointers }
cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr],
main^.rowgroup_ctr, main^.rowgroups_avail,
output_buf, out_row_ctr, out_rows_avail);
if (main^.rowgroup_ctr < main^.rowgroups_avail) then
exit; { Need to suspend }
{ After the first iMCU, change wraparound pointers to normal state }
if (main^.iMCU_row_ctr = 1) then
set_wraparound_pointers(cinfo);
{ Prepare to load new iMCU row using other xbuffer list }
main^.whichptr := main^.whichptr xor 1; { 0=>1 or 1=>0 }
main^.buffer_full := FALSE;
{ Still need to process last row group of this iMCU row, }
{ which is saved at index M+1 of the other xbuffer }
main^.rowgroup_ctr := JDIMENSION (cinfo^.min_DCT_scaled_size + 1);
main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size + 2);
main^.context_state := CTX_POSTPONED_ROW;
end;
end;
end;
{ Process some data.
Final pass of two-pass quantization: just call the postprocessor.
Source data will be the postprocessor controller's internal buffer. }
{$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF}
procedure process_data_crank_post (cinfo : j_decompress_ptr;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
in_row_group_ctr : JDIMENSION;
begin
in_row_group_ctr := 0;
cinfo^.post^.post_process_data (cinfo, JSAMPIMAGE (NIL),
in_row_group_ctr,
JDIMENSION(0),
output_buf,
out_row_ctr,
out_rows_avail);
end;
{$endif} { QUANT_2PASS_SUPPORTED }
{ Initialize main buffer controller. }
{GLOBAL}
procedure jinit_d_main_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
var
main : my_main_ptr;
ci, rgroup, ngroups : int;
compptr : jpeg_component_info_ptr;
begin
main := my_main_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_main_controller)) );
cinfo^.main := jpeg_d_main_controller_ptr(main);
main^.pub.start_pass := start_pass_main;
if (need_full_buffer) then { shouldn't happen }
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{ Allocate the workspace.
ngroups is the number of row groups we need.}
if (cinfo^.upsample^.need_context_rows) then
begin
if (cinfo^.min_DCT_scaled_size < 2) then { unsupported, see comments above }
ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL);
alloc_funny_pointers(cinfo); { Alloc space for xbuffer[] lists }
ngroups := cinfo^.min_DCT_scaled_size + 2;
end
else
begin
ngroups := cinfo^.min_DCT_scaled_size;
end;
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size; { height of a row group of component }
main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * LongWord(compptr^.DCT_scaled_size),
JDIMENSION (rgroup * ngroups));
Inc(compptr);
end;
end;
end.

2644
Imaging/JpegLib/imjdmarker.pas Normal file
View File

File diff suppressed because it is too large Load Diff

679
Imaging/JpegLib/imjdmaster.pas Normal file
View File

@@ -0,0 +1,679 @@
unit imjdmaster;
{ This file contains master control logic for the JPEG decompressor.
These routines are concerned with selecting the modules to be executed
and with determining the number of passes and the work to be done in each
pass. }
{ Original: jdmaster.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjerror,
imjdeferr,
imjdcolor, imjdsample, imjdpostct, imjddctmgr, imjdphuff,
imjdhuff, imjdcoefct, imjdmainct,
{$ifdef QUANT_1PASS_SUPPORTED}
imjquant1,
{$endif}
{$ifdef QUANT_2PASS_SUPPORTED}
imjquant2,
{$endif}
{$ifdef UPSAMPLE_MERGING_SUPPORTED}
imjdmerge,
{$endif}
imjpeglib;
{ Compute output image dimensions and related values.
NOTE: this is exported for possible use by application.
Hence it mustn't do anything that can't be done twice.
Also note that it may be called before the master module is initialized! }
{GLOBAL}
procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr);
{ Do computations that are needed before master selection phase }
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{GLOBAL}
procedure jpeg_new_colormap (cinfo : j_decompress_ptr);
{$endif}
{ Initialize master decompression control and select active modules.
This is performed at the start of jpeg_start_decompress. }
{GLOBAL}
procedure jinit_master_decompress (cinfo : j_decompress_ptr);
implementation
{ Private state }
type
my_master_ptr = ^my_decomp_master;
my_decomp_master = record
pub : jpeg_decomp_master; { public fields }
pass_number : int; { # of passes completed }
using_merged_upsample : boolean; { TRUE if using merged upsample/cconvert }
{ Saved references to initialized quantizer modules,
in case we need to switch modes. }
quantizer_1pass : jpeg_color_quantizer_ptr;
quantizer_2pass : jpeg_color_quantizer_ptr;
end;
{ Determine whether merged upsample/color conversion should be used.
CRUCIAL: this must match the actual capabilities of jdmerge.c! }
{LOCAL}
function use_merged_upsample (cinfo : j_decompress_ptr) : boolean;
var
compptr : jpeg_component_info_list_ptr;
begin
compptr := cinfo^.comp_info;
{$ifdef UPSAMPLE_MERGING_SUPPORTED}
{ Merging is the equivalent of plain box-filter upsampling }
if (cinfo^.do_fancy_upsampling) or (cinfo^.CCIR601_sampling) then
begin
use_merged_upsample := FALSE;
exit;
end;
{ jdmerge.c only supports YCC=>RGB color conversion }
if (cinfo^.jpeg_color_space <> JCS_YCbCr) or (cinfo^.num_components <> 3)
or (cinfo^.out_color_space <> JCS_RGB)
or (cinfo^.out_color_components <> RGB_PIXELSIZE) then
begin
use_merged_upsample := FALSE;
exit;
end;
{ and it only handles 2h1v or 2h2v sampling ratios }
if (compptr^[0].h_samp_factor <> 2) or
(compptr^[1].h_samp_factor <> 1) or
(compptr^[2].h_samp_factor <> 1) or
(compptr^[0].v_samp_factor > 2) or
(compptr^[1].v_samp_factor <> 1) or
(compptr^[2].v_samp_factor <> 1) then
begin
use_merged_upsample := FALSE;
exit;
end;
{ furthermore, it doesn't work if we've scaled the IDCTs differently }
if (compptr^[0].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or
(compptr^[1].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or
(compptr^[2].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) then
begin
use_merged_upsample := FALSE;
exit;
end;
{ ??? also need to test for upsample-time rescaling, when & if supported }
use_merged_upsample := TRUE; { by golly, it'll work... }
{$else}
use_merged_upsample := FALSE;
{$endif}
end;
{ Compute output image dimensions and related values.
NOTE: this is exported for possible use by application.
Hence it mustn't do anything that can't be done twice.
Also note that it may be called before the master module is initialized! }
{GLOBAL}
procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr);
{ Do computations that are needed before master selection phase }
{$ifdef IDCT_SCALING_SUPPORTED}
var
ci : int;
compptr : jpeg_component_info_ptr;
{$endif}
var
ssize : int;
begin
{ Prevent application from calling me at wrong times }
if (cinfo^.global_state <> DSTATE_READY) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
{$ifdef IDCT_SCALING_SUPPORTED}
{ Compute actual output image dimensions and DCT scaling choices. }
if (cinfo^.scale_num * 8 <= cinfo^.scale_denom) then
begin
{ Provide 1/8 scaling }
cinfo^.output_width := JDIMENSION (
jdiv_round_up( long(cinfo^.image_width), long(8)) );
cinfo^.output_height := JDIMENSION (
jdiv_round_up( long(cinfo^.image_height), long(8)) );
cinfo^.min_DCT_scaled_size := 1;
end
else
if (cinfo^.scale_num * 4 <= cinfo^.scale_denom) then
begin
{ Provide 1/4 scaling }
cinfo^.output_width := JDIMENSION (
jdiv_round_up( long (cinfo^.image_width), long(4)) );
cinfo^.output_height := JDIMENSION (
jdiv_round_up( long (cinfo^.image_height), long(4)) );
cinfo^.min_DCT_scaled_size := 2;
end
else
if (cinfo^.scale_num * 2 <= cinfo^.scale_denom) then
begin
{ Provide 1/2 scaling }
cinfo^.output_width := JDIMENSION (
jdiv_round_up( long(cinfo^.image_width), long(2)) );
cinfo^.output_height := JDIMENSION (
jdiv_round_up( long(cinfo^.image_height), long(2)) );
cinfo^.min_DCT_scaled_size := 4;
end
else
begin
{ Provide 1/1 scaling }
cinfo^.output_width := cinfo^.image_width;
cinfo^.output_height := cinfo^.image_height;
cinfo^.min_DCT_scaled_size := DCTSIZE;
end;
{ In selecting the actual DCT scaling for each component, we try to
scale up the chroma components via IDCT scaling rather than upsampling.
This saves time if the upsampler gets to use 1:1 scaling.
Note this code assumes that the supported DCT scalings are powers of 2. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
ssize := cinfo^.min_DCT_scaled_size;
while (ssize < DCTSIZE) and
((compptr^.h_samp_factor * ssize * 2 <=
cinfo^.max_h_samp_factor * cinfo^.min_DCT_scaled_size) and
(compptr^.v_samp_factor * ssize * 2 <=
cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size)) do
begin
ssize := ssize * 2;
end;
compptr^.DCT_scaled_size := ssize;
Inc(compptr);
end;
{ Recompute downsampled dimensions of components;
application needs to know these if using raw downsampled data. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Size in samples, after IDCT scaling }
compptr^.downsampled_width := JDIMENSION (
jdiv_round_up(long (cinfo^.image_width) *
long (compptr^.h_samp_factor * compptr^.DCT_scaled_size),
long (cinfo^.max_h_samp_factor * DCTSIZE)) );
compptr^.downsampled_height := JDIMENSION (
jdiv_round_up(long (cinfo^.image_height) *
long (compptr^.v_samp_factor * compptr^.DCT_scaled_size),
long (cinfo^.max_v_samp_factor * DCTSIZE)) );
Inc(compptr);
end;
{$else} { !IDCT_SCALING_SUPPORTED }
{ Hardwire it to "no scaling" }
cinfo^.output_width := cinfo^.image_width;
cinfo^.output_height := cinfo^.image_height;
{ jdinput.c has already initialized DCT_scaled_size to DCTSIZE,
and has computed unscaled downsampled_width and downsampled_height. }
{$endif} { IDCT_SCALING_SUPPORTED }
{ Report number of components in selected colorspace. }
{ Probably this should be in the color conversion module... }
case (cinfo^.out_color_space) of
JCS_GRAYSCALE:
cinfo^.out_color_components := 1;
{$ifndef RGB_PIXELSIZE_IS_3}
JCS_RGB:
cinfo^.out_color_components := RGB_PIXELSIZE;
{$else}
JCS_RGB,
{$endif} { else share code with YCbCr }
JCS_YCbCr:
cinfo^.out_color_components := 3;
JCS_CMYK,
JCS_YCCK:
cinfo^.out_color_components := 4;
else { else must be same colorspace as in file }
cinfo^.out_color_components := cinfo^.num_components;
end;
if (cinfo^.quantize_colors) then
cinfo^.output_components := 1
else
cinfo^.output_components := cinfo^.out_color_components;
{ See if upsampler will want to emit more than one row at a time }
if (use_merged_upsample(cinfo)) then
cinfo^.rec_outbuf_height := cinfo^.max_v_samp_factor
else
cinfo^.rec_outbuf_height := 1;
end;
{ Several decompression processes need to range-limit values to the range
0..MAXJSAMPLE; the input value may fall somewhat outside this range
due to noise introduced by quantization, roundoff error, etc. These
processes are inner loops and need to be as fast as possible. On most
machines, particularly CPUs with pipelines or instruction prefetch,
a (subscript-check-less) C table lookup
x := sample_range_limit[x];
is faster than explicit tests
if (x < 0) x := 0;
else if (x > MAXJSAMPLE) x := MAXJSAMPLE;
These processes all use a common table prepared by the routine below.
For most steps we can mathematically guarantee that the initial value
of x is within MAXJSAMPLE+1 of the legal range, so a table running from
-(MAXJSAMPLE+1) to 2*MAXJSAMPLE+1 is sufficient. But for the initial
limiting step (just after the IDCT), a wildly out-of-range value is
possible if the input data is corrupt. To avoid any chance of indexing
off the end of memory and getting a bad-pointer trap, we perform the
post-IDCT limiting thus:
x := range_limit[x & MASK];
where MASK is 2 bits wider than legal sample data, ie 10 bits for 8-bit
samples. Under normal circumstances this is more than enough range and
a correct output will be generated; with bogus input data the mask will
cause wraparound, and we will safely generate a bogus-but-in-range output.
For the post-IDCT step, we want to convert the data from signed to unsigned
representation by adding CENTERJSAMPLE at the same time that we limit it.
So the post-IDCT limiting table ends up looking like this:
CENTERJSAMPLE,CENTERJSAMPLE+1,...,MAXJSAMPLE,
MAXJSAMPLE (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times),
0 (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times),
0,1,...,CENTERJSAMPLE-1
Negative inputs select values from the upper half of the table after
masking.
We can save some space by overlapping the start of the post-IDCT table
with the simpler range limiting table. The post-IDCT table begins at
sample_range_limit + CENTERJSAMPLE.
Note that the table is allocated in near data space on PCs; it's small
enough and used often enough to justify this. }
{LOCAL}
procedure prepare_range_limit_table (cinfo : j_decompress_ptr);
{ Allocate and fill in the sample_range_limit table }
var
table : range_limit_table_ptr;
idct_table : JSAMPROW;
i : int;
begin
table := range_limit_table_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
(5 * (MAXJSAMPLE+1) + CENTERJSAMPLE) * SIZEOF(JSAMPLE)) );
{ First segment of "simple" table: limit[x] := 0 for x < 0 }
MEMZERO(table, (MAXJSAMPLE+1) * SIZEOF(JSAMPLE));
cinfo^.sample_range_limit := (table);
{ allow negative subscripts of simple table }
{ is noop, handled via type definition (Nomssi) }
{ Main part of "simple" table: limit[x] := x }
for i := 0 to MAXJSAMPLE do
table^[i] := JSAMPLE (i);
idct_table := JSAMPROW(@ table^[CENTERJSAMPLE]);
{ Point to where post-IDCT table starts }
{ End of simple table, rest of first half of post-IDCT table }
for i := CENTERJSAMPLE to pred(2*(MAXJSAMPLE+1)) do
idct_table^[i] := MAXJSAMPLE;
{ Second half of post-IDCT table }
MEMZERO(@(idct_table^[2 * (MAXJSAMPLE+1)]),
(2 * (MAXJSAMPLE+1) - CENTERJSAMPLE) * SIZEOF(JSAMPLE));
MEMCOPY(@(idct_table^[(4 * (MAXJSAMPLE+1) - CENTERJSAMPLE)]),
@cinfo^.sample_range_limit^[0], CENTERJSAMPLE * SIZEOF(JSAMPLE));
end;
{ Master selection of decompression modules.
This is done once at jpeg_start_decompress time. We determine
which modules will be used and give them appropriate initialization calls.
We also initialize the decompressor input side to begin consuming data.
Since jpeg_read_header has finished, we know what is in the SOF
and (first) SOS markers. We also have all the application parameter
settings. }
{LOCAL}
procedure master_selection (cinfo : j_decompress_ptr);
var
master : my_master_ptr;
use_c_buffer : boolean;
samplesperrow : long;
jd_samplesperrow : JDIMENSION;
var
nscans : int;
begin
master := my_master_ptr (cinfo^.master);
{ Initialize dimensions and other stuff }
jpeg_calc_output_dimensions(cinfo);
prepare_range_limit_table(cinfo);
{ Width of an output scanline must be representable as JDIMENSION. }
samplesperrow := long(cinfo^.output_width) * long (cinfo^.out_color_components);
jd_samplesperrow := JDIMENSION (samplesperrow);
if (long(jd_samplesperrow) <> samplesperrow) then
ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW);
{ Initialize my private state }
master^.pass_number := 0;
master^.using_merged_upsample := use_merged_upsample(cinfo);
{ Color quantizer selection }
master^.quantizer_1pass := NIL;
master^.quantizer_2pass := NIL;
{ No mode changes if not using buffered-image mode. }
if (not cinfo^.quantize_colors) or (not cinfo^.buffered_image) then
begin
cinfo^.enable_1pass_quant := FALSE;
cinfo^.enable_external_quant := FALSE;
cinfo^.enable_2pass_quant := FALSE;
end;
if (cinfo^.quantize_colors) then
begin
if (cinfo^.raw_data_out) then
ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL);
{ 2-pass quantizer only works in 3-component color space. }
if (cinfo^.out_color_components <> 3) then
begin
cinfo^.enable_1pass_quant := TRUE;
cinfo^.enable_external_quant := FALSE;
cinfo^.enable_2pass_quant := FALSE;
cinfo^.colormap := NIL;
end
else
if (cinfo^.colormap <> NIL) then
begin
cinfo^.enable_external_quant := TRUE;
end
else
if (cinfo^.two_pass_quantize) then
begin
cinfo^.enable_2pass_quant := TRUE;
end
else
begin
cinfo^.enable_1pass_quant := TRUE;
end;
if (cinfo^.enable_1pass_quant) then
begin
{$ifdef QUANT_1PASS_SUPPORTED}
jinit_1pass_quantizer(cinfo);
master^.quantizer_1pass := cinfo^.cquantize;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end;
{ We use the 2-pass code to map to external colormaps. }
if (cinfo^.enable_2pass_quant) or (cinfo^.enable_external_quant) then
begin
{$ifdef QUANT_2PASS_SUPPORTED}
jinit_2pass_quantizer(cinfo);
master^.quantizer_2pass := cinfo^.cquantize;
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end;
{ If both quantizers are initialized, the 2-pass one is left active;
this is necessary for starting with quantization to an external map. }
end;
{ Post-processing: in particular, color conversion first }
if (not cinfo^.raw_data_out) then
begin
if (master^.using_merged_upsample) then
begin
{$ifdef UPSAMPLE_MERGING_SUPPORTED}
jinit_merged_upsampler(cinfo); { does color conversion too }
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
begin
jinit_color_deconverter(cinfo);
jinit_upsampler(cinfo);
end;
jinit_d_post_controller(cinfo, cinfo^.enable_2pass_quant);
end;
{ Inverse DCT }
jinit_inverse_dct(cinfo);
{ Entropy decoding: either Huffman or arithmetic coding. }
if (cinfo^.arith_code) then
begin
ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL);
end
else
begin
if (cinfo^.progressive_mode) then
begin
{$ifdef D_PROGRESSIVE_SUPPORTED}
jinit_phuff_decoder(cinfo);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif}
end
else
jinit_huff_decoder(cinfo);
end;
{ Initialize principal buffer controllers. }
use_c_buffer := cinfo^.inputctl^.has_multiple_scans or cinfo^.buffered_image;
jinit_d_coef_controller(cinfo, use_c_buffer);
if (not cinfo^.raw_data_out) then
jinit_d_main_controller(cinfo, FALSE { never need full buffer here });
{ We can now tell the memory manager to allocate virtual arrays. }
cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo));
{ Initialize input side of decompressor to consume first scan. }
cinfo^.inputctl^.start_input_pass (cinfo);
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ If jpeg_start_decompress will read the whole file, initialize
progress monitoring appropriately. The input step is counted
as one pass. }
if (cinfo^.progress <> NIL) and (not cinfo^.buffered_image) and
(cinfo^.inputctl^.has_multiple_scans) then
begin
{ Estimate number of scans to set pass_limit. }
if (cinfo^.progressive_mode) then
begin
{ Arbitrarily estimate 2 interleaved DC scans + 3 AC scans/component. }
nscans := 2 + 3 * cinfo^.num_components;
end
else
begin
{ For a nonprogressive multiscan file, estimate 1 scan per component. }
nscans := cinfo^.num_components;
end;
cinfo^.progress^.pass_counter := Long(0);
cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows) * nscans;
cinfo^.progress^.completed_passes := 0;
if cinfo^.enable_2pass_quant then
cinfo^.progress^.total_passes := 3
else
cinfo^.progress^.total_passes := 2;
{ Count the input pass as done }
Inc(master^.pass_number);
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
end;
{ Per-pass setup.
This is called at the beginning of each output pass. We determine which
modules will be active during this pass and give them appropriate
start_pass calls. We also set is_dummy_pass to indicate whether this
is a "real" output pass or a dummy pass for color quantization.
(In the latter case, jdapistd.c will crank the pass to completion.) }
{METHODDEF}
procedure prepare_for_output_pass (cinfo : j_decompress_ptr);
var
master : my_master_ptr;
begin
master := my_master_ptr (cinfo^.master);
if (master^.pub.is_dummy_pass) then
begin
{$ifdef QUANT_2PASS_SUPPORTED}
{ Final pass of 2-pass quantization }
master^.pub.is_dummy_pass := FALSE;
cinfo^.cquantize^.start_pass (cinfo, FALSE);
cinfo^.post^.start_pass (cinfo, JBUF_CRANK_DEST);
cinfo^.main^.start_pass (cinfo, JBUF_CRANK_DEST);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
{$endif} { QUANT_2PASS_SUPPORTED }
end
else
begin
if (cinfo^.quantize_colors) and (cinfo^.colormap = NIL) then
begin
{ Select new quantization method }
if (cinfo^.two_pass_quantize) and (cinfo^.enable_2pass_quant) then
begin
cinfo^.cquantize := master^.quantizer_2pass;
master^.pub.is_dummy_pass := TRUE;
end
else
if (cinfo^.enable_1pass_quant) then
begin
cinfo^.cquantize := master^.quantizer_1pass;
end
else
begin
ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE);
end;
end;
cinfo^.idct^.start_pass (cinfo);
cinfo^.coef^.start_output_pass (cinfo);
if (not cinfo^.raw_data_out) then
begin
if (not master^.using_merged_upsample) then
cinfo^.cconvert^.start_pass (cinfo);
cinfo^.upsample^.start_pass (cinfo);
if (cinfo^.quantize_colors) then
cinfo^.cquantize^.start_pass (cinfo, master^.pub.is_dummy_pass);
if master^.pub.is_dummy_pass then
cinfo^.post^.start_pass (cinfo, JBUF_SAVE_AND_PASS)
else
cinfo^.post^.start_pass (cinfo, JBUF_PASS_THRU);
cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU);
end;
end;
{ Set up progress monitor's pass info if present }
if (cinfo^.progress <> NIL) then
begin
cinfo^.progress^.completed_passes := master^.pass_number;
if master^.pub.is_dummy_pass then
cinfo^.progress^.total_passes := master^.pass_number + 2
else
cinfo^.progress^.total_passes := master^.pass_number + 1;
{ In buffered-image mode, we assume one more output pass if EOI not
yet reached, but no more passes if EOI has been reached. }
if (cinfo^.buffered_image) and (not cinfo^.inputctl^.eoi_reached) then
begin
if cinfo^.enable_2pass_quant then
Inc(cinfo^.progress^.total_passes, 2)
else
Inc(cinfo^.progress^.total_passes, 1);
end;
end;
end;
{ Finish up at end of an output pass. }
{METHODDEF}
procedure finish_output_pass (cinfo : j_decompress_ptr);
var
master : my_master_ptr;
begin
master := my_master_ptr (cinfo^.master);
if (cinfo^.quantize_colors) then
cinfo^.cquantize^.finish_pass (cinfo);
Inc(master^.pass_number);
end;
{$ifdef D_MULTISCAN_FILES_SUPPORTED}
{ Switch to a new external colormap between output passes. }
{GLOBAL}
procedure jpeg_new_colormap (cinfo : j_decompress_ptr);
var
master : my_master_ptr;
begin
master := my_master_ptr (cinfo^.master);
{ Prevent application from calling me at wrong times }
if (cinfo^.global_state <> DSTATE_BUFIMAGE) then
ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
if (cinfo^.quantize_colors) and (cinfo^.enable_external_quant) and
(cinfo^.colormap <> NIL) then
begin
{ Select 2-pass quantizer for external colormap use }
cinfo^.cquantize := master^.quantizer_2pass;
{ Notify quantizer of colormap change }
cinfo^.cquantize^.new_color_map (cinfo);
master^.pub.is_dummy_pass := FALSE; { just in case }
end
else
ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE);
end;
{$endif} { D_MULTISCAN_FILES_SUPPORTED }
{ Initialize master decompression control and select active modules.
This is performed at the start of jpeg_start_decompress. }
{GLOBAL}
procedure jinit_master_decompress (cinfo : j_decompress_ptr);
var
master : my_master_ptr;
begin
master := my_master_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_decomp_master)) );
cinfo^.master := jpeg_decomp_master_ptr(master);
master^.pub.prepare_for_output_pass := prepare_for_output_pass;
master^.pub.finish_output_pass := finish_output_pass;
master^.pub.is_dummy_pass := FALSE;
master_selection(cinfo);
end;
end.

514
Imaging/JpegLib/imjdmerge.pas Normal file
View File

@@ -0,0 +1,514 @@
unit imjdmerge;
{ This file contains code for merged upsampling/color conversion.
This file combines functions from jdsample.c and jdcolor.c;
read those files first to understand what's going on.
When the chroma components are to be upsampled by simple replication
(ie, box filtering), we can save some work in color conversion by
calculating all the output pixels corresponding to a pair of chroma
samples at one time. In the conversion equations
R := Y + K1 * Cr
G := Y + K2 * Cb + K3 * Cr
B := Y + K4 * Cb
only the Y term varies among the group of pixels corresponding to a pair
of chroma samples, so the rest of the terms can be calculated just once.
At typical sampling ratios, this eliminates half or three-quarters of the
multiplications needed for color conversion.
This file currently provides implementations for the following cases:
YCbCr => RGB color conversion only.
Sampling ratios of 2h1v or 2h2v.
No scaling needed at upsample time.
Corner-aligned (non-CCIR601) sampling alignment.
Other special cases could be added, but in most applications these are
the only common cases. (For uncommon cases we fall back on the more
general code in jdsample.c and jdcolor.c.) }
{ Original: jdmerge.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjutils;
{ Module initialization routine for merged upsampling/color conversion.
NB: this is called under the conditions determined by use_merged_upsample()
in jdmaster.c. That routine MUST correspond to the actual capabilities
of this module; no safety checks are made here. }
{GLOBAL}
procedure jinit_merged_upsampler (cinfo : j_decompress_ptr);
implementation
{ Private subobject }
type { the same definition as in JdColor }
int_Color_Table = array[0..MAXJSAMPLE+1-1] of int;
int_CConvertPtr = ^int_Color_Table;
INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32;
INT32_CConvertPtr = ^INT32_Color_Table;
type
my_upsample_ptr = ^my_upsampler;
my_upsampler = record
pub : jpeg_upsampler; { public fields }
{ Pointer to routine to do actual upsampling/conversion of one row group }
upmethod : procedure (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
in_row_group_ctr : JDIMENSION;
output_buf : JSAMPARRAY);
{ Private state for YCC->RGB conversion }
Cr_r_tab : int_CConvertPtr; { => table for Cr to R conversion }
Cb_b_tab : int_CConvertPtr; { => table for Cb to B conversion }
Cr_g_tab : INT32_CConvertPtr; { => table for Cr to G conversion }
Cb_g_tab : INT32_CConvertPtr; { => table for Cb to G conversion }
{ For 2:1 vertical sampling, we produce two output rows at a time.
We need a "spare" row buffer to hold the second output row if the
application provides just a one-row buffer; we also use the spare
to discard the dummy last row if the image height is odd. }
spare_row : JSAMPROW;
spare_full : boolean; { TRUE if spare buffer is occupied }
out_row_width : JDIMENSION; { samples per output row }
rows_to_go : JDIMENSION; { counts rows remaining in image }
end; {my_upsampler;}
const
SCALEBITS = 16; { speediest right-shift on some machines }
ONE_HALF = (INT32(1) shl (SCALEBITS-1));
{ Initialize tables for YCC->RGB colorspace conversion.
This is taken directly from jdcolor.c; see that file for more info. }
{LOCAL}
procedure build_ycc_rgb_table (cinfo : j_decompress_ptr);
const
FIX_1_40200 = INT32( Round(1.40200 * (INT32(1) shl SCALEBITS)) );
FIX_1_77200 = INT32( Round(1.77200 * (INT32(1) shl SCALEBITS)) );
FIX_0_71414 = INT32( Round(0.71414 * (INT32(1) shl SCALEBITS)) );
FIX_0_34414 = INT32( Round(0.34414 * (INT32(1) shl SCALEBITS)) );
var
upsample : my_upsample_ptr;
i : int;
x : INT32;
var
shift_temp : INT32;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
upsample^.Cr_r_tab := int_CConvertPtr (
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(int)) );
upsample^.Cb_b_tab := int_CConvertPtr (
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(int)) );
upsample^.Cr_g_tab := INT32_CConvertPtr (
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(INT32)) );
upsample^.Cb_g_tab := INT32_CConvertPtr (
cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
(MAXJSAMPLE+1) * SIZEOF(INT32)) );
x := -CENTERJSAMPLE;
for i := 0 to pred(MAXJSAMPLE) do
begin
{ i is the actual input pixel value, in the range 0..MAXJSAMPLE }
{ The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE }
{ Cr=>R value is nearest int to 1.40200 * x }
{upsample^.Cr_r_tab^[i] := int(
RIGHT_SHIFT(FIX_1_40200 * x + ONE_HALF, SCALEBITS) );}
shift_temp := FIX_1_40200 * x + ONE_HALF;
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
upsample^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
upsample^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS);
{ Cb=>B value is nearest int to 1.77200 * x }
{upsample^.Cb_b_tab^[i] := int(
RIGHT_SHIFT(FIX_1_77200 * x + ONE_HALF, SCALEBITS) );}
shift_temp := FIX_1_77200 * x + ONE_HALF;
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
upsample^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
upsample^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS);
{ Cr=>G value is scaled-up -0.71414 * x }
upsample^.Cr_g_tab^[i] := (- FIX_0_71414) * x;
{ Cb=>G value is scaled-up -0.34414 * x }
{ We also add in ONE_HALF so that need not do it in inner loop }
upsample^.Cb_g_tab^[i] := (- FIX_0_34414) * x + ONE_HALF;
Inc(x);
end;
end;
{ Initialize for an upsampling pass. }
{METHODDEF}
procedure start_pass_merged_upsample (cinfo : j_decompress_ptr);
var
upsample : my_upsample_ptr;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
{ Mark the spare buffer empty }
upsample^.spare_full := FALSE;
{ Initialize total-height counter for detecting bottom of image }
upsample^.rows_to_go := cinfo^.output_height;
end;
{ Control routine to do upsampling (and color conversion).
The control routine just handles the row buffering considerations. }
{METHODDEF}
procedure merged_2v_upsample (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
{ 2:1 vertical sampling case: may need a spare row. }
var
upsample : my_upsample_ptr;
work_ptrs : array[0..2-1] of JSAMPROW;
num_rows : JDIMENSION; { number of rows returned to caller }
begin
upsample := my_upsample_ptr (cinfo^.upsample);
if (upsample^.spare_full) then
begin
{ If we have a spare row saved from a previous cycle, just return it. }
jcopy_sample_rows(JSAMPARRAY(@upsample^.spare_row),
0,
JSAMPARRAY(@ output_buf^[out_row_ctr]),
0, 1, upsample^.out_row_width);
num_rows := 1;
upsample^.spare_full := FALSE;
end
else
begin
{ Figure number of rows to return to caller. }
num_rows := 2;
{ Not more than the distance to the end of the image. }
if (num_rows > upsample^.rows_to_go) then
num_rows := upsample^.rows_to_go;
{ And not more than what the client can accept: }
Dec(out_rows_avail, {var} out_row_ctr);
if (num_rows > out_rows_avail) then
num_rows := out_rows_avail;
{ Create output pointer array for upsampler. }
work_ptrs[0] := output_buf^[out_row_ctr];
if (num_rows > 1) then
begin
work_ptrs[1] := output_buf^[out_row_ctr + 1];
end
else
begin
work_ptrs[1] := upsample^.spare_row;
upsample^.spare_full := TRUE;
end;
{ Now do the upsampling. }
upsample^.upmethod (cinfo, input_buf, {var}in_row_group_ctr,
JSAMPARRAY(@work_ptrs));
end;
{ Adjust counts }
Inc(out_row_ctr, num_rows);
Dec(upsample^.rows_to_go, num_rows);
{ When the buffer is emptied, declare this input row group consumed }
if (not upsample^.spare_full) then
Inc(in_row_group_ctr);
end;
{METHODDEF}
procedure merged_1v_upsample (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
{ 1:1 vertical sampling case: much easier, never need a spare row. }
var
upsample : my_upsample_ptr;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
{ Just do the upsampling. }
upsample^.upmethod (cinfo, input_buf, in_row_group_ctr,
JSAMPARRAY(@ output_buf^[out_row_ctr]));
{ Adjust counts }
Inc(out_row_ctr);
Inc(in_row_group_ctr);
end;
{ These are the routines invoked by the control routines to do
the actual upsampling/conversion. One row group is processed per call.
Note: since we may be writing directly into application-supplied buffers,
we have to be honest about the output width; we can't assume the buffer
has been rounded up to an even width. }
{ Upsample and color convert for the case of 2:1 horizontal and 1:1 vertical. }
{METHODDEF}
procedure h2v1_merged_upsample (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
in_row_group_ctr : JDIMENSION;
output_buf : JSAMPARRAY);
var
upsample : my_upsample_ptr;
{register} y, cred, cgreen, cblue : int;
cb, cr : int;
{register} outptr : JSAMPROW;
inptr0, inptr1, inptr2 : JSAMPLE_PTR;
col : JDIMENSION;
{ copy these pointers into registers if possible }
{register} range_limit : range_limit_table_ptr;
Crrtab : int_CConvertPtr;
Cbbtab : int_CConvertPtr;
Crgtab : INT32_CConvertPtr;
Cbgtab : INT32_CConvertPtr;
var
shift_temp : INT32;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
range_limit := cinfo^.sample_range_limit;
Crrtab := upsample^.Cr_r_tab;
Cbbtab := upsample^.Cb_b_tab;
Crgtab := upsample^.Cr_g_tab;
Cbgtab := upsample^.Cb_g_tab;
inptr0 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr]);
inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]);
inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]);
outptr := output_buf^[0];
{ Loop for each pair of output pixels }
for col := pred(cinfo^.output_width shr 1) downto 0 do
begin
{ Do the chroma part of the calculation }
cb := GETJSAMPLE(inptr1^);
Inc(inptr1);
cr := GETJSAMPLE(inptr2^);
Inc(inptr2);
cred := Crrtab^[cr];
{cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );}
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cgreen := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cgreen := int(shift_temp shr SCALEBITS);
cblue := Cbbtab^[cb];
{ Fetch 2 Y values and emit 2 pixels }
y := GETJSAMPLE(inptr0^);
Inc(inptr0);
outptr^[RGB_RED] := range_limit^[y + cred];
outptr^[RGB_GREEN] := range_limit^[y + cgreen];
outptr^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE);
y := GETJSAMPLE(inptr0^);
Inc(inptr0);
outptr^[RGB_RED] := range_limit^[y + cred];
outptr^[RGB_GREEN] := range_limit^[y + cgreen];
outptr^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE);
end;
{ If image width is odd, do the last output column separately }
if Odd(cinfo^.output_width) then
begin
cb := GETJSAMPLE(inptr1^);
cr := GETJSAMPLE(inptr2^);
cred := Crrtab^[cr];
{cgreen := int ( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );}
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cgreen := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cgreen := int(shift_temp shr SCALEBITS);
cblue := Cbbtab^[cb];
y := GETJSAMPLE(inptr0^);
outptr^[RGB_RED] := range_limit^[y + cred];
outptr^[RGB_GREEN] := range_limit^[y + cgreen];
outptr^[RGB_BLUE] := range_limit^[y + cblue];
end;
end;
{ Upsample and color convert for the case of 2:1 horizontal and 2:1 vertical. }
{METHODDEF}
procedure h2v2_merged_upsample (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
in_row_group_ctr : JDIMENSION;
output_buf : JSAMPARRAY);
var
upsample : my_upsample_ptr;
{register} y, cred, cgreen, cblue : int;
cb, cr : int;
{register} outptr0, outptr1 : JSAMPROW;
inptr00, inptr01, inptr1, inptr2 : JSAMPLE_PTR;
col : JDIMENSION;
{ copy these pointers into registers if possible }
{register} range_limit : range_limit_table_ptr;
Crrtab : int_CConvertPtr;
Cbbtab : int_CConvertPtr;
Crgtab : INT32_CConvertPtr;
Cbgtab : INT32_CConvertPtr;
var
shift_temp : INT32;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
range_limit := cinfo^.sample_range_limit;
Crrtab := upsample^.Cr_r_tab;
Cbbtab := upsample^.Cb_b_tab;
Crgtab := upsample^.Cr_g_tab;
Cbgtab := upsample^.Cb_g_tab;
inptr00 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2]);
inptr01 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2 + 1]);
inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]);
inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]);
outptr0 := output_buf^[0];
outptr1 := output_buf^[1];
{ Loop for each group of output pixels }
for col := pred(cinfo^.output_width shr 1) downto 0 do
begin
{ Do the chroma part of the calculation }
cb := GETJSAMPLE(inptr1^);
Inc(inptr1);
cr := GETJSAMPLE(inptr2^);
Inc(inptr2);
cred := Crrtab^[cr];
{cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );}
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cgreen := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cgreen := int(shift_temp shr SCALEBITS);
cblue := Cbbtab^[cb];
{ Fetch 4 Y values and emit 4 pixels }
y := GETJSAMPLE(inptr00^);
Inc(inptr00);
outptr0^[RGB_RED] := range_limit^[y + cred];
outptr0^[RGB_GREEN] := range_limit^[y + cgreen];
outptr0^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE);
y := GETJSAMPLE(inptr00^);
Inc(inptr00);
outptr0^[RGB_RED] := range_limit^[y + cred];
outptr0^[RGB_GREEN] := range_limit^[y + cgreen];
outptr0^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE);
y := GETJSAMPLE(inptr01^);
Inc(inptr01);
outptr1^[RGB_RED] := range_limit^[y + cred];
outptr1^[RGB_GREEN] := range_limit^[y + cgreen];
outptr1^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE);
y := GETJSAMPLE(inptr01^);
Inc(inptr01);
outptr1^[RGB_RED] := range_limit^[y + cred];
outptr1^[RGB_GREEN] := range_limit^[y + cgreen];
outptr1^[RGB_BLUE] := range_limit^[y + cblue];
Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE);
end;
{ If image width is odd, do the last output column separately }
if Odd(cinfo^.output_width) then
begin
cb := GETJSAMPLE(inptr1^);
cr := GETJSAMPLE(inptr2^);
cred := Crrtab^[cr];
{cgreen := int (RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS));}
shift_temp := Cbgtab^[cb] + Crgtab^[cr];
if shift_temp < 0 then { SHIFT arithmetic RIGHT }
cgreen := int((shift_temp shr SCALEBITS)
or ( (not INT32(0)) shl (32-SCALEBITS)))
else
cgreen := int(shift_temp shr SCALEBITS);
cblue := Cbbtab^[cb];
y := GETJSAMPLE(inptr00^);
outptr0^[RGB_RED] := range_limit^[y + cred];
outptr0^[RGB_GREEN] := range_limit^[y + cgreen];
outptr0^[RGB_BLUE] := range_limit^[y + cblue];
y := GETJSAMPLE(inptr01^);
outptr1^[RGB_RED] := range_limit^[y + cred];
outptr1^[RGB_GREEN] := range_limit^[y + cgreen];
outptr1^[RGB_BLUE] := range_limit^[y + cblue];
end;
end;
{ Module initialization routine for merged upsampling/color conversion.
NB: this is called under the conditions determined by use_merged_upsample()
in jdmaster.c. That routine MUST correspond to the actual capabilities
of this module; no safety checks are made here. }
{GLOBAL}
procedure jinit_merged_upsampler (cinfo : j_decompress_ptr);
var
upsample : my_upsample_ptr;
begin
upsample := my_upsample_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_upsampler)) );
cinfo^.upsample := jpeg_upsampler_ptr (upsample);
upsample^.pub.start_pass := start_pass_merged_upsample;
upsample^.pub.need_context_rows := FALSE;
upsample^.out_row_width := cinfo^.output_width * JDIMENSION(cinfo^.out_color_components);
if (cinfo^.max_v_samp_factor = 2) then
begin
upsample^.pub.upsample := merged_2v_upsample;
upsample^.upmethod := h2v2_merged_upsample;
{ Allocate a spare row buffer }
upsample^.spare_row := JSAMPROW(
cinfo^.mem^.alloc_large ( j_common_ptr(cinfo), JPOOL_IMAGE,
size_t (upsample^.out_row_width * SIZEOF(JSAMPLE))) );
end
else
begin
upsample^.pub.upsample := merged_1v_upsample;
upsample^.upmethod := h2v1_merged_upsample;
{ No spare row needed }
upsample^.spare_row := NIL;
end;
build_ycc_rgb_table(cinfo);
end;
end.

1061
Imaging/JpegLib/imjdphuff.pas Normal file
View File

File diff suppressed because it is too large Load Diff

341
Imaging/JpegLib/imjdpostct.pas Normal file
View File

@@ -0,0 +1,341 @@
unit imjdpostct;
{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
{ This file contains the decompression postprocessing controller.
This controller manages the upsampling, color conversion, and color
quantization/reduction steps; specifically, it controls the buffering
between upsample/color conversion and color quantization/reduction.
If no color quantization/reduction is required, then this module has no
work to do, and it just hands off to the upsample/color conversion code.
An integrated upsample/convert/quantize process would replace this module
entirely. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjdeferr,
imjerror,
imjutils,
imjpeglib;
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
implementation
{ Private buffer controller object }
type
my_post_ptr = ^my_post_controller;
my_post_controller = record
pub : jpeg_d_post_controller; { public fields }
{ Color quantization source buffer: this holds output data from
the upsample/color conversion step to be passed to the quantizer.
For two-pass color quantization, we need a full-image buffer;
for one-pass operation, a strip buffer is sufficient. }
whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass }
buffer : JSAMPARRAY; { strip buffer, or current strip of virtual }
strip_height : JDIMENSION; { buffer size in rows }
{ for two-pass mode only: }
starting_row : JDIMENSION; { row # of first row in current strip }
next_row : JDIMENSION; { index of next row to fill/empty in strip }
end;
{ Forward declarations }
{METHODDEF}
procedure post_process_1pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$ifdef QUANT_2PASS_SUPPORTED}
{METHODDEF}
procedure post_process_prepass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{METHODDEF}
procedure post_process_2pass(cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION); forward;
{$endif}
{ Initialize for a processing pass. }
{METHODDEF}
procedure start_pass_dpost (cinfo : j_decompress_ptr;
pass_mode : J_BUF_MODE);
var
post : my_post_ptr;
begin
post := my_post_ptr(cinfo^.post);
case (pass_mode) of
JBUF_PASS_THRU:
if (cinfo^.quantize_colors) then
begin
{ Single-pass processing with color quantization. }
post^.pub.post_process_data := post_process_1pass;
{ We could be doing buffered-image output before starting a 2-pass
color quantization; in that case, jinit_d_post_controller did not
allocate a strip buffer. Use the virtual-array buffer as workspace. }
if (post^.buffer = NIL) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
JDIMENSION(0), post^.strip_height, TRUE);
end;
end
else
begin
{ For single-pass processing without color quantization,
I have no work to do; just call the upsampler directly. }
post^.pub.post_process_data := cinfo^.upsample^.upsample;
end;
{$ifdef QUANT_2PASS_SUPPORTED}
JBUF_SAVE_AND_PASS:
begin
{ First pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_prepass;
end;
JBUF_CRANK_DEST:
begin
{ Second pass of 2-pass quantization }
if (post^.whole_image = NIL) then
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
post^.pub.post_process_data := post_process_2pass;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
else
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
end;
post^.next_row := 0;
post^.starting_row := 0;
end;
{ Process some data in the one-pass (strip buffer) case.
This is used for color precision reduction as well as one-pass quantization. }
{METHODDEF}
procedure post_process_1pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr (cinfo^.post);
{ Fill the buffer, but not more than what we can dump out in one go. }
{ Note we rely on the upsampler to detect bottom of image. }
max_rows := out_rows_avail - out_row_ctr;
if (max_rows > post^.strip_height) then
max_rows := post^.strip_height;
num_rows := 0;
cinfo^.upsample^.upsample (cinfo,
input_buf,
in_row_group_ctr,
in_row_groups_avail,
post^.buffer,
num_rows, { var }
max_rows);
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
post^.buffer,
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{$ifdef QUANT_2PASS_SUPPORTED}
{ Process some data in the first pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_prepass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail:JDIMENSION);
var
post : my_post_ptr;
old_next_row, num_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, TRUE);
end;
{ Upsample some data (up to a strip height's worth). }
old_next_row := post^.next_row;
cinfo^.upsample^.upsample (cinfo,
input_buf, in_row_group_ctr, in_row_groups_avail,
post^.buffer, post^.next_row, post^.strip_height);
{ Allow quantizer to scan new data. No data is emitted, }
{ but we advance out_row_ctr so outer loop can tell when we're done. }
if (post^.next_row > old_next_row) then
begin
num_rows := post^.next_row - old_next_row;
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[old_next_row]),
JSAMPARRAY(NIL),
int(num_rows));
Inc(out_row_ctr, num_rows);
end;
{ Advance if we filled the strip. }
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{ Process some data in the second pass of 2-pass quantization. }
{METHODDEF}
procedure post_process_2pass (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
post : my_post_ptr;
num_rows, max_rows : JDIMENSION;
begin
post := my_post_ptr(cinfo^.post);
{ Reposition virtual buffer if at start of strip. }
if (post^.next_row = 0) then
begin
post^.buffer := cinfo^.mem^.access_virt_sarray
(j_common_ptr(cinfo), post^.whole_image,
post^.starting_row, post^.strip_height, FALSE);
end;
{ Determine number of rows to emit. }
num_rows := post^.strip_height - post^.next_row; { available in strip }
max_rows := out_rows_avail - out_row_ctr; { available in output area }
if (num_rows > max_rows) then
num_rows := max_rows;
{ We have to check bottom of image here, can't depend on upsampler. }
max_rows := cinfo^.output_height - post^.starting_row;
if (num_rows > max_rows) then
num_rows := max_rows;
{ Quantize and emit data. }
cinfo^.cquantize^.color_quantize (cinfo,
JSAMPARRAY(@ post^.buffer^[post^.next_row]),
JSAMPARRAY(@ output_buf^[out_row_ctr]),
int(num_rows));
Inc(out_row_ctr, num_rows);
{ Advance if we filled the strip. }
Inc(post^.next_row, num_rows);
if (post^.next_row >= post^.strip_height) then
begin
Inc(post^.starting_row, post^.strip_height);
post^.next_row := 0;
end;
end;
{$endif} { QUANT_2PASS_SUPPORTED }
{ Initialize postprocessing controller. }
{GLOBAL}
procedure jinit_d_post_controller (cinfo : j_decompress_ptr;
need_full_buffer : boolean);
var
post : my_post_ptr;
begin
post := my_post_ptr(
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_post_controller)) );
cinfo^.post := jpeg_d_post_controller_ptr (post);
post^.pub.start_pass := start_pass_dpost;
post^.whole_image := NIL; { flag for no virtual arrays }
post^.buffer := NIL; { flag for no strip buffer }
{ Create the quantization buffer, if needed }
if (cinfo^.quantize_colors) then
begin
{ The buffer strip height is max_v_samp_factor, which is typically
an efficient number of rows for upsampling to return.
(In the presence of output rescaling, we might want to be smarter?) }
post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor);
if (need_full_buffer) then
begin
{ Two-pass color quantization: need full-image storage. }
{ We round up the number of rows to a multiple of the strip height. }
{$ifdef QUANT_2PASS_SUPPORTED}
post^.whole_image := cinfo^.mem^.request_virt_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, FALSE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
JDIMENSION (jround_up( long(cinfo^.output_height),
long(post^.strip_height)) ),
post^.strip_height);
{$else}
ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE);
{$endif} { QUANT_2PASS_SUPPORTED }
end
else
begin
{ One-pass color quantization: just make a strip buffer. }
post^.buffer := cinfo^.mem^.alloc_sarray
(j_common_ptr (cinfo), JPOOL_IMAGE,
LongInt(cinfo^.output_width) * cinfo^.out_color_components,
post^.strip_height);
end;
end;
end;
end.

592
Imaging/JpegLib/imjdsample.pas Normal file
View File

@@ -0,0 +1,592 @@
unit imjdsample;
{ Original: jdsample.c; Copyright (C) 1991-1996, Thomas G. Lane. }
{ This file contains upsampling routines.
Upsampling input data is counted in "row groups". A row group
is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size)
sample rows of each component. Upsampling will normally produce
max_v_samp_factor pixel rows from each row group (but this could vary
if the upsampler is applying a scale factor of its own).
An excellent reference for image resampling is
Digital Image Warping, George Wolberg, 1990.
Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7.}
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjpeglib,
imjdeferr,
imjerror;
{ Pointer to routine to upsample a single component }
type
upsample1_ptr = procedure (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
{ Module initialization routine for upsampling. }
{GLOBAL}
procedure jinit_upsampler (cinfo : j_decompress_ptr);
implementation
{ Private subobject }
type
my_upsample_ptr = ^my_upsampler;
my_upsampler = record
pub : jpeg_upsampler; { public fields }
{ Color conversion buffer. When using separate upsampling and color
conversion steps, this buffer holds one upsampled row group until it
has been color converted and output.
Note: we do not allocate any storage for component(s) which are full-size,
ie do not need rescaling. The corresponding entry of color_buf[] is
simply set to point to the input data array, thereby avoiding copying.}
color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY;
{ Per-component upsampling method pointers }
methods : array[0..MAX_COMPONENTS-1] of upsample1_ptr;
next_row_out : int; { counts rows emitted from color_buf }
rows_to_go : JDIMENSION; { counts rows remaining in image }
{ Height of an input row group for each component. }
rowgroup_height : array[0..MAX_COMPONENTS-1] of int;
{ These arrays save pixel expansion factors so that int_expand need not
recompute them each time. They are unused for other upsampling methods.}
h_expand : array[0..MAX_COMPONENTS-1] of UINT8 ;
v_expand : array[0..MAX_COMPONENTS-1] of UINT8 ;
end;
{ Initialize for an upsampling pass. }
{METHODDEF}
procedure start_pass_upsample (cinfo : j_decompress_ptr);
var
upsample : my_upsample_ptr;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
{ Mark the conversion buffer empty }
upsample^.next_row_out := cinfo^.max_v_samp_factor;
{ Initialize total-height counter for detecting bottom of image }
upsample^.rows_to_go := cinfo^.output_height;
end;
{ Control routine to do upsampling (and color conversion).
In this version we upsample each component independently.
We upsample one row group into the conversion buffer, then apply
color conversion a row at a time. }
{METHODDEF}
procedure sep_upsample (cinfo : j_decompress_ptr;
input_buf : JSAMPIMAGE;
var in_row_group_ctr : JDIMENSION;
in_row_groups_avail : JDIMENSION;
output_buf : JSAMPARRAY;
var out_row_ctr : JDIMENSION;
out_rows_avail : JDIMENSION);
var
upsample : my_upsample_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
num_rows : JDIMENSION;
begin
upsample := my_upsample_ptr (cinfo^.upsample);
{ Fill the conversion buffer, if it's empty }
if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then
begin
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Invoke per-component upsample method. Notice we pass a POINTER
to color_buf[ci], so that fullsize_upsample can change it. }
upsample^.methods[ci] (cinfo, compptr,
JSAMPARRAY(@ input_buf^[ci]^
[LongInt(in_row_group_ctr) * upsample^.rowgroup_height[ci]]),
upsample^.color_buf[ci]);
Inc(compptr);
end;
upsample^.next_row_out := 0;
end;
{ Color-convert and emit rows }
{ How many we have in the buffer: }
num_rows := JDIMENSION (cinfo^.max_v_samp_factor - upsample^.next_row_out);
{ Not more than the distance to the end of the image. Need this test
in case the image height is not a multiple of max_v_samp_factor: }
if (num_rows > upsample^.rows_to_go) then
num_rows := upsample^.rows_to_go;
{ And not more than what the client can accept: }
Dec(out_rows_avail, out_row_ctr);
if (num_rows > out_rows_avail) then
num_rows := out_rows_avail;
cinfo^.cconvert^.color_convert (cinfo,
JSAMPIMAGE(@(upsample^.color_buf)),
JDIMENSION (upsample^.next_row_out),
JSAMPARRAY(@(output_buf^[out_row_ctr])),
int (num_rows));
{ Adjust counts }
Inc(out_row_ctr, num_rows);
Dec(upsample^.rows_to_go, num_rows);
Inc(upsample^.next_row_out, num_rows);
{ When the buffer is emptied, declare this input row group consumed }
if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then
Inc(in_row_group_ctr);
end;
{ These are the routines invoked by sep_upsample to upsample pixel values
of a single component. One row group is processed per call. }
{ For full-size components, we just make color_buf[ci] point at the
input buffer, and thus avoid copying any data. Note that this is
safe only because sep_upsample doesn't declare the input row group
"consumed" until we are done color converting and emitting it. }
{METHODDEF}
procedure fullsize_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
begin
output_data_ptr := input_data;
end;
{ This is a no-op version used for "uninteresting" components.
These components will not be referenced by color conversion. }
{METHODDEF}
procedure noop_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
begin
output_data_ptr := NIL; { safety check }
end;
{ This version handles any integral sampling ratios.
This is not used for typical JPEG files, so it need not be fast.
Nor, for that matter, is it particularly accurate: the algorithm is
simple replication of the input pixel onto the corresponding output
pixels. The hi-falutin sampling literature refers to this as a
"box filter". A box filter tends to introduce visible artifacts,
so if you are actually going to use 3:1 or 4:1 sampling ratios
you would be well advised to improve this code. }
{METHODDEF}
procedure int_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
var
upsample : my_upsample_ptr;
output_data : JSAMPARRAY;
{register} inptr, outptr : JSAMPLE_PTR;
{register} invalue : JSAMPLE;
{register} h : int;
{outend}
h_expand, v_expand : int;
inrow, outrow : int;
var
outcount : int; { Nomssi: avoid pointer arithmetic }
begin
upsample := my_upsample_ptr (cinfo^.upsample);
output_data := output_data_ptr;
h_expand := upsample^.h_expand[compptr^.component_index];
v_expand := upsample^.v_expand[compptr^.component_index];
inrow := 0;
outrow := 0;
while (outrow < cinfo^.max_v_samp_factor) do
begin
{ Generate one output row with proper horizontal expansion }
inptr := JSAMPLE_PTR(input_data^[inrow]);
outptr := JSAMPLE_PTR(output_data^[outrow]);
outcount := cinfo^.output_width;
while (outcount > 0) do { Nomssi }
begin
invalue := inptr^; { don't need GETJSAMPLE() here }
Inc(inptr);
for h := pred(h_expand) downto 0 do
begin
outptr^ := invalue;
inc(outptr); { <-- fix: this was left out in PasJpeg 1.0 }
Dec(outcount); { thanks to Jannie Gerber for the report }
end;
end;
{ Generate any additional output rows by duplicating the first one }
if (v_expand > 1) then
begin
jcopy_sample_rows(output_data, outrow, output_data, outrow+1,
v_expand-1, cinfo^.output_width);
end;
Inc(inrow);
Inc(outrow, v_expand);
end;
end;
{ Fast processing for the common case of 2:1 horizontal and 1:1 vertical.
It's still a box filter. }
{METHODDEF}
procedure h2v1_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
var
output_data : JSAMPARRAY;
{register} inptr, outptr : JSAMPLE_PTR;
{register} invalue : JSAMPLE;
{outend : JSAMPROW;}
outcount : int;
inrow : int;
begin
output_data := output_data_ptr;
for inrow := 0 to pred(cinfo^.max_v_samp_factor) do
begin
inptr := JSAMPLE_PTR(input_data^[inrow]);
outptr := JSAMPLE_PTR(output_data^[inrow]);
{outend := outptr + cinfo^.output_width;}
outcount := cinfo^.output_width;
while (outcount > 0) do
begin
invalue := inptr^; { don't need GETJSAMPLE() here }
Inc(inptr);
outptr^ := invalue;
Inc(outptr);
outptr^ := invalue;
Inc(outptr);
Dec(outcount, 2); { Nomssi: to avoid pointer arithmetic }
end;
end;
end;
{ Fast processing for the common case of 2:1 horizontal and 2:1 vertical.
It's still a box filter. }
{METHODDEF}
procedure h2v2_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
var
output_data : JSAMPARRAY;
{register} inptr, outptr : JSAMPLE_PTR;
{register} invalue : JSAMPLE;
{outend : JSAMPROW;}
outcount : int;
inrow, outrow : int;
begin
output_data := output_data_ptr;
inrow := 0;
outrow := 0;
while (outrow < cinfo^.max_v_samp_factor) do
begin
inptr := JSAMPLE_PTR(input_data^[inrow]);
outptr := JSAMPLE_PTR(output_data^[outrow]);
{outend := outptr + cinfo^.output_width;}
outcount := cinfo^.output_width;
while (outcount > 0) do
begin
invalue := inptr^; { don't need GETJSAMPLE() here }
Inc(inptr);
outptr^ := invalue;
Inc(outptr);
outptr^ := invalue;
Inc(outptr);
Dec(outcount, 2);
end;
jcopy_sample_rows(output_data, outrow, output_data, outrow+1,
1, cinfo^.output_width);
Inc(inrow);
Inc(outrow, 2);
end;
end;
{ Fancy processing for the common case of 2:1 horizontal and 1:1 vertical.
The upsampling algorithm is linear interpolation between pixel centers,
also known as a "triangle filter". This is a good compromise between
speed and visual quality. The centers of the output pixels are 1/4 and 3/4
of the way between input pixel centers.
A note about the "bias" calculations: when rounding fractional values to
integer, we do not want to always round 0.5 up to the next integer.
If we did that, we'd introduce a noticeable bias towards larger values.
Instead, this code is arranged so that 0.5 will be rounded up or down at
alternate pixel locations (a simple ordered dither pattern). }
{METHODDEF}
procedure h2v1_fancy_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
var
output_data : JSAMPARRAY;
{register} pre_inptr, inptr, outptr : JSAMPLE_PTR;
{register} invalue : int;
{register} colctr : JDIMENSION;
inrow : int;
begin
output_data := output_data_ptr;
for inrow := 0 to pred(cinfo^.max_v_samp_factor) do
begin
inptr := JSAMPLE_PTR(input_data^[inrow]);
outptr := JSAMPLE_PTR(output_data^[inrow]);
{ Special case for first column }
pre_inptr := inptr;
invalue := GETJSAMPLE(inptr^);
Inc(inptr);
outptr^ := JSAMPLE (invalue);
Inc(outptr);
outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(inptr^) + 2) shr 2);
Inc(outptr);
for colctr := pred(compptr^.downsampled_width - 2) downto 0 do
begin
{ General case: 3/4 * nearer pixel + 1/4 * further pixel }
invalue := GETJSAMPLE(inptr^) * 3;
Inc(inptr);
outptr^ := JSAMPLE ((invalue + GETJSAMPLE(pre_inptr^) + 1) shr 2);
Inc(pre_inptr);
Inc(outptr);
outptr^ := JSAMPLE ((invalue + GETJSAMPLE(inptr^) + 2) shr 2);
Inc(outptr);
end;
{ Special case for last column }
invalue := GETJSAMPLE(inptr^);
outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(pre_inptr^) + 1) shr 2);
Inc(outptr);
outptr^ := JSAMPLE (invalue);
{Inc(outptr); - value never used }
end;
end;
{ Fancy processing for the common case of 2:1 horizontal and 2:1 vertical.
Again a triangle filter; see comments for h2v1 case, above.
It is OK for us to reference the adjacent input rows because we demanded
context from the main buffer controller (see initialization code). }
{METHODDEF}
procedure h2v2_fancy_upsample (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
input_data : JSAMPARRAY;
var output_data_ptr : JSAMPARRAY);
var
output_data : JSAMPARRAY;
{register} inptr0, inptr1, outptr : JSAMPLE_PTR;
{$ifdef BITS_IN_JSAMPLE_IS_8}
{register} thiscolsum, lastcolsum, nextcolsum : int;
{$else}
{register} thiscolsum, lastcolsum, nextcolsum : INT32;
{$endif}
{register} colctr : JDIMENSION;
inrow, outrow, v : int;
var
prev_input_data : JSAMPARRAY; { Nomssi work around }
begin
output_data := output_data_ptr;
outrow := 0;
inrow := 0;
while (outrow < cinfo^.max_v_samp_factor) do
begin
for v := 0 to pred(2) do
begin
{ inptr0 points to nearest input row, inptr1 points to next nearest }
inptr0 := JSAMPLE_PTR(input_data^[inrow]);
if (v = 0) then { next nearest is row above }
begin
{inptr1 := JSAMPLE_PTR(input_data^[inrow-1]);}
prev_input_data := input_data; { work around }
Dec(JSAMPROW_PTR(prev_input_data)); { negative offsets }
inptr1 := JSAMPLE_PTR(prev_input_data^[inrow]);
end
else { next nearest is row below }
inptr1 := JSAMPLE_PTR(input_data^[inrow+1]);
outptr := JSAMPLE_PTR(output_data^[outrow]);
Inc(outrow);
{ Special case for first column }
thiscolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^);
Inc(inptr0);
Inc(inptr1);
nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^);
Inc(inptr0);
Inc(inptr1);
outptr^ := JSAMPLE ((thiscolsum * 4 + 8) shr 4);
Inc(outptr);
outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4);
Inc(outptr);
lastcolsum := thiscolsum; thiscolsum := nextcolsum;
for colctr := pred(compptr^.downsampled_width - 2) downto 0 do
begin
{ General case: 3/4 * nearer pixel + 1/4 * further pixel in each }
{ dimension, thus 9/16, 3/16, 3/16, 1/16 overall }
nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^);
Inc(inptr0);
Inc(inptr1);
outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4);
Inc(outptr);
outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4);
Inc(outptr);
lastcolsum := thiscolsum;
thiscolsum := nextcolsum;
end;
{ Special case for last column }
outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4);
Inc(outptr);
outptr^ := JSAMPLE ((thiscolsum * 4 + 7) shr 4);
{Inc(outptr); - value never used }
end;
Inc(inrow);
end;
end;
{ Module initialization routine for upsampling. }
{GLOBAL}
procedure jinit_upsampler (cinfo : j_decompress_ptr);
var
upsample : my_upsample_ptr;
ci : int;
compptr : jpeg_component_info_ptr;
need_buffer, do_fancy : boolean;
h_in_group, v_in_group, h_out_group, v_out_group : int;
begin
upsample := my_upsample_ptr (
cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
SIZEOF(my_upsampler)) );
cinfo^.upsample := jpeg_upsampler_ptr (upsample);
upsample^.pub.start_pass := start_pass_upsample;
upsample^.pub.upsample := sep_upsample;
upsample^.pub.need_context_rows := FALSE; { until we find out differently }
if (cinfo^.CCIR601_sampling) then { this isn't supported }
ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL);
{ jdmainct.c doesn't support context rows when min_DCT_scaled_size := 1,
so don't ask for it. }
do_fancy := cinfo^.do_fancy_upsampling and (cinfo^.min_DCT_scaled_size > 1);
{ Verify we can handle the sampling factors, select per-component methods,
and create storage as needed. }
compptr := jpeg_component_info_ptr(cinfo^.comp_info);
for ci := 0 to pred(cinfo^.num_components) do
begin
{ Compute size of an "input group" after IDCT scaling. This many samples
are to be converted to max_h_samp_factor * max_v_samp_factor pixels. }
h_in_group := (compptr^.h_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size;
v_in_group := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div
cinfo^.min_DCT_scaled_size;
h_out_group := cinfo^.max_h_samp_factor;
v_out_group := cinfo^.max_v_samp_factor;
upsample^.rowgroup_height[ci] := v_in_group; { save for use later }
need_buffer := TRUE;
if (not compptr^.component_needed) then
begin
{ Don't bother to upsample an uninteresting component. }
upsample^.methods[ci] := noop_upsample;
need_buffer := FALSE;
end
else
if (h_in_group = h_out_group) and (v_in_group = v_out_group) then
begin
{ Fullsize components can be processed without any work. }
upsample^.methods[ci] := fullsize_upsample;
need_buffer := FALSE;
end
else
if (h_in_group * 2 = h_out_group) and
(v_in_group = v_out_group) then
begin
{ Special cases for 2h1v upsampling }
if (do_fancy) and (compptr^.downsampled_width > 2) then
upsample^.methods[ci] := h2v1_fancy_upsample
else
upsample^.methods[ci] := h2v1_upsample;
end
else
if (h_in_group * 2 = h_out_group) and
(v_in_group * 2 = v_out_group) then
begin
{ Special cases for 2h2v upsampling }
if (do_fancy) and (compptr^.downsampled_width > 2) then
begin
upsample^.methods[ci] := h2v2_fancy_upsample;
upsample^.pub.need_context_rows := TRUE;
end
else
upsample^.methods[ci] := h2v2_upsample;
end
else
if ((h_out_group mod h_in_group) = 0) and
((v_out_group mod v_in_group) = 0) then
begin
{ Generic integral-factors upsampling method }
upsample^.methods[ci] := int_upsample;
upsample^.h_expand[ci] := UINT8 (h_out_group div h_in_group);
upsample^.v_expand[ci] := UINT8 (v_out_group div v_in_group);
end
else
ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL);
if (need_buffer) then
begin
upsample^.color_buf[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
JDIMENSION (jround_up( long (cinfo^.output_width),
long (cinfo^.max_h_samp_factor))),
JDIMENSION (cinfo^.max_v_samp_factor));
end;
Inc(compptr);
end;
end;
end.

462
Imaging/JpegLib/imjerror.pas Normal file
View File

@@ -0,0 +1,462 @@
unit imjerror;
{ This file contains simple error-reporting and trace-message routines.
These are suitable for Unix-like systems and others where writing to
stderr is the right thing to do. Many applications will want to replace
some or all of these routines.
These routines are used by both the compression and decompression code. }
{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. }
{ note: format_message still contains a hack }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjdeferr,
imjpeglib;
{
jversion;
}
const
EXIT_FAILURE = 1; { define halt() codes if not provided }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int);
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
implementation
{ How to format a message string, in format_message() ? }
{$IFDEF OS2}
{$DEFINE NO_FORMAT}
{$ENDIF}
{$IFDEF FPC}
{$DEFINE NO_FORMAT}
{$ENDIF}
uses
{$IFNDEF NO_FORMAT}
{$IFDEF VER70}
drivers, { Turbo Vision unit with FormatStr }
{$ELSE}
sysutils, { Delphi Unit with Format() }
{$ENDIF}
{$ENDIF}
imjcomapi;
{ Error exit handler: must not return to caller.
Applications may override this if they want to get control back after
an error. Typically one would longjmp somewhere instead of exiting.
The setjmp buffer can be made a private field within an expanded error
handler object. Note that the info needed to generate an error message
is stored in the error object, so you can generate the message now or
later, at your convenience.
You should make sure that the JPEG object is cleaned up (with jpeg_abort
or jpeg_destroy) at some point. }
{METHODDEF}
procedure error_exit (cinfo : j_common_ptr);
begin
{ Always display the message }
cinfo^.err^.output_message(cinfo);
{ Let the memory manager delete any temp files before we die }
jpeg_destroy(cinfo);
halt(EXIT_FAILURE);
end;
{ Actual output of an error or trace message.
Applications may override this method to send JPEG messages somewhere
other than stderr. }
{ Macros to simplify using the error and trace message stuff }
{ The first parameter is either type of cinfo pointer }
{ Fatal errors (print message and exit) }
procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.error_exit(cinfo);
end;
procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.msg_parm.i[2] := p3;
cinfo^.err^.msg_parm.i[3] := p4;
cinfo^.err^.error_exit (cinfo);
end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
cinfo^.err^.error_exit (cinfo);
end;
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, -1);
end;
procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, -1);
end;
procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, -1);
end;
{ Informational/debugging messages }
procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message(cinfo, lvl);
end;
procedure TRACEMS1(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; p1 : long);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int;
p2 : int);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.i[0] := p1;
cinfo^.err^.msg_parm.i[1] := p2;
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS3(cinfo : j_common_ptr;
lvl : int;
code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int; p5 : int);
var
_mp : ^int8array;
begin
_mp := @cinfo^.err^.msg_parm.i;
_mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3;
_mp^[3] := p4; _mp^[5] := p5;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int;
p5 : int; p6 : int; p7 : int; p8 : int);
var
_mp : int8array;
begin
_mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4;
_mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8;
cinfo^.err^.msg_parm.i := _mp;
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.emit_message (cinfo, lvl);
end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
cinfo^.err^.emit_message (cinfo, lvl);
end;
{METHODDEF}
procedure output_message (cinfo : j_common_ptr);
var
buffer : string; {[JMSG_LENGTH_MAX];}
begin
{ Create the message }
cinfo^.err^.format_message (cinfo, buffer);
{ Send it to stderr, adding a newline }
WriteLn(output, buffer);
end;
{ Decide whether to emit a trace or warning message.
msg_level is one of:
-1: recoverable corrupt-data warning, may want to abort.
0: important advisory messages (always display to user).
1: first level of tracing detail.
2,3,...: successively more detailed tracing messages.
An application might override this method if it wanted to abort on warnings
or change the policy about which messages to display. }
{METHODDEF}
procedure emit_message (cinfo : j_common_ptr; msg_level : int);
var
err : jpeg_error_mgr_ptr;
begin
err := cinfo^.err;
if (msg_level < 0) then
begin
{ It's a warning message. Since corrupt files may generate many warnings,
the policy implemented here is to show only the first warning,
unless trace_level >= 3. }
if (err^.num_warnings = 0) or (err^.trace_level >= 3) then
err^.output_message(cinfo);
{ Always count warnings in num_warnings. }
Inc( err^.num_warnings );
end
else
begin
{ It's a trace message. Show it if trace_level >= msg_level. }
if (err^.trace_level >= msg_level) then
err^.output_message (cinfo);
end;
end;
{ Format a message string for the most recent JPEG error or message.
The message is stored into buffer, which should be at least JMSG_LENGTH_MAX
characters. Note that no '\n' character is added to the string.
Few applications should need to override this method. }
{METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string);
var
err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE;
msgtext : string;
isstring : boolean;
begin
err := cinfo^.err;
msg_code := J_MESSAGE_CODE(err^.msg_code);
msgtext := '';
{ Look up message string in proper table }
if (msg_code > JMSG_NOMESSAGE)
and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then
begin
msgtext := err^.jpeg_message_table^[msg_code];
end
else
if (err^.addon_message_table <> NIL) and
(msg_code >= err^.first_addon_message) and
(msg_code <= err^.last_addon_message) then
begin
msgtext := err^.addon_message_table^[J_MESSAGE_CODE
(ord(msg_code) - ord(err^.first_addon_message))];
end;
{ Defend against bogus message number }
if (msgtext = '') then
begin
err^.msg_parm.i[0] := int(msg_code);
msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE];
end;
{ Check for string parameter, as indicated by %s in the message text }
isstring := Pos('%s', msgtext) > 0;
{ Format the message into the passed buffer }
if (isstring) then
buffer := Concat(msgtext, err^.msg_parm.s)
else
begin
{$IFDEF VER70}
FormatStr(buffer, msgtext, err^.msg_parm.i);
{$ELSE}
{$IFDEF NO_FORMAT}
buffer := msgtext;
{$ELSE}
buffer := Format(msgtext, [
err^.msg_parm.i[0], err^.msg_parm.i[1],
err^.msg_parm.i[2], err^.msg_parm.i[3],
err^.msg_parm.i[4], err^.msg_parm.i[5],
err^.msg_parm.i[6], err^.msg_parm.i[7] ]);
{$ENDIF}
{$ENDIF}
end;
end;
{ Reset error state variables at start of a new image.
This is called during compression startup to reset trace/error
processing to default state, without losing any application-specific
method pointers. An application might possibly want to override
this method if it has additional error processing state. }
{METHODDEF}
procedure reset_error_mgr (cinfo : j_common_ptr);
begin
cinfo^.err^.num_warnings := 0;
{ trace_level is not reset since it is an application-supplied parameter }
cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" }
end;
{ Fill in the standard error-handling methods in a jpeg_error_mgr object.
Typical call is:
cinfo : jpeg_compress_struct;
err : jpeg_error_mgr;
cinfo.err := jpeg_std_error(@err);
after which the application may override some of the methods. }
{GLOBAL}
function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr;
begin
err.error_exit := error_exit;
err.emit_message := emit_message;
err.output_message := output_message;
err.format_message := format_message;
err.reset_error_mgr := reset_error_mgr;
err.trace_level := 0; { default := no tracing }
err.num_warnings := 0; { no warnings emitted yet }
err.msg_code := 0; { may be useful as a flag for "no error" }
{ Initialize message table pointers }
err.jpeg_message_table := @jpeg_std_message_table;
err.last_jpeg_message := pred(JMSG_LASTMSGCODE);
err.addon_message_table := NIL;
err.first_addon_message := JMSG_NOMESSAGE; { for safety }
err.last_addon_message := JMSG_NOMESSAGE;
jpeg_std_error := @err;
end;
end.

176
Imaging/JpegLib/imjfdctflt.pas Normal file
View File

@@ -0,0 +1,176 @@
unit imjfdctflt;
{$N+}
{ This file contains a floating-point implementation of the
forward DCT (Discrete Cosine Transform).
This implementation should be more accurate than either of the integer
DCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original : jfdctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Perform the forward DCT on one block of samples.}
{GLOBAL}
procedure jpeg_fdct_float (var data : array of FAST_FLOAT);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z1, z2, z3, z4, z5, z11, z13 : FAST_FLOAT;
dataptr : PWorkspace;
ctr : int;
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * ({FAST_FLOAT}(0.707106781)); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * ( {FAST_FLOAT}(0.382683433)); { c6 }
z2 := {FAST_FLOAT}(0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT}(1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := (tmp12 + tmp13) * {FAST_FLOAT} (0.707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := (tmp10 - tmp12) * {FAST_FLOAT} (0.382683433); { c6 }
z2 := {FAST_FLOAT} (0.541196100) * tmp10 + z5; { c2-c6 }
z4 := {FAST_FLOAT} (1.306562965) * tmp12 + z5; { c2+c6 }
z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(FAST_FLOAT_PTR(dataptr)); { advance pointer to next column }
end;
end;
end.

237
Imaging/JpegLib/imjfdctfst.pas Normal file
View File

@@ -0,0 +1,237 @@
unit imjfdctfst;
{ This file contains a fast, not so accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original: jfdctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jfdctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
Again to save a few shifts, the intermediate results between pass 1 and
pass 2 are not upscaled, but are represented only to integral precision.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
const
CONST_BITS = 8;
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_382683433 = INT32(Round(CONST_SCALE * 0.382683433)); {98}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {139}
FIX_0_707106781 = INT32(Round(CONST_SCALE * 0.707106781)); {181}
FIX_1_306562965 = INT32(Round(CONST_SCALE * 1.306562965)); {334}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
{$ifndef USE_ACCURATE_ROUNDING}
shift_temp := x;
{$else}
shift_temp := x + (INT32(1) shl (n-1));
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
function MULTIPLY(X : DCTELEM; Y: INT32): DCTELEM;
begin
Multiply := DeScale((X) * (Y), CONST_BITS);
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_ifast (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z1, z2, z3, z4, z5, z11, z13 : DCTELEM;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := tmp10 + tmp11; { phase 3 }
dataptr^[4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[2] := tmp13 + z1; { phase 5 }
dataptr^[6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[5] := z13 + z2; { phase 6 }
dataptr^[3] := z13 - z2;
dataptr^[1] := z11 + z4;
dataptr^[7] := z11 - z4;
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part }
tmp10 := tmp0 + tmp3; { phase 2 }
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 }
dataptr^[DCTSIZE*4] := tmp10 - tmp11;
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 }
dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 }
dataptr^[DCTSIZE*6] := tmp13 - z1;
{ Odd part }
tmp10 := tmp4 + tmp5; { phase 2 }
tmp11 := tmp5 + tmp6;
tmp12 := tmp6 + tmp7;
{ The rotator is modified from fig 4-8 to avoid extra negations. }
z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 }
z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 }
z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 }
z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 }
z11 := tmp7 + z3; { phase 5 }
z13 := tmp7 - z3;
dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 }
dataptr^[DCTSIZE*3] := z13 - z2;
dataptr^[DCTSIZE*1] := z11 + z4;
dataptr^[DCTSIZE*7] := z11 - z4;
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.

297
Imaging/JpegLib/imjfdctint.pas Normal file
View File

@@ -0,0 +1,297 @@
unit imjfdctint;
{ This file contains a slow-but-accurate integer implementation of the
forward DCT (Discrete Cosine Transform).
A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT
on each column. Direct algorithms are also available, but they are
much more complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjutils,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D DCT step produces outputs which are a factor of sqrt(N)
larger than the true DCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D DCT,
because the y0 and y4 outputs need not be divided by sqrt(N).
In the IJG code, this factor of 8 is removed by the quantization step
(in jcdctmgr.c), NOT in this module.
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (For 12-bit sample data, the intermediate
array is INT32 anyway.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: int): INT32;
begin
Multiply := int(X) * INT32(Y);
end;
{$else}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := X * Y;
end;
{$endif}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform the forward DCT on one block of samples. }
{GLOBAL}
procedure jpeg_fdct_islow (var data : array of DCTELEM);
type
PWorkspace = ^TWorkspace;
TWorkspace = array [0..DCTSIZE2-1] of DCTELEM;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
dataptr : PWorkspace;
ctr : int;
{SHIFT_TEMPS}
begin
{ Pass 1: process rows. }
{ Note results are scaled up by sqrt(8) compared to a true DCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[0] + dataptr^[7];
tmp7 := dataptr^[0] - dataptr^[7];
tmp1 := dataptr^[1] + dataptr^[6];
tmp6 := dataptr^[1] - dataptr^[6];
tmp2 := dataptr^[2] + dataptr^[5];
tmp5 := dataptr^[2] - dataptr^[5];
tmp3 := dataptr^[3] + dataptr^[4];
tmp4 := dataptr^[3] - dataptr^[4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS);
dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS);
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS-PASS1_BITS));
dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS-PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS));
dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, CONST_BITS-PASS1_BITS));
dataptr^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS));
dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS));
Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row }
end;
{ Pass 2: process columns.
We remove the PASS1_BITS scaling, but leave the results scaled up
by an overall factor of 8. }
dataptr := PWorkspace(@data);
for ctr := DCTSIZE-1 downto 0 do
begin
tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7];
tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7];
tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6];
tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6];
tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5];
tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5];
tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4];
tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4];
{ Even part per LL&M figure 1 --- note that published figure is faulty;
rotator "sqrt(2)*c1" should be "sqrt(2)*c6". }
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS));
dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS));
z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100);
dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865),
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065),
CONST_BITS+PASS1_BITS));
{ Odd part per figure 8 --- note paper omits factor of sqrt(2).
cK represents cos(K*pi/16).
i0..i3 in the paper are tmp4..tmp7 here. }
z1 := tmp4 + tmp7;
z2 := tmp5 + tmp6;
z3 := tmp4 + tmp6;
z4 := tmp5 + tmp7;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3,
CONST_BITS+PASS1_BITS));
dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4,
CONST_BITS+PASS1_BITS));
Inc(DCTELEMPTR(dataptr)); { advance pointer to next column }
end;
end;
end.

793
Imaging/JpegLib/imjidctasm.pas Normal file
View File

@@ -0,0 +1,793 @@
unit imjidctasm;
{ This file contains a slow-but-accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jidctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. }
{ ;-------------------------------------------------------------------------
; JIDCTINT.ASM
; 80386 protected mode assembly translation of JIDCTINT.C
; **** Optimized to all hell by Jason M. Felice (jasonf@apk.net) ****
; **** E-mail welcome ****
;
; ** This code does not make O/S calls -- use it for OS/2, Win95, WinNT,
; ** DOS prot. mode., Linux, whatever... have fun.
;
; ** Note, this code is dependant on the structure member order in the .h
; ** files for the following structures:
; -- amazingly NOT j_decompress_struct... cool.
; -- jpeg_component_info (dependant on position of dct_table element)
;
; Originally created with the /Fa option of MSVC 4.0 (why work when you
; don't have to?)
;
; (this code, when compiled is 1K bytes smaller than the optimized MSVC
; release build, not to mention 120-130 ms faster in my profile test with 1
; small color and and 1 medium black-and-white jpeg: stats using TASM 4.0
; and MSVC 4.0 to create a non-console app; jpeg_idct_islow accumulated
; 5,760 hits on all trials)
;
; TASM -t -ml -os jidctint.asm, jidctint.obj
;-------------------------------------------------------------------------
Converted to Delphi 2.0 BASM for PasJPEG
by Jacques NOMSSI NZALI <nomssi@physik.tu-chemnitz.de>
October 13th 1996
* assumes Delphi "register" calling convention
first 3 parameter are in EAX,EDX,ECX
* register allocation revised
}
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D IDCT step produces outputs which are a factor of sqrt(N)
larger than the true IDCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D IDCT,
because the y0 and y4 inputs need not be divided by sqrt(N).
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (To scale up 12-bit sample data further, an
intermediate INT32 array would be needed.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
const
CONST_BITS = 13;
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
PASS1_BITS = 2;
{$else}
const
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ for DESCALE }
const
ROUND_CONST = (INT32(1) shl (CONST_BITS-PASS1_BITS-1));
const
ROUND_CONST_2 = (INT32(1) shl (CONST_BITS+PASS1_BITS+3-1));
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
const
coefDCTSIZE = DCTSIZE*SizeOf(JCOEF);
wrkDCTSIZE = DCTSIZE*SizeOf(int);
var
tmp0, tmp1, tmp2, tmp3 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
var
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
var
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace;
var
dcval : int;
var
dcval_ : JSAMPLE;
asm
push edi
push esi
push ebx
cld { The only direction we use, might as well set it now, as opposed }
{ to inside 2 loops. }
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
{range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));}
mov eax, [eax].jpeg_decompress_struct.sample_range_limit {eax=cinfo}
add eax, (MAXJSAMPLE+1 + CENTERJSAMPLE)*(Type JSAMPLE)
mov range_limit, eax
{ Pass 1: process columns from input, store into work array. }
{ Note results are scaled up by sqrt(8) compared to a true IDCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
{inptr := coef_block;}
mov esi, ecx { ecx=coef_block }
{quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);}
mov edi, [edx].jpeg_component_info.dct_table { edx=compptr }
{wsptr := PWorkspace(@workspace);}
lea ecx, workspace
{for ctr := pred(DCTSIZE) downto 0 do
begin}
mov ctr, DCTSIZE
@loop518:
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
{if ((inptr^[DCTSIZE*1]) or (inptr^[DCTSIZE*2]) or (inptr^[DCTSIZE*3]) or
(inptr^[DCTSIZE*4]) or (inptr^[DCTSIZE*5]) or (inptr^[DCTSIZE*6]) or
(inptr^[DCTSIZE*7]) = 0) then
begin}
mov eax, DWORD PTR [esi+coefDCTSIZE*1]
or eax, DWORD PTR [esi+coefDCTSIZE*2]
or eax, DWORD PTR [esi+coefDCTSIZE*3]
mov edx, DWORD PTR [esi+coefDCTSIZE*4]
or eax, edx
or eax, DWORD PTR [esi+coefDCTSIZE*5]
or eax, DWORD PTR [esi+coefDCTSIZE*6]
or eax, DWORD PTR [esi+coefDCTSIZE*7]
jne @loop520
{ AC terms all zero }
{dcval := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) *
(quantptr^[DCTSIZE*0]) shl PASS1_BITS;}
mov eax, DWORD PTR [esi+coefDCTSIZE*0]
imul eax, DWORD PTR [edi+wrkDCTSIZE*0]
shl eax, PASS1_BITS
{wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;}
mov DWORD PTR [ecx+ wrkDCTSIZE*0], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*1], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*2], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*3], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*4], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*5], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*6], eax
mov DWORD PTR [ecx+ wrkDCTSIZE*7], eax
{Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
{Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;}
dec ctr
je @loop519
add esi, Type JCOEF
add edi, Type ISLOW_MULT_TYPE
add ecx, Type int { int_ptr }
jmp @loop518
@loop520:
{end;}
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
{z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2];
z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6];
z1 := (z2 + z3) * INT32(FIX_0_541196100);
tmp2 := z1 + INT32(z3) * INT32(- FIX_1_847759065);
tmp3 := z1 + INT32(z2) * INT32(FIX_0_765366865);}
mov edx, DWORD PTR [esi+coefDCTSIZE*2]
imul edx, DWORD PTR [edi+wrkDCTSIZE*2] {z2}
mov eax, DWORD PTR [esi+coefDCTSIZE*6]
imul eax, DWORD PTR [edi+wrkDCTSIZE*6] {z3}
lea ebx, [eax+edx]
imul ebx, FIX_0_541196100 {z1}
imul eax, (-FIX_1_847759065)
add eax, ebx
mov tmp2, eax
imul edx, FIX_0_765366865
add edx, ebx
mov tmp3, edx
{z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0];
z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*4]) * quantptr^[DCTSIZE*4];}
mov edx, DWORD PTR [esi+coefDCTSIZE*4]
imul edx, DWORD PTR [edi+wrkDCTSIZE*4] { z3 = edx }
mov eax, DWORD PTR [esi+coefDCTSIZE*0]
imul eax, DWORD PTR [edi+wrkDCTSIZE*0] { z2 = eax }
{tmp0 := (z2 + z3) shl CONST_BITS;
tmp1 := (z2 - z3) shl CONST_BITS;}
lea ebx,[eax+edx]
sub eax, edx
shl ebx, CONST_BITS { tmp0 = ebx }
shl eax, CONST_BITS { tmp1 = eax }
{tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;}
mov edx, tmp3
sub ebx, edx
mov tmp13, ebx
add edx, edx
add ebx, edx
mov tmp10, ebx
{tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;}
mov ebx, tmp2
sub eax, ebx
mov tmp12, eax
add ebx, ebx
add eax, ebx
mov tmp11, eax
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
{tmp0 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7];}
mov eax, DWORD PTR [esi+coefDCTSIZE*7]
imul eax, DWORD PTR [edi+wrkDCTSIZE*7]
mov edx, eax { edx = tmp0 }
{tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
imul eax, FIX_0_298631336
mov tmp0, eax
{tmp3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1];}
mov eax, DWORD PTR [esi+coefDCTSIZE*1]
imul eax, DWORD PTR [edi+wrkDCTSIZE*1]
mov tmp3, eax
{z1 := tmp0 + tmp3;}
{z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) }
add eax, edx
imul eax, (-FIX_0_899976223)
mov z1, eax
{tmp1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5];}
mov eax, DWORD PTR [esi+coefDCTSIZE*5]
imul eax, DWORD PTR [edi+wrkDCTSIZE*5]
mov ebx, eax { ebx = tmp1 }
{tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
imul eax, FIX_2_053119869
mov tmp1, eax
{tmp2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3];}
mov eax, DWORD PTR [esi+coefDCTSIZE*3]
imul eax, DWORD PTR [edi+wrkDCTSIZE*3]
mov tmp2, eax
{z3 := tmp0 + tmp2;}
add edx, eax { edx = z3 }
{z2 := tmp1 + tmp2;}
{z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) }
add eax, ebx
imul eax, (-FIX_2_562915447)
mov z2, eax
{z4 := tmp1 + tmp3;}
add ebx, tmp3 { ebx = z4 }
{z5 := INT32(z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 }
lea eax, [edx+ebx]
imul eax, FIX_1_175875602 { eax = z5 }
{z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) }
{Inc(z4, z5);}
imul ebx, (-FIX_0_390180644)
add ebx, eax
mov z4, ebx
{z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) }
{Inc(z3, z5);}
imul edx, (-FIX_1_961570560)
add eax, edx { z3 = eax }
{Inc(tmp0, z1 + z3);}
mov ebx, z1
add ebx, eax
add tmp0, ebx
{tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
{Inc(tmp2, z2 + z3);}
mov ebx, tmp2
imul ebx, FIX_3_072711026
mov edx, z2 { z2 = edx }
add ebx, edx
add eax, ebx
mov tmp2, eax
{Inc(tmp1, z2 + z4);}
mov eax, z4 { z4 = eax }
add edx, eax
add tmp1, edx
{tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
{Inc(tmp3, z1 + z4);}
mov edx, tmp3
imul edx, FIX_1_501321110
add edx, eax
add edx, z1 { tmp3 = edx }
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
{wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));}
{wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));}
mov eax, tmp10
add eax, ROUND_CONST
lea ebx, [eax+edx]
sar ebx, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*0], ebx
sub eax, edx
sar eax, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*7], eax
{wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));}
{wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));}
mov eax, tmp11
add eax, ROUND_CONST
mov edx, tmp2
lea ebx, [eax+edx]
sar ebx, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*1], ebx
sub eax, edx
sar eax, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*6], eax
{wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));}
{wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));}
mov eax, tmp12
add eax, ROUND_CONST
mov edx, tmp1
lea ebx, [eax+edx]
sar ebx, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*2], ebx
sub eax, edx
sar eax, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*5], eax
{wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));}
{wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));}
mov eax, tmp13
add eax, ROUND_CONST
mov edx, tmp0
lea ebx, [eax+edx]
sar ebx, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*3], ebx
sub eax, edx
sar eax, CONST_BITS-PASS1_BITS
mov DWORD PTR [ecx+wrkDCTSIZE*4], eax
{Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
{Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));}
dec ctr
je @loop519
add esi, Type JCOEF
add edi, Type ISLOW_MULT_TYPE
add ecx, Type int { int_ptr }
{end;}
jmp @loop518
@loop519:
{ Save to memory what we've registerized for the preceding loop. }
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
{wsptr := @workspace;}
lea esi, workspace
{for ctr := 0 to pred(DCTSIZE) do
begin}
mov ctr, 0
@loop523:
{outptr := output_buf^[ctr];}
mov eax, ctr
mov ebx, output_buf
mov edi, DWORD PTR [ebx+eax*4] { 4 = SizeOf(pointer) }
{Inc(JSAMPLE_PTR(outptr), output_col);}
add edi, LongWord(output_col)
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
{if ((wsptr^[1]) or (wsptr^[2]) or (wsptr^[3]) or (wsptr^[4]) or
(wsptr^[5]) or (wsptr^[6]) or (wsptr^[7]) = 0) then
begin}
mov eax, DWORD PTR [esi+4*1]
or eax, DWORD PTR [esi+4*2]
or eax, DWORD PTR [esi+4*3]
jne @loop525 { Nomssi: early exit path may help }
or eax, DWORD PTR [esi+4*4]
or eax, DWORD PTR [esi+4*5]
or eax, DWORD PTR [esi+4*6]
or eax, DWORD PTR [esi+4*7]
jne @loop525
{ AC terms all zero }
{JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]),
PASS1_BITS+3)) and RANGE_MASK];}
mov eax, DWORD PTR [esi+4*0]
add eax, (INT32(1) shl (PASS1_BITS+3-1))
sar eax, PASS1_BITS+3
and eax, RANGE_MASK
mov ebx, range_limit
mov al, BYTE PTR [ebx+eax]
mov ah, al
{outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;}
stosw
stosw
stosw
stosw
{Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
{continue;}
add esi, wrkDCTSIZE
inc ctr
cmp ctr, DCTSIZE
jl @loop523
jmp @loop524
{end;}
@loop525:
{$endif}
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
{z2 := INT32 (wsptr^[2]);}
mov edx, DWORD PTR [esi+4*2] { z2 = edx }
{z3 := INT32 (wsptr^[6]);}
mov ecx, DWORD PTR [esi+4*6] { z3 = ecx }
{z1 := (z2 + z3) * INT32(FIX_0_541196100);}
lea eax, [edx+ecx]
imul eax, FIX_0_541196100
mov ebx, eax { z1 = ebx }
{tmp2 := z1 + (z3) * INT32(- FIX_1_847759065);}
imul ecx, (-FIX_1_847759065)
add ecx, ebx { tmp2 = ecx }
{tmp3 := z1 + (z2) * INT32(FIX_0_765366865);}
imul edx, FIX_0_765366865
add ebx, edx { tmp3 = ebx }
{tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;}
{tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;}
mov edx, DWORD PTR [esi+4*4]
mov eax, DWORD PTR [esi+4*0]
sub eax, edx
add edx, edx
add edx, eax
shl edx, CONST_BITS { tmp0 = edx }
shl eax, CONST_BITS { tmp1 = eax }
{tmp10 := tmp0 + tmp3;}
{tmp13 := tmp0 - tmp3;}
sub edx, ebx
mov tmp13, edx
add ebx, ebx
add edx, ebx
mov tmp10, edx
{tmp11 := tmp1 + tmp2;}
{tmp12 := tmp1 - tmp2;}
lea ebx, [ecx+eax]
mov tmp11, ebx
sub eax, ecx
mov tmp12, eax
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
{ The following lines no longer produce code, since wsptr has been
optimized to esi, it is more efficient to access these values
directly.
tmp0 := INT32(wsptr^[7]);
tmp1 := INT32(wsptr^[5]);
tmp2 := INT32(wsptr^[3]);
tmp3 := INT32(wsptr^[1]); }
{z2 := tmp1 + tmp2;}
{z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) }
mov ebx, DWORD PTR [esi+4*3] { tmp2 }
mov ecx, DWORD PTR [esi+4*5] { tmp1 }
lea eax, [ebx+ecx]
imul eax, (-FIX_2_562915447)
mov z2, eax
{z3 := tmp0 + tmp2;}
mov edx, DWORD PTR [esi+4*7] { tmp0 }
add ebx, edx { old z3 = ebx }
mov eax, ebx
{z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) }
imul eax, (-FIX_1_961570560)
mov z3, eax
{z1 := tmp0 + tmp3;}
{z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) }
mov eax, DWORD PTR [esi+4*1] { tmp3 }
add edx, eax
imul edx, (-FIX_0_899976223) { z1 = edx }
{z4 := tmp1 + tmp3;}
add eax, ecx { +tmp1 }
add ebx, eax { z3 + z4 = ebx }
{z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) }
imul eax, (-FIX_0_390180644) { z4 = eax }
{z5 := (z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 }
{Inc(z3, z5);}
imul ebx, FIX_1_175875602
mov ecx, z3
add ecx, ebx { ecx = z3 }
{Inc(z4, z5);}
add ebx, eax { z4 = ebx }
{tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
{Inc(tmp0, z1 + z3);}
mov eax, DWORD PTR [esi+4*7]
imul eax, FIX_0_298631336
add eax, edx
add eax, ecx
mov tmp0, eax
{tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
{Inc(tmp1, z2 + z4);}
mov eax, DWORD PTR [esi+4*5]
imul eax, FIX_2_053119869
add eax, z2
add eax, ebx
mov tmp1, eax
{tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
{Inc(tmp2, z2 + z3);}
mov eax, DWORD PTR [esi+4*3]
imul eax, FIX_3_072711026
add eax, z2
add ecx, eax { ecx = tmp2 }
{tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
{Inc(tmp3, z1 + z4);}
mov eax, DWORD PTR [esi+4*1]
imul eax, FIX_1_501321110
add eax, edx
add ebx, eax { ebx = tmp3 }
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
{outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK]; }
{outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
mov edx, tmp10
add edx, ROUND_CONST_2
lea eax, [ebx+edx]
sub edx, ebx
shr eax, CONST_BITS+PASS1_BITS+3
and eax, RANGE_MASK
mov ebx, range_limit { once for all }
mov al, BYTE PTR [ebx+eax]
mov [edi+0], al
shr edx, CONST_BITS+PASS1_BITS+3
and edx, RANGE_MASK
mov al, BYTE PTR [ebx+edx]
mov [edi+7], al
{outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
mov eax, tmp11
add eax, ROUND_CONST_2
lea edx, [eax+ecx]
shr edx, CONST_BITS+PASS1_BITS+3
and edx, RANGE_MASK
mov dl, BYTE PTR [ebx+edx]
mov [edi+1], dl
{outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
sub eax, ecx
shr eax, CONST_BITS+PASS1_BITS+3
and eax, RANGE_MASK
mov al, BYTE PTR [ebx+eax]
mov [edi+6], al
{outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
mov eax, tmp12
add eax, ROUND_CONST_2
mov ecx, tmp1
lea edx, [eax+ecx]
shr edx, CONST_BITS+PASS1_BITS+3
and edx, RANGE_MASK
mov dl, BYTE PTR [ebx+edx]
mov [edi+2], dl
{outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
sub eax, ecx
shr eax, CONST_BITS+PASS1_BITS+3
and eax, RANGE_MASK
mov al, BYTE PTR [ebx+eax]
mov [edi+5], al
{outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
mov eax, tmp13
add eax, ROUND_CONST_2
mov ecx, tmp0
lea edx, [eax+ecx]
shr edx, CONST_BITS+PASS1_BITS+3
and edx, RANGE_MASK
mov dl, BYTE PTR [ebx+edx]
mov [edi+3], dl
{outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0,
CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];}
sub eax, ecx
shr eax, CONST_BITS+PASS1_BITS+3
and eax, RANGE_MASK
mov al, BYTE PTR [ebx+eax]
mov [edi+4], al
{Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
add esi, wrkDCTSIZE
add edi, DCTSIZE
{end;}
inc ctr
cmp ctr, DCTSIZE
jl @loop523
@loop524:
@loop496:
pop ebx
pop esi
pop edi
end;
end.

286
Imaging/JpegLib/imjidctflt.pas Normal file
View File

@@ -0,0 +1,286 @@
unit imjidctflt;
{$N+}
{ This file contains a floating-point implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
This implementation should be more accurate than either of the integer
IDCT implementations. However, it may not give the same results on all
machines because of differences in roundoff behavior. Speed will depend
on the hardware's floating point capacity.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with a fixed-point
implementation, accuracy is lost due to imprecise representation of the
scaled quantization values. However, that problem does not arise if
we use floating point arithmetic. }
{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a float result. }
function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT;
begin
Dequantize := ( (coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_float (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT;
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT;
tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT;
z5, z10, z11, z12, z13 : FAST_FLOAT;
inptr : JCOEFPTR;
quantptr : FLOAT_MULT_TYPE_FIELD_PTR;
wsptr : PWorkSpace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS}
var
dcval : FAST_FLOAT;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 }
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := tmp0 + tmp7;
wsptr^[DCTSIZE*7] := tmp0 - tmp7;
wsptr^[DCTSIZE*1] := tmp1 + tmp6;
wsptr^[DCTSIZE*6] := tmp1 - tmp6;
wsptr^[DCTSIZE*2] := tmp2 + tmp5;
wsptr^[DCTSIZE*5] := tmp2 - tmp5;
wsptr^[DCTSIZE*4] := tmp3 + tmp4;
wsptr^[DCTSIZE*3] := tmp3 - tmp4;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(FLOAT_MULT_TYPE_PTR(quantptr));
Inc(FAST_FLOAT_PTR(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 = 2**3. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@(output_buf^[ctr]^[output_col]));
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
And testing floats for zero is relatively expensive, so we don't bother. }
{ Even part }
tmp10 := wsptr^[0] + wsptr^[4];
tmp11 := wsptr^[0] - wsptr^[4];
tmp13 := wsptr^[2] + wsptr^[6];
tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := wsptr^[5] + wsptr^[3];
z10 := wsptr^[5] - wsptr^[3];
z11 := wsptr^[1] + wsptr^[7];
z12 := wsptr^[1] - wsptr^[7];
tmp7 := z11 + z13;
tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562));
z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 }
tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) }
tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7;
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3))
and RANGE_MASK];
Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

410
Imaging/JpegLib/imjidctfst.pas Normal file
View File

@@ -0,0 +1,410 @@
unit imjidctfst;
{ This file contains a fast, not so accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on Arai, Agui, and Nakajima's algorithm for
scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in
Japanese, but the algorithm is described in the Pennebaker & Mitchell
JPEG textbook (see REFERENCES section in file README). The following code
is based directly on figure 4-8 in P&M.
While an 8-point DCT cannot be done in less than 11 multiplies, it is
possible to arrange the computation so that many of the multiplies are
simple scalings of the final outputs. These multiplies can then be
folded into the multiplications or divisions by the JPEG quantization
table entries. The AA&N method leaves only 5 multiplies and 29 adds
to be done in the DCT itself.
The primary disadvantage of this method is that with fixed-point math,
accuracy is lost due to imprecise representation of the scaled
quantization values. The smaller the quantization table entry, the less
precise the scaled value, so this implementation does worse with high-
quality-setting files than with low-quality ones. }
{ Original : jidctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling decisions are generally the same as in the LL&M algorithm;
see jidctint.c for more details. However, we choose to descale
(right shift) multiplication products as soon as they are formed,
rather than carrying additional fractional bits into subsequent additions.
This compromises accuracy slightly, but it lets us save a few shifts.
More importantly, 16-bit arithmetic is then adequate (for 8-bit samples)
everywhere except in the multiplications proper; this saves a good deal
of work on 16-bit-int machines.
The dequantized coefficients are not integers because the AA&N scaling
factors have been incorporated. We represent them scaled up by PASS1_BITS,
so that the first and second IDCT rounds have the same input scaling.
For 8-bit JSAMPLEs, we choose IFAST_SCALE_BITS = PASS1_BITS so as to
avoid a descaling shift; this compromises accuracy rather drastically
for small quantization table entries, but it saves a lot of shifts.
For 12-bit JSAMPLEs, there's no hope of using 16x16 multiplies anyway,
so we use a much larger scaling factor to preserve accuracy.
A final compromise is to represent the multiplicative constants to only
8 fractional bits, rather than 13. This saves some shifting work on some
machines, and may also reduce the cost of multiplication (since there
are fewer one-bits in the constants). }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 8;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 8;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
FIX_1_082392200 = INT32(Round((INT32(1) shl CONST_BITS)*1.082392200)); {277}
FIX_1_414213562 = INT32(Round((INT32(1) shl CONST_BITS)*1.414213562)); {362}
FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS)*1.847759065)); {473}
FIX_2_613125930 = INT32(Round((INT32(1) shl CONST_BITS)*2.613125930)); {669}
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef USE_ACCURATE_ROUNDING}
shift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
shift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
{$endif}
Descale := (shift_temp shr n);
end;
{ Multiply a DCTELEM variable by an INT32 constant, and immediately
descale to yield a DCTELEM result. }
{(DCTELEM( DESCALE((var) * (const), CONST_BITS))}
function Multiply(Avar, Aconst: Integer): DCTELEM;
begin
Multiply := DCTELEM( Avar*INT32(Aconst) div (INT32(1) shl CONST_BITS));
end;
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce a DCTELEM result. For 8-bit data a 16x16->16
multiplication will do. For 12-bit data, the multiplier table is
declared INT32, so a 32-bit multiply will be used. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( IFAST_MULT_TYPE(coef) * quantval);
end;
{$else}
function DEQUANTIZE(coef,quantval : INT32) : int;
begin
Dequantize := DESCALE((coef)*(quantval), IFAST_SCALE_BITS-PASS1_BITS);
end;
{$endif}
{ Like DESCALE, but applies to a DCTELEM and produces an int.
We assume that int right shift is unsigned if INT32 right shift is. }
function IDESCALE(x : DCTELEM; n : int) : int;
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
DCTELEMBITS = 16; { DCTELEM may be 16 or 32 bits }
{$else}
const
DCTELEMBITS = 32; { DCTELEM must be 32 bits }
{$endif}
var
ishift_temp : DCTELEM;
begin
{$ifndef USE_ACCURATE_ROUNDING}
ishift_temp := x + (INT32(1) shl (n-1));
{$else}
{ We can gain a little more speed, with a further compromise in accuracy,
by omitting the addition in a descaling shift. This yields an incorrectly
rounded result half the time... }
ishift_temp := x;
{$endif}
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
if ishift_temp < 0 then
IDescale := (ishift_temp shr n)
or ((not DCTELEM(0)) shl (DCTELEMBITS-n))
else
{$endif}
IDescale := (ishift_temp shr n);
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_ifast (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM;
tmp10, tmp11, tmp12, tmp13 : DCTELEM;
z5, z10, z11, z12, z13 : DCTELEM;
inptr : JCOEFPTR;
quantptr : IFAST_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS} { for DESCALE }
{ISHIFT_TEMPS} { for IDESCALE }
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := IFAST_MULT_TYPE_FIELD_PTR(compptr^.dct_table);
wsptr := @workspace;
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and
(inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero }
dcval := int(DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]));
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
tmp10 := tmp0 + tmp2; { phase 3 }
tmp11 := tmp0 - tmp2;
tmp13 := tmp1 + tmp3; { phases 5-3 }
tmp12 := MULTIPLY(tmp1 - tmp3, FIX_1_414213562) - tmp13; { 2*c4 }
tmp0 := tmp10 + tmp13; { phase 2 }
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
z13 := tmp6 + tmp5; { phase 6 }
z10 := tmp6 - tmp5;
z11 := tmp4 + tmp7;
z12 := tmp4 - tmp7;
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
wsptr^[DCTSIZE*0] := int (tmp0 + tmp7);
wsptr^[DCTSIZE*7] := int (tmp0 - tmp7);
wsptr^[DCTSIZE*1] := int (tmp1 + tmp6);
wsptr^[DCTSIZE*6] := int (tmp1 - tmp6);
wsptr^[DCTSIZE*2] := int (tmp2 + tmp5);
wsptr^[DCTSIZE*5] := int (tmp2 - tmp5);
wsptr^[DCTSIZE*4] := int (tmp3 + tmp4);
wsptr^[DCTSIZE*3] := int (tmp3 - tmp4);
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(IFAST_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := JSAMPROW(@output_buf^[ctr]^[output_col]);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) and
(wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then
begin
{ AC terms all zero }
dcval_ := range_limit^[IDESCALE(wsptr^[0], PASS1_BITS+3)
and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part }
tmp10 := (DCTELEM(wsptr^[0]) + DCTELEM(wsptr^[4]));
tmp11 := (DCTELEM(wsptr^[0]) - DCTELEM(wsptr^[4]));
tmp13 := (DCTELEM(wsptr^[2]) + DCTELEM(wsptr^[6]));
tmp12 := MULTIPLY(DCTELEM(wsptr^[2]) - DCTELEM(wsptr^[6]), FIX_1_414213562)
- tmp13;
tmp0 := tmp10 + tmp13;
tmp3 := tmp10 - tmp13;
tmp1 := tmp11 + tmp12;
tmp2 := tmp11 - tmp12;
{ Odd part }
z13 := DCTELEM(wsptr^[5]) + DCTELEM(wsptr^[3]);
z10 := DCTELEM(wsptr^[5]) - DCTELEM(wsptr^[3]);
z11 := DCTELEM(wsptr^[1]) + DCTELEM(wsptr^[7]);
z12 := DCTELEM(wsptr^[1]) - DCTELEM(wsptr^[7]);
tmp7 := z11 + z13; { phase 5 }
tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 }
z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 }
tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) }
tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) }
tmp6 := tmp12 - tmp7; { phase 2 }
tmp5 := tmp11 - tmp6;
tmp4 := tmp10 + tmp5;
{ Final output stage: scale down by a factor of 8 and range-limit }
outptr^[0] := range_limit^[IDESCALE(tmp0 + tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[7] := range_limit^[IDESCALE(tmp0 - tmp7, PASS1_BITS+3)
and RANGE_MASK];
outptr^[1] := range_limit^[IDESCALE(tmp1 + tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[6] := range_limit^[IDESCALE(tmp1 - tmp6, PASS1_BITS+3)
and RANGE_MASK];
outptr^[2] := range_limit^[IDESCALE(tmp2 + tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[5] := range_limit^[IDESCALE(tmp2 - tmp5, PASS1_BITS+3)
and RANGE_MASK];
outptr^[4] := range_limit^[IDESCALE(tmp3 + tmp4, PASS1_BITS+3)
and RANGE_MASK];
outptr^[3] := range_limit^[IDESCALE(tmp3 - tmp4, PASS1_BITS+3)
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

440
Imaging/JpegLib/imjidctint.pas Normal file
View File

@@ -0,0 +1,440 @@
unit imjidctint;
{$Q+}
{ This file contains a slow-but-accurate integer implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.
A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT
on each row (or vice versa, but it's more convenient to emit a row at
a time). Direct algorithms are also available, but they are much more
complex and seem not to be any faster when reduced to code.
This implementation is based on an algorithm described in
C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT
Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics,
Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991.
The primary algorithm described there uses 11 multiplies and 29 adds.
We use their alternate method with 12 multiplies and 32 adds.
The advantage of this method is that no data path contains more than one
multiplication; this allows a very simple and accurate implementation in
scaled fixed-point arithmetic, with a minimal number of shifts. }
{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ The poop on this scaling stuff is as follows:
Each 1-D IDCT step produces outputs which are a factor of sqrt(N)
larger than the true IDCT outputs. The final outputs are therefore
a factor of N larger than desired; since N=8 this can be cured by
a simple right shift at the end of the algorithm. The advantage of
this arrangement is that we save two multiplications per 1-D IDCT,
because the y0 and y4 inputs need not be divided by sqrt(N).
We have to do addition and subtraction of the integer inputs, which
is no problem, and multiplication by fractional constants, which is
a problem to do in integer arithmetic. We multiply all the constants
by CONST_SCALE and convert them to integer constants (thus retaining
CONST_BITS bits of precision in the constants). After doing a
multiplication we have to divide the product by CONST_SCALE, with proper
rounding, to produce the correct output. This division can be done
cheaply as a right shift of CONST_BITS bits. We postpone shifting
as long as possible so that partial sums can be added together with
full fractional precision.
The outputs of the first pass are scaled up by PASS1_BITS bits so that
they are represented to better-than-integral precision. These outputs
require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word
with the recommended scaling. (To scale up 12-bit sample data further, an
intermediate INT32 array would be needed.)
To avoid overflow of the 32-bit intermediate results in pass 2, we must
have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis
shows that the values given below are the most effective. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
CONST_SCALE = (INT32(1) shl CONST_BITS);
const
FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446}
FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196}
FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433}
FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270}
FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373}
FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633}
FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299}
FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137}
FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069}
FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819}
FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995}
FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{$IFDEF BASM16}
{$IFNDEF WIN32}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: Integer): integer; assembler;
asm
mov ax, X
imul Y
mov al, ah
mov ah, dl
end;
{$ENDIF}
{$ENDIF}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$else}
{#define MULTIPLY(var,const) ((var) * (const))}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := INT32(X) * INT32(Y);
end;
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce an int result. In this module, both inputs and result
are 16 bits or less, so either int or short multiply will work. }
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients. }
{GLOBAL}
procedure jpeg_idct_islow (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = coef_bits_field; { buffers data between passes }
var
tmp0, tmp1, tmp2, tmp3 : INT32;
tmp10, tmp11, tmp12, tmp13 : INT32;
z1, z2, z3, z4, z5 : INT32;
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace;
{SHIFT_TEMPS}
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
{ Note results are scaled up by sqrt(8) compared to a true IDCT; }
{ furthermore, we scale the results by 2**PASS1_BITS. }
inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := PWorkspace(@workspace);
for ctr := pred(DCTSIZE) downto 0 do
begin
{ Due to quantization, we will usually find that many of the input
coefficients are zero, especially the AC terms. We can exploit this
by short-circuiting the IDCT calculation for any column in which all
the AC terms are zero. In that case each output is equal to the
DC coefficient (with scale factor as needed).
With typical images and quantization tables, half or more of the
column DCT calculations can be simplified this way. }
if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and
(inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and
(inptr^[DCTSIZE*7]=0)) then
begin
{ AC terms all zero }
dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
wsptr^[DCTSIZE*4] := dcval;
wsptr^[DCTSIZE*5] := dcval;
wsptr^[DCTSIZE*6] := dcval;
wsptr^[DCTSIZE*7] := dcval;
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]);
z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]);
tmp0 := (z2 + z3) shl CONST_BITS;
tmp1 := (z2 - z3) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]);
tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]);
tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]);
tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));
wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));
Inc(JCOEF_PTR(inptr)); { advance pointers to next column }
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process rows from work array, store into output array. }
{ Note that we must descale the results by a factor of 8 == 2**3, }
{ and also undo the PASS1_BITS scaling. }
wsptr := @workspace;
for ctr := 0 to pred(DCTSIZE) do
begin
outptr := output_buf^[ctr];
Inc(JSAMPLE_PTR(outptr), output_col);
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so
the simplification applies less often (typically 5% to 10% of the time).
On machines with very fast multiplication, it's possible that the
test takes more time than it's worth. In that case this section
may be commented out. }
{$ifndef NO_ZERO_ROW_TEST}
if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0)
and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then
begin
{ AC terms all zero }
JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]),
PASS1_BITS+3)) and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
outptr^[4] := dcval_;
outptr^[5] := dcval_;
outptr^[6] := dcval_;
outptr^[7] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part: reverse the even part of the forward DCT. }
{ The rotator is sqrt(2)*c(-6). }
z2 := INT32 (wsptr^[2]);
z3 := INT32 (wsptr^[6]);
z1 := MULTIPLY(z2 + z3, FIX_0_541196100);
tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065);
tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865);
tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;
tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;
tmp10 := tmp0 + tmp3;
tmp13 := tmp0 - tmp3;
tmp11 := tmp1 + tmp2;
tmp12 := tmp1 - tmp2;
{ Odd part per figure 8; the matrix is unitary and hence its
transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. }
tmp0 := INT32(wsptr^[7]);
tmp1 := INT32(wsptr^[5]);
tmp2 := INT32(wsptr^[3]);
tmp3 := INT32(wsptr^[1]);
z1 := tmp0 + tmp3;
z2 := tmp1 + tmp2;
z3 := tmp0 + tmp2;
z4 := tmp1 + tmp3;
z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 }
tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) }
tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) }
tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) }
tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) }
z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) }
z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) }
z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) }
z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) }
Inc(z3, z5);
Inc(z4, z5);
Inc(tmp0, z1 + z3);
Inc(tmp1, z2 + z4);
Inc(tmp2, z2 + z3);
Inc(tmp3, z1 + z4);
{ Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0,
CONST_BITS+PASS1_BITS+3))
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
end.

525
Imaging/JpegLib/imjidctred.pas Normal file
View File

@@ -0,0 +1,525 @@
unit imjidctred;
{ This file contains inverse-DCT routines that produce reduced-size output:
either 4x4, 2x2, or 1x1 pixels from an 8x8 DCT block.
The implementation is based on the Loeffler, Ligtenberg and Moschytz (LL&M)
algorithm used in jidctint.c. We simply replace each 8-to-8 1-D IDCT step
with an 8-to-4 step that produces the four averages of two adjacent outputs
(or an 8-to-2 step producing two averages of four outputs, for 2x2 output).
These steps were derived by computing the corresponding values at the end
of the normal LL&M code, then simplifying as much as possible.
1x1 is trivial: just take the DC coefficient divided by 8.
See jidctint.c for additional comments. }
{ Original : jidctred.c ; Copyright (C) 1994-1998, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib,
imjdct; { Private declarations for DCT subsystem }
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 1x1 output block. }
{GLOBAL}
procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 2x2 output block. }
{GLOBAL}
procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 4x4 output block. }
{GLOBAL}
procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
implementation
{ This module is specialized to the case DCTSIZE = 8. }
{$ifndef DCTSIZE_IS_8}
Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err }
{$endif}
{ Scaling is the same as in jidctint.c. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
const
CONST_BITS = 13;
PASS1_BITS = 2;
{$else}
const
CONST_BITS = 13;
PASS1_BITS = 1; { lose a little precision to avoid overflow }
{$endif}
const
FIX_0_211164243 = INT32(Round((INT32(1) shl CONST_BITS) * 0.211164243)); {1730}
FIX_0_509795579 = INT32(Round((INT32(1) shl CONST_BITS) * 0.509795579)); {4176}
FIX_0_601344887 = INT32(Round((INT32(1) shl CONST_BITS) * 0.601344887)); {4926}
FIX_0_720959822 = INT32(Round((INT32(1) shl CONST_BITS) * 0.720959822)); {5906}
FIX_0_765366865 = INT32(Round((INT32(1) shl CONST_BITS) * 0.765366865)); {6270}
FIX_0_850430095 = INT32(Round((INT32(1) shl CONST_BITS) * 0.850430095)); {6967}
FIX_0_899976223 = INT32(Round((INT32(1) shl CONST_BITS) * 0.899976223)); {7373}
FIX_1_061594337 = INT32(Round((INT32(1) shl CONST_BITS) * 1.061594337)); {8697}
FIX_1_272758580 = INT32(Round((INT32(1) shl CONST_BITS) * 1.272758580)); {10426}
FIX_1_451774981 = INT32(Round((INT32(1) shl CONST_BITS) * 1.451774981)); {11893}
FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS) * 1.847759065)); {15137}
FIX_2_172734803 = INT32(Round((INT32(1) shl CONST_BITS) * 2.172734803)); {17799}
FIX_2_562915447 = INT32(Round((INT32(1) shl CONST_BITS) * 2.562915447)); {20995}
FIX_3_624509785 = INT32(Round((INT32(1) shl CONST_BITS) * 3.624509785)); {29692}
{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result.
For 8-bit samples with the recommended scaling, all the variable
and constant values involved are no more than 16 bits wide, so a
16x16->32 bit multiply can be used instead of a full 32x32 multiply.
For 12-bit samples, a full 32-bit multiplication will be needed. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{function Multiply(X, Y: Integer): integer; assembler;
asm
mov ax, X
imul Y
mov al, ah
mov ah, dl
end;}
{MULTIPLY16C16(var,const)}
function Multiply(X, Y: Integer): INT32;
begin
Multiply := X*INT32(Y);
end;
{$else}
function Multiply(X, Y: INT32): INT32;
begin
Multiply := X*Y;
end;
{$endif}
{ Dequantize a coefficient by multiplying it by the multiplier-table
entry; produce an int result. In this module, both inputs and result
are 16 bits or less, so either int or short multiply will work. }
function DEQUANTIZE(coef,quantval : int) : int;
begin
Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval);
end;
{ Descale and correctly round an INT32 value that's scaled by N bits.
We assume RIGHT_SHIFT rounds towards minus infinity, so adding
the fudge factor is correct for either sign of X. }
function DESCALE(x : INT32; n : int) : INT32;
var
shift_temp : INT32;
begin
{$ifdef RIGHT_SHIFT_IS_UNSIGNED}
shift_temp := x + (INT32(1) shl (n-1));
if shift_temp < 0 then
Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n))
else
Descale := (shift_temp shr n);
{$else}
Descale := (x + (INT32(1) shl (n-1)) shr n;
{$endif}
end;
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 4x4 output block. }
{GLOBAL}
procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = array[0..(DCTSIZE*4)-1] of int; { buffers data between passes }
var
tmp0, tmp2, tmp10, tmp12 : INT32;
z1, z2, z3, z4 : INT32;
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS}
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace;
for ctr := DCTSIZE downto 1 do
begin
{ Don't bother to process column 4, because second pass won't use it }
if (ctr = DCTSIZE-4) then
begin
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and (inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero; we need not examine term 4 for 4x4 output }
dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) *
quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
wsptr^[DCTSIZE*2] := dcval;
wsptr^[DCTSIZE*3] := dcval;
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part }
tmp0 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]);
tmp0 := tmp0 shl (CONST_BITS+1);
z2 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2]);
z3 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6]);
tmp2 := MULTIPLY(z2, FIX_1_847759065) + MULTIPLY(z3, - FIX_0_765366865);
tmp10 := tmp0 + tmp2;
tmp12 := tmp0 - tmp2;
{ Odd part }
z1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7];
z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5];
z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3];
z4 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1];
tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) }
+ MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) }
+ MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) }
+ MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) }
tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) }
+ MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) }
+ MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) }
+ MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) }
{ Final output stage }
wsptr^[DCTSIZE*0] := int(DESCALE(tmp10 + tmp2, CONST_BITS-PASS1_BITS+1));
wsptr^[DCTSIZE*3] := int(DESCALE(tmp10 - tmp2, CONST_BITS-PASS1_BITS+1));
wsptr^[DCTSIZE*1] := int(DESCALE(tmp12 + tmp0, CONST_BITS-PASS1_BITS+1));
wsptr^[DCTSIZE*2] := int(DESCALE(tmp12 - tmp0, CONST_BITS-PASS1_BITS+1));
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process 4 rows from work array, store into output array. }
wsptr := @workspace;
for ctr := 0 to pred(4) do
begin
outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]);
{ It's not clear whether a zero row test is worthwhile here ... }
{$ifndef NO_ZERO_ROW_TEST}
if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and
(wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then
begin
{ AC terms all zero }
dcval_ := range_limit^[int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3))
and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
outptr^[2] := dcval_;
outptr^[3] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part }
tmp0 := (INT32(wsptr^[0])) shl (CONST_BITS+1);
tmp2 := MULTIPLY(INT32(wsptr^[2]), FIX_1_847759065)
+ MULTIPLY(INT32(wsptr^[6]), - FIX_0_765366865);
tmp10 := tmp0 + tmp2;
tmp12 := tmp0 - tmp2;
{ Odd part }
z1 := INT32(wsptr^[7]);
z2 := INT32(wsptr^[5]);
z3 := INT32(wsptr^[3]);
z4 := INT32(wsptr^[1]);
tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) }
+ MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) }
+ MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) }
+ MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) }
tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) }
+ MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) }
+ MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) }
+ MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) }
{ Final output stage }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp2,
CONST_BITS+PASS1_BITS+3+1))
and RANGE_MASK];
outptr^[3] := range_limit^[ int(DESCALE(tmp10 - tmp2,
CONST_BITS+PASS1_BITS+3+1))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp12 + tmp0,
CONST_BITS+PASS1_BITS+3+1))
and RANGE_MASK];
outptr^[2] := range_limit^[ int(DESCALE(tmp12 - tmp0,
CONST_BITS+PASS1_BITS+3+1))
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 2x2 output block. }
{GLOBAL}
procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
type
PWorkspace = ^TWorkspace;
TWorkspace = array[0..(DCTSIZE*2)-1] of int; { buffers data between passes }
var
tmp0, tmp10, z1 : INT32;
inptr : JCOEFPTR;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
wsptr : PWorkspace;
outptr : JSAMPROW;
range_limit : JSAMPROW;
ctr : int;
workspace : TWorkspace; { buffers data between passes }
{SHIFT_TEMPS}
var
dcval : int;
var
dcval_ : JSAMPLE;
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
inptr := coef_block;
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
wsptr := @workspace;
for ctr := DCTSIZE downto 1 do
begin
{ Don't bother to process columns 2,4,6 }
if (ctr = DCTSIZE-2) or (ctr = DCTSIZE-4) or (ctr = DCTSIZE-6) then
begin
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*3]=0) and
(inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*7]=0) then
begin
{ AC terms all zero; we need not examine terms 2,4,6 for 2x2 output }
dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) *
quantptr^[DCTSIZE*0]) shl PASS1_BITS;
wsptr^[DCTSIZE*0] := dcval;
wsptr^[DCTSIZE*1] := dcval;
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
continue;
end;
{ Even part }
z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]);
tmp10 := z1 shl (CONST_BITS+2);
{ Odd part }
z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7]);
tmp0 := MULTIPLY(z1, - FIX_0_720959822); { sqrt(2) * (c7-c5+c3-c1) }
z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5]);
Inc(tmp0, MULTIPLY(z1, FIX_0_850430095)); { sqrt(2) * (-c1+c3+c5+c7) }
z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3]);
Inc(tmp0, MULTIPLY(z1, - FIX_1_272758580)); { sqrt(2) * (-c1+c3-c5-c7) }
z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1]);
Inc(tmp0, MULTIPLY(z1, FIX_3_624509785)); { sqrt(2) * (c1+c3+c5+c7) }
{ Final output stage }
wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp0, CONST_BITS-PASS1_BITS+2));
wsptr^[DCTSIZE*1] := int (DESCALE(tmp10 - tmp0, CONST_BITS-PASS1_BITS+2));
Inc(JCOEF_PTR(inptr));
Inc(ISLOW_MULT_TYPE_PTR(quantptr));
Inc(int_ptr(wsptr));
end;
{ Pass 2: process 2 rows from work array, store into output array. }
wsptr := @workspace;
for ctr := 0 to pred(2) do
begin
outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]);
{ It's not clear whether a zero row test is worthwhile here ... }
{$ifndef NO_ZERO_ROW_TEST}
if (wsptr^[1]=0) and (wsptr^[3]=0) and (wsptr^[5]=0) and (wsptr^[7]= 0) then
begin
{ AC terms all zero }
dcval_ := range_limit^[ int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3))
and RANGE_MASK];
outptr^[0] := dcval_;
outptr^[1] := dcval_;
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
continue;
end;
{$endif}
{ Even part }
tmp10 := (INT32 (wsptr^[0])) shl (CONST_BITS+2);
{ Odd part }
tmp0 := MULTIPLY( INT32(wsptr^[7]), - FIX_0_720959822) { sqrt(2) * (c7-c5+c3-c1) }
+ MULTIPLY( INT32(wsptr^[5]), FIX_0_850430095) { sqrt(2) * (-c1+c3+c5+c7) }
+ MULTIPLY( INT32(wsptr^[3]), - FIX_1_272758580) { sqrt(2) * (-c1+c3-c5-c7) }
+ MULTIPLY( INT32(wsptr^[1]), FIX_3_624509785); { sqrt(2) * (c1+c3+c5+c7) }
{ Final output stage }
outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp0,
CONST_BITS+PASS1_BITS+3+2))
and RANGE_MASK];
outptr^[1] := range_limit^[ int(DESCALE(tmp10 - tmp0,
CONST_BITS+PASS1_BITS+3+2))
and RANGE_MASK];
Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row }
end;
end;
{ Perform dequantization and inverse DCT on one block of coefficients,
producing a reduced-size 1x1 output block. }
{GLOBAL}
procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr;
compptr : jpeg_component_info_ptr;
coef_block : JCOEFPTR;
output_buf : JSAMPARRAY;
output_col : JDIMENSION);
var
dcval : int;
quantptr : ISLOW_MULT_TYPE_FIELD_PTR;
range_limit : JSAMPROW;
{SHIFT_TEMPS}
begin
{ Each IDCT routine is responsible for range-limiting its results and
converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could
be quite far out of range if the input data is corrupt, so a bulletproof
range-limiting step is required. We use a mask-and-table-lookup method
to do the combined operations quickly. See the comments with
prepare_range_limit_table (in jdmaster.c) for more info. }
range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));
{ Pass 1: process columns from input, store into work array. }
{ We hardly need an inverse DCT routine for this: just take the
average pixel value, which is one-eighth of the DC coefficient. }
quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);
dcval := (ISLOW_MULT_TYPE(coef_block^[0]) * quantptr^[0]);
dcval := int (DESCALE( INT32(dcval), 3));
output_buf^[0]^[output_col] := range_limit^[dcval and RANGE_MASK];
end;
end.

126
Imaging/JpegLib/imjinclude.pas Normal file
View File

@@ -0,0 +1,126 @@
unit imjinclude;
{ This file exists to provide a single place to fix any problems with
including the wrong system include files. (Common problems are taken
care of by the standard jconfig symbols, but on really weird systems
you may have to edit this file.)
NOTE: this file is NOT intended to be included by applications using the
JPEG library. Most applications need only include jpeglib.h. }
{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{ Include auto-config file to find out which system include files we need. }
uses
{$ifdef Delphi_Stream}
classes,
{$endif}
imjmorecfg;
{ Nomssi:
To write a dest/source manager that handle streams rather than files,
you can edit the FILEptr definition and the JFREAD() and JFWRITE()
functions in this unit, you don't need to change the default managers
JDATASRC and JDATADST. }
{$ifdef Delphi_Stream}
type
FILEptr = ^TStream;
{$else}
{$ifdef Delphi_Jpeg}
type
FILEptr = TCustomMemoryStream;
{$else}
type
FILEptr = ^File;
{$endif}
{$endif}
{ We need the NULL macro and size_t typedef.
On an ANSI-conforming system it is sufficient to include <stddef.h>.
Otherwise, we get them from <stdlib.h> or <stdio.h>; we may have to
pull in <sys/types.h> as well.
Note that the core JPEG library does not require <stdio.h>;
only the default error handler and data source/destination modules do.
But we must pull it in because of the references to FILE in jpeglib.h.
You can remove those references if you want to compile without <stdio.h>.}
{ We need memory copying and zeroing functions, plus strncpy().
ANSI and System V implementations declare these in <string.h>.
BSD doesn't have the mem() functions, but it does have bcopy()/bzero().
Some systems may declare memset and memcpy in <memory.h>.
NOTE: we assume the size parameters to these functions are of type size_t.
Change the casts in these macros if not! }
procedure MEMZERO(target : pointer; size : size_t);
procedure MEMCOPY(dest, src : pointer; size : size_t);
{function SIZEOF(object) : size_t;}
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
implementation
procedure MEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure MEMCOPY(dest, src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{ In ANSI C, and indeed any rational implementation, size_t is also the
type returned by sizeof(). However, it seems there are some irrational
implementations out there, in which sizeof() returns an int even though
size_t is defined as long or unsigned long. To ensure consistent results
we always use this SIZEOF() macro in place of using sizeof() directly. }
{#define
SIZEOF(object) (size_t(sizeof(object))}
{ The modules that use fread() and fwrite() always invoke them through
these macros. On some systems you may need to twiddle the argument casts.
CAUTION: argument order is different from underlying functions! }
function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Read(buf^, sizeofbuf);
{$else}
blockread(fp^, buf^, sizeofbuf, count);
{$endif}
JFREAD := size_t(count);
end;
function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t;
var
count : uint;
begin
{$ifdef Delphi_Stream}
count := fp^.Write(buf^, sizeofbuf);
{$else}
blockwrite(fp^, buf^, sizeofbuf, count);
{$endif}
JFWRITE := size_t(count);
end;
end.

1282
Imaging/JpegLib/imjmemmgr.pas Normal file
View File

File diff suppressed because it is too large Load Diff

264
Imaging/JpegLib/imjmemnobs.pas Normal file
View File

@@ -0,0 +1,264 @@
unit imjmemnobs;
{ Delphi3 -- > jmemnobs from jmemwin }
{ This file provides an Win32-compatible implementation of the system-
dependent portion of the JPEG memory manager. }
{ Check jmemnobs.c }
{ Copyright (C) 1996, Jacques Nomssi Nzali }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjdeferr,
imjerror,
imjpeglib;
{ The macro MAX_ALLOC_CHUNK designates the maximum number of bytes that may
be requested in a single call to jpeg_get_large (and jpeg_get_small for that
matter, but that case should never come into play). This macro is needed
to model the 64Kb-segment-size limit of far addressing on 80x86 machines.
On those machines, we expect that jconfig.h will provide a proper value.
On machines with 32-bit flat address spaces, any large constant may be used.
NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type
size_t and will be a multiple of sizeof(align_type). }
{$IFDEF WINDOWS}
const
MAX_ALLOC_CHUNK = long(32752);
{$ELSE}
const
MAX_ALLOC_CHUNK = long(1000000000);
{$ENDIF}
{GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long);
{ These routines take care of any system-dependent initialization and
cleanup required. }
{GLOBAL}
function jpeg_mem_init (cinfo : j_common_ptr) : long;
{GLOBAL}
procedure jpeg_mem_term (cinfo : j_common_ptr);
{ These two functions are used to allocate and release small chunks of
memory. (Typically the total amount requested through jpeg_get_small is
no more than 20K or so; this will be requested in chunks of a few K each.)
Behavior should be the same as for the standard library functions malloc
and free; in particular, jpeg_get_small must return NIL on failure.
On most systems, these ARE malloc and free. jpeg_free_small is passed the
size of the object being freed, just in case it's needed.
On an 80x86 machine using small-data memory model, these manage near heap. }
{ Near-memory allocation and freeing are controlled by the regular library
routines malloc() and free(). }
{GLOBAL}
function jpeg_get_small (cinfo : j_common_ptr;
sizeofobject : size_t) : pointer;
{GLOBAL}
{object is a reserved word in Borland Pascal }
procedure jpeg_free_small (cinfo : j_common_ptr;
an_object : pointer;
sizeofobject : size_t);
{ These two functions are used to allocate and release large chunks of
memory (up to the total free space designated by jpeg_mem_available).
The interface is the same as above, except that on an 80x86 machine,
far pointers are used. On most other machines these are identical to
the jpeg_get/free_small routines; but we keep them separate anyway,
in case a different allocation strategy is desirable for large chunks. }
{ "Large" objects are allocated in far memory, if possible }
{GLOBAL}
function jpeg_get_large (cinfo : j_common_ptr;
sizeofobject : size_t) : voidp; {far}
{GLOBAL}
procedure jpeg_free_large (cinfo : j_common_ptr;
{var?} an_object : voidp; {FAR}
sizeofobject : size_t);
{ This routine computes the total memory space available for allocation.
It's impossible to do this in a portable way; our current solution is
to make the user tell us (with a default value set at compile time).
If you can actually get the available space, it's a good idea to subtract
a slop factor of 5% or so. }
{GLOBAL}
function jpeg_mem_available (cinfo : j_common_ptr;
min_bytes_needed : long;
max_bytes_needed : long;
already_allocated : long) : long;
implementation
{ This structure holds whatever state is needed to access a single
backing-store object. The read/write/close method pointers are called
by jmemmgr.c to manipulate the backing-store object; all other fields
are private to the system-dependent backing store routines. }
{ These two functions are used to allocate and release small chunks of
memory. (Typically the total amount requested through jpeg_get_small is
no more than 20K or so; this will be requested in chunks of a few K each.)
Behavior should be the same as for the standard library functions malloc
and free; in particular, jpeg_get_small must return NIL on failure.
On most systems, these ARE malloc and free. jpeg_free_small is passed the
size of the object being freed, just in case it's needed.
On an 80x86 machine using small-data memory model, these manage near heap. }
{ Near-memory allocation and freeing are controlled by the regular library
routines malloc() and free(). }
{GLOBAL}
function jpeg_get_small (cinfo : j_common_ptr;
sizeofobject : size_t) : pointer;
var
p : pointer;
begin
GetMem(p, sizeofobject);
jpeg_get_small := p;
end;
{GLOBAL}
{object is a reserved word in Object Pascal }
procedure jpeg_free_small (cinfo : j_common_ptr;
an_object : pointer;
sizeofobject : size_t);
begin
FreeMem(an_object, sizeofobject);
end;
{ These two functions are used to allocate and release large chunks of
memory (up to the total free space designated by jpeg_mem_available).
The interface is the same as above, except that on an 80x86 machine,
far pointers are used. On most other machines these are identical to
the jpeg_get/free_small routines; but we keep them separate anyway,
in case a different allocation strategy is desirable for large chunks. }
{GLOBAL}
function jpeg_get_large (cinfo : j_common_ptr;
sizeofobject : size_t) : voidp; {far}
var
p : pointer;
begin
GetMem(p, sizeofobject);
jpeg_get_large := p;
end;
{GLOBAL}
procedure jpeg_free_large (cinfo : j_common_ptr;
{var?} an_object : voidp; {FAR}
sizeofobject : size_t);
begin
Freemem(an_object, sizeofobject);
end;
{ This routine computes the total space still available for allocation by
jpeg_get_large. If more space than this is needed, backing store will be
used. NOTE: any memory already allocated must not be counted.
There is a minimum space requirement, corresponding to the minimum
feasible buffer sizes; jmemmgr.c will request that much space even if
jpeg_mem_available returns zero. The maximum space needed, enough to hold
all working storage in memory, is also passed in case it is useful.
Finally, the total space already allocated is passed. If no better
method is available, cinfo^.mem^.max_memory_to_use - already_allocated
is often a suitable calculation.
It is OK for jpeg_mem_available to underestimate the space available
(that'll just lead to more backing-store access than is really necessary).
However, an overestimate will lead to failure. Hence it's wise to subtract
a slop factor from the true available space. 5% should be enough.
On machines with lots of virtual memory, any large constant may be returned.
Conversely, zero may be returned to always use the minimum amount of memory.}
{ This routine computes the total memory space available for allocation.
It's impossible to do this in a portable way; our current solution is
to make the user tell us (with a default value set at compile time).
If you can actually get the available space, it's a good idea to subtract
a slop factor of 5% or so. }
const
DEFAULT_MAX_MEM = long(300000); { for total usage about 450K }
{GLOBAL}
function jpeg_mem_available (cinfo : j_common_ptr;
min_bytes_needed : long;
max_bytes_needed : long;
already_allocated : long) : long;
begin
{jpeg_mem_available := cinfo^.mem^.max_memory_to_use - already_allocated;}
jpeg_mem_available := max_bytes_needed;
end;
{ Initial opening of a backing-store object. This must fill in the
read/write/close pointers in the object. The read/write routines
may take an error exit if the specified maximum file size is exceeded.
(If jpeg_mem_available always returns a large value, this routine can
just take an error exit.) }
{ Initial opening of a backing-store object. }
{GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr;
info : backing_store_ptr;
total_bytes_needed : long);
begin
ERREXIT(cinfo, JERR_NO_BACKING_STORE);
end;
{ These routines take care of any system-dependent initialization and
cleanup required. jpeg_mem_init will be called before anything is
allocated (and, therefore, nothing in cinfo is of use except the error
manager pointer). It should return a suitable default value for
max_memory_to_use; this may subsequently be overridden by the surrounding
application. (Note that max_memory_to_use is only important if
jpeg_mem_available chooses to consult it ... no one else will.)
jpeg_mem_term may assume that all requested memory has been freed and that
all opened backing-store objects have been closed. }
{ These routines take care of any system-dependent initialization and
cleanup required. }
{GLOBAL}
function jpeg_mem_init (cinfo : j_common_ptr) : long;
begin
jpeg_mem_init := DEFAULT_MAX_MEM; { default for max_memory_to_use }
end;
{GLOBAL}
procedure jpeg_mem_term (cinfo : j_common_ptr);
begin
end;
end.

247
Imaging/JpegLib/imjmorecfg.pas Normal file
View File

@@ -0,0 +1,247 @@
unit imjmorecfg;
{ This file contains additional configuration options that customize the
JPEG software for special applications or support machine-dependent
optimizations. Most users will not need to touch this file. }
{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
{$IFDEF FPC} { Free Pascal Compiler }
type
int = longint;
uInt = Cardinal; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF WIN32}
{ Delphi 2.0 }
type
int = Integer;
uInt = Cardinal;
short = SmallInt;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF VIRTUALPASCAL}
type
int = longint;
uInt = longint; { unsigned int }
short = system.Integer;
ushort = system.Word;
long = longint;
{$ELSE}
type
int = Integer;
uInt = Word; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ENDIF}
{$ENDIF}
{$ENDIF}
type
voidp = pointer;
type
int_ptr = ^int;
size_t = int;
{ Define BITS_IN_JSAMPLE as either
8 for 8-bit sample values (the usual setting)
12 for 12-bit sample values
Only 8 and 12 are legal data precisions for lossy JPEG according to the
JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. }
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const
BITS_IN_JSAMPLE = 8;
{$else}
const
BITS_IN_JSAMPLE = 12;
{$endif}
{ Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn
few applications need more than 4 channels (maybe 5 for CMYK + alpha
mask). We recommend 10 as a reasonable compromise; use 4 if you are
really short on memory. (Each allowed component costs a hundred or so
bytes of storage, whether actually used in an image or not.) }
const
MAX_COMPONENTS = 10; { maximum number of image components }
{ Basic data types.
You may need to change these if you have a machine with unusual data
type sizes; for example, "char" not 8 bits, "short" not 16 bits,
or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits,
but it had better be at least 16. }
{ Representation of a single sample (pixel element value).
We frequently allocate large arrays of these, so it's important to keep
them small. But if you have memory to burn and access to char or short
arrays is very slow on your hardware, you might want to change these. }
{$ifdef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..255.
You can use a signed char by having GETJSAMPLE mask it with $FF. }
{ CHAR_IS_UNSIGNED }
type
JSAMPLE = byte; { Pascal unsigned char }
GETJSAMPLE = int;
const
MAXJSAMPLE = 255;
CENTERJSAMPLE = 128;
{$endif}
{$ifndef BITS_IN_JSAMPLE_IS_8}
{ JSAMPLE should be the smallest type that will hold the values 0..4095.
On nearly all machines "short" will do nicely. }
type
JSAMPLE = short;
GETJSAMPLE = int;
const
MAXJSAMPLE = 4095;
CENTERJSAMPLE = 2048;
{$endif} { BITS_IN_JSAMPLE = 12 }
{ Representation of a DCT frequency coefficient.
This should be a signed value of at least 16 bits; "short" is usually OK.
Again, we allocate large arrays of these, but you can change to int
if you have memory to burn and "short" is really slow. }
type
JCOEF = int;
JCOEF_PTR = ^JCOEF;
{ Compressed datastreams are represented as arrays of JOCTET.
These must be EXACTLY 8 bits wide, at least once they are written to
external storage. Note that when using the stdio data source/destination
managers, this is also the data type passed to fread/fwrite. }
type
JOCTET = Byte;
jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
JOCTET_FIELD = array[jTOctet] of JOCTET;
JOCTET_FIELD_PTR = ^JOCTET_FIELD;
JOCTETPTR = ^JOCTET;
GETJOCTET = JOCTET; { A work around }
{ These typedefs are used for various table entries and so forth.
They must be at least as wide as specified; but making them too big
won't cost a huge amount of memory, so we don't provide special
extraction code like we did for JSAMPLE. (In other words, these
typedefs live at a different point on the speed/space tradeoff curve.) }
{ UINT8 must hold at least the values 0..255. }
type
UINT8 = byte;
{ UINT16 must hold at least the values 0..65535. }
UINT16 = Word;
{ INT16 must hold at least the values -32768..32767. }
INT16 = int;
{ INT32 must hold at least signed 32-bit values. }
INT32 = longint;
type
INT32PTR = ^INT32;
{ Datatype used for image dimensions. The JPEG standard only supports
images up to 64K*64K due to 16-bit fields in SOF markers. Therefore
"unsigned int" is sufficient on all machines. However, if you need to
handle larger images and you don't mind deviating from the spec, you
can change this datatype. }
type
JDIMENSION = uInt;
const
JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows }
{ Ordering of RGB data in scanlines passed to or from the application.
If your application wants to deal with data in the order B,G,R, just
change these macros. You can also deal with formats such as R,G,B,X
(one extra byte per pixel) by changing RGB_PIXELSIZE. Note that changing
the offsets will also change the order in which colormap data is organized.
RESTRICTIONS:
1. The sample applications cjpeg,djpeg do NOT support modified RGB formats.
2. These macros only affect RGB<=>YCbCr color conversion, so they are not
useful if you are using JPEG color spaces other than YCbCr or grayscale.
3. The color quantizer modules will not behave desirably if RGB_PIXELSIZE
is not 3 (they don't understand about dummy color components!). So you
can't use color quantization if you change that value. }
{$ifdef RGB_RED_IS_0}
const
RGB_RED = 0; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 2; { Offset of Blue }
{$else}
const
RGB_RED = 2; { Offset of Red in an RGB scanline element }
RGB_GREEN = 1; { Offset of Green }
RGB_BLUE = 0; { Offset of Blue }
{$endif}
{$ifdef RGB_PIXELSIZE_IS_3}
const
RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element }
{$else}
const
RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value }
{$endif}
{ Definitions for speed-related optimizations. }
{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying
two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER
as short on such a machine. MULTIPLIER must be at least 16 bits wide. }
type
MULTIPLIER = int; { type for fastest integer multiply }
{ FAST_FLOAT should be either float or double, whichever is done faster
by your compiler. (Note that this type is only used in the floating point
DCT routines, so it only matters if you've defined DCT_FLOAT_SUPPORTED.)
Typically, float is faster in ANSI C compilers, while double is faster in
pre-ANSI compilers (because they insist on converting to double anyway).
The code below therefore chooses float if we have ANSI-style prototypes. }
type
FAST_FLOAT = double; {float}
implementation
end.

1300
Imaging/JpegLib/imjpeglib.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1009
Imaging/JpegLib/imjquant1.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1551
Imaging/JpegLib/imjquant2.pas Normal file
View File

File diff suppressed because it is too large Load Diff

232
Imaging/JpegLib/imjutils.pas Normal file
View File

@@ -0,0 +1,232 @@
unit imjutils;
{ This file contains tables and miscellaneous utility routines needed
for both compression and decompression.
Note we prefix all global names with "j" to minimize conflicts with
a surrounding application. }
{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. }
interface
{$I imjconfig.inc}
uses
imjmorecfg,
imjinclude,
imjpeglib;
{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element
of a DCT block read in natural order (left to right, top to bottom). }
{$ifdef FALSE} { This table is not actually needed in v6a }
const
jpeg_zigzag_order : array[0..DCTSIZE2] of int =
(0, 1, 5, 6, 14, 15, 27, 28,
2, 4, 7, 13, 16, 26, 29, 42,
3, 8, 12, 17, 25, 30, 41, 43,
9, 11, 18, 24, 31, 40, 44, 53,
10, 19, 23, 32, 39, 45, 52, 54,
20, 22, 33, 38, 46, 51, 55, 60,
21, 34, 37, 47, 50, 56, 59, 61,
35, 36, 48, 49, 57, 58, 62, 63);
{$endif}
{ jpeg_natural_order[i] is the natural-order position of the i'th element
of zigzag order.
When reading corrupted data, the Huffman decoders could attempt
to reference an entry beyond the end of this array (if the decoded
zero run length reaches past the end of the block). To prevent
wild stores without adding an inner-loop test, we put some extra
"63"s after the real entries. This will cause the extra coefficient
to be stored in location 63 of the block, not somewhere random.
The worst case would be a run-length of 15, which means we need 16
fake entries. }
const
jpeg_natural_order : array[0..DCTSIZE2+16-1] of int =
(0, 1, 8, 16, 9, 2, 3, 10,
17, 24, 32, 25, 18, 11, 4, 5,
12, 19, 26, 33, 40, 48, 41, 34,
27, 20, 13, 6, 7, 14, 21, 28,
35, 42, 49, 56, 57, 50, 43, 36,
29, 22, 15, 23, 30, 37, 44, 51,
58, 59, 52, 45, 38, 31, 39, 46,
53, 60, 61, 54, 47, 55, 62, 63,
63, 63, 63, 63, 63, 63, 63, 63, { extra entries for safety in decoder }
63, 63, 63, 63, 63, 63, 63, 63);
{ Arithmetic utilities }
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY;
source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
procedure FMEMZERO(target : pointer; size : size_t);
procedure FMEMCOPY(dest,src : pointer; size : size_t);
implementation
{GLOBAL}
function jdiv_round_up (a : long; b : long) : long;
{ Compute a/b rounded up to next integer, ie, ceil(a/b) }
{ Assumes a >= 0, b > 0 }
begin
jdiv_round_up := (a + b - long(1)) div b;
end;
{GLOBAL}
function jround_up (a : long; b : long) : long;
{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b }
{ Assumes a >= 0, b > 0 }
begin
Inc(a, b - long(1));
jround_up := a - (a mod b);
end;
{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays
and coefficient-block arrays. This won't work on 80x86 because the arrays
are FAR and we're assuming a small-pointer memory model. However, some
DOS compilers provide far-pointer versions of memcpy() and memset() even
in the small-model libraries. These will be used if USE_FMEM is defined.
Otherwise, the routines below do it the hard way. (The performance cost
is not all that great, because these routines aren't very heavily used.) }
{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros }
procedure FMEMZERO(target : pointer; size : size_t);
begin
FillChar(target^, size, 0);
end;
procedure FMEMCOPY(dest,src : pointer; size : size_t);
begin
Move(src^, dest^, size);
end;
{$else} { 80x86 case, define if we can }
{$ifdef USE_FMEM}
FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size))
FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size))
{$endif}
{$endif}
{GLOBAL}
procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int;
output_array : JSAMPARRAY; dest_row : int;
num_rows : int; num_cols : JDIMENSION);
{ Copy some rows of samples from one place to another.
num_rows rows are copied from input_array[source_row++]
to output_array[dest_row++]; these areas may overlap for duplication.
The source and destination arrays must be at least as wide as num_cols. }
var
inptr, outptr : JSAMPLE_PTR; {register}
{$ifdef FMEMCOPY}
count : size_t; {register}
{$else}
count : JDIMENSION; {register}
{$endif}
row : int; {register}
begin
{$ifdef FMEMCOPY}
count := size_t(num_cols * SIZEOF(JSAMPLE));
{$endif}
Inc(JSAMPROW_PTR(input_array), source_row);
Inc(JSAMPROW_PTR(output_array), dest_row);
for row := pred(num_rows) downto 0 do
begin
inptr := JSAMPLE_PTR(input_array^[0]);
Inc(JSAMPROW_PTR(input_array));
outptr := JSAMPLE_PTR(output_array^[0]);
Inc(JSAMPROW_PTR(output_array));
{$ifdef FMEMCOPY}
FMEMCOPY(outptr, inptr, count);
{$else}
for count := pred(num_cols) downto 0 do
begin
outptr^ := inptr^; { needn't bother with GETJSAMPLE() here }
Inc(inptr);
Inc(outptr);
end;
{$endif}
end;
end;
{GLOBAL}
procedure jcopy_block_row (input_row : JBLOCKROW;
output_row : JBLOCKROW;
num_blocks : JDIMENSION);
{ Copy a row of coefficient blocks from one place to another. }
{$ifdef FMEMCOPY}
begin
FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF)));
{$else}
var
inptr, outptr : JCOEFPTR; {register}
count : long; {register}
begin
inptr := JCOEFPTR (input_row);
outptr := JCOEFPTR (output_row);
for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do
begin
outptr^ := inptr^;
Inc(outptr);
Inc(inptr);
end;
{$endif}
end;
{GLOBAL}
procedure jzero_far (target : pointer;{far} bytestozero : size_t);
{ Zero out a chunk of FAR memory. }
{ This might be sample-array data, block-array data, or alloc_large data. }
{$ifdef FMEMZERO}
begin
FMEMZERO(target, bytestozero);
{$else}
var
ptr : byteptr;
count : size_t; {register}
begin
ptr := target;
for count := bytestozero-1 downto 0 do
begin
ptr^ := 0;
Inc(ptr);
end;
{$endif}
end;
end.

381
Imaging/JpegLib/readme.txt Normal file
View File

@@ -0,0 +1,381 @@
_____________________________________________________________________________
PASJPEG 1.1 May 29th, 1999
Based on the Independent JPEG Group's JPEG software release 6b
Copyright (C) 1996,1998,1999 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Information in this file
========================
o Introduction
o Notes
o File list
o Translation
o Legal issues
o Archive Locations
Introduction
============
PASJPEG is a port of the sixth public release of the IJG C source (release
6b of 27-Mar-98) [3], that implements JPEG baseline, extended-sequential, and
progressive compression processes to Turbo Pascal 7.0 for DOS (TP). The code
has been tested under Delphi 3.0, it can be ported to other Pascal
environments, since many compilers try to be compatible to TP.
JPEG (pronounced "jay-peg") is a standardized familly of algorithms for
compression of continous tone still images. Most JPEG processes are lossy,
the output image is not exactly identical to the input image. However, on
typical photographic images, very good compression levels can be obtained
with no visible change, and remarkably high compression levels are possible
if you can tolerate a low-quality image [1],[2]. The Independent JPEG Group
(IJG) has created a free, portable C library for JPEG compression and
decompression of JPEG images.
The IJG documentation (system architecture, using the IJG JPEG library,
usage and file list) is a must read. The files DEMO.PAS, TEST.PAS, CJPEG.PAS,
DJPEG.PAS and EXAMPLE.PAS demonstrate the usage of the JPEG decompression
and compression library. The RDJPGCOM application shows how to parse a JFIF
file.
Notes:
======
* Please report any errors/problems you may find in code and in the
documentation (e.g. this README.TXT file).
* The sample applications (CJPEG, DJPEG) doesn't support all the options
of the original C code. WRJPGCOM is not ported.
* Environment variable JPEGMEM syntax changed;
* You can modify the jpeg.pas unit from the Delphi 3 distribution to
use PasJPEG.
Change log
==========
1. bugs fixed:
* in procedure read_gif_map(), unit RDCOLMAP.PAS (used by DJPEG sample
application). Davie Lee Reed <smatters@iquest.net>
* -dct int and -dct fast now bytewise equal to the IJG output.
* -dct float produced large files
2. Support for scripts
3. BASM version of JIDCTINT.PAS for Delphi 2 and 3.
4. images with integral sampling ratios were not decoded correctly.
Create a jpeg file with cjpeg and the option "-sample 4x1" and try to decode
it with any software that uses PasJpeg. Thanks to Jannie Gerber for reporting
this with a fix: In JDSAMPLE.PAS, procedure int_upsample(),
for h := pred(h_expand) downto 0 do
begin
outptr^ := invalue;
+=> inc(outptr); { this is the culprit that was left out!!! }
Dec(outcount);
end;
File list
=========
Here is a road map to the files in the PasJPEG distribution. The
distribution includes the JPEG library proper, plus two application
programs ("cjpeg" and "djpeg") which use the library to convert JPEG
files to and from some other popular image formats. A third application
"jpegtran" uses the library to do lossless conversion between different
variants of JPEG. There is also the stand-alone applications "rdjpgcom".
Documentation(see README for a guide to the documentation files):
readme.txt Introduction, Documentation
Additional files
demo.pas Demo program, uses example.pas
example.pas Sample code for calling JPEG library.
test.pas Sample application code for demo.pas
Configuration/installation files and programs (see install.doc for more info):
jconfig.inc Configuration declarations.
*.ijg script files
Pascal source code files:
jinclude.pas Central include file used by all IJG .c files to reference
system include files.
jpeglib.pas JPEG library's internal data structures, exported data
and function declarations.
jmorecfg.pas Additional configuration declarations; need not be changed
for a standard installation.
jdeferr.pas defines the error and message text.
jerror.pas Declares JPEG library's error and trace message codes.
jinclude.pas the place to specify system depedent input/output code.
jdct.pas Private declarations for forward & reverse DCT subsystems.
These files contain most of the functions intended to be called directly by
an application program:
jcapimin.pas Application program interface: core routines for compression.
jcapistd.pas Application program interface: standard compression.
jdapimin.pas Application program interface: core routines for decompression.
jdapistd.pas Application program interface: standard decompression.
jcomapi.pas Application program interface routines common to compression
and decompression.
jcparam.pas Compression parameter setting helper routines.
jctrans.pas API and library routines for transcoding compression.
jdtrans.pas API and library routines for transcoding decompression.
Compression side of the library:
jcinit.pas Initialization: determines which other modules to use.
jcmaster.pas Master control: setup and inter-pass sequencing logic.
jcmainct.pas Main buffer controller (preprocessor => JPEG compressor).
jcprepct.pas Preprocessor buffer controller.
jccoefct.pas Buffer controller for DCT coefficient buffer.
jccolor.pas Color space conversion.
jcsample.pas Downsampling.
jcdctmgr.pas DCT manager (DCT implementation selection & control).
jfdctint.pas Forward DCT using slow-but-accurate integer method.
jfdctfst.pas Forward DCT using faster, less accurate integer method.
jfdctflt.pas Forward DCT using floating-point arithmetic.
jchuff.pas Huffman entropy coding for sequential JPEG.
jcphuff.pas Huffman entropy coding for progressive JPEG.
jcmarker.pas JPEG marker writing.
jdatadst.pas Data destination manager for stdio output.
Decompression side of the library:
jdmaster.pas Master control: determines which other modules to use.
jdinput.pas Input controller: controls input processing modules.
jdmainct.pas Main buffer controller (JPEG decompressor => postprocessor).
jdcoefct.pas Buffer controller for DCT coefficient buffer.
jdpostct.pas Postprocessor buffer controller.
jdmarker.pas JPEG marker reading.
jdhuff.pas Huffman entropy decoding for sequential JPEG.
jdphuff.pas Huffman entropy decoding for progressive JPEG.
jddctmgr.pas IDCT manager (IDCT implementation selection & control).
jidctint.pas Inverse DCT using slow-but-accurate integer method.
jidctasm.pas BASM specific version of jidctint.pas for 32bit Delphi.
jidctfst.pas Inverse DCT using faster, less accurate integer method.
jidctflt.pas Inverse DCT using floating-point arithmetic.
jidctred.pas Inverse DCTs with reduced-size outputs.
jidct2d.pas How to for a direct 2D Inverse DCT - not used
jdsample.pas Upsampling.
jdcolor.pas Color space conversion.
jdmerge.pas Merged upsampling/color conversion (faster, lower quality).
jquant1.pas One-pass color quantization using a fixed-spacing colormap.
jquant2.pas Two-pass color quantization using a custom-generated colormap.
Also handles one-pass quantization to an externally given map.
jdatasrc.pas Data source manager for stdio input.
Support files for both compression and decompression:
jerror.pas Standard error handling routines (application replaceable).
jmemmgr.pas System-independent (more or less) memory management code.
jutils.pas Miscellaneous utility routines.
jmemmgr.pas relies on a system-dependent memory management module. The
PASJPEG distribution includes the following implementations of the system-
dependent module:
jmemnobs.pas "No backing store": assumes adequate virtual memory exists.
jmemdos.pas Custom implementation for MS-DOS (16-bit environment only):
can use extended and expanded memory as well as temporary
files.
jmemsys.pas A skeleton with all the declaration you need to create a
working system-dependent JPEG memory manager on unusual
systems.
Exactly one of the system-dependent units should be used in jmemmgr.pas.
jmemdosa.pas BASM 80x86 assembly code support for jmemdos.pas; used only
in MS-DOS-specific configurations of the JPEG library.
Applications using the library should use jmorecfg, jerror, jpeglib, and
include jconfig.inc.
CJPEG/DJPEG/JPEGTRAN
Pascal source code files:
cderror.pas Additional error and trace message codes for cjpeg/djpeg.
Not used, Those errors have been added to jdeferr.
cjpeg.pas Main program for cjpeg.
djpeg.pas Main program for djpeg.
jpegtran.pas Main program for jpegtran.
cdjpeg.pas Utility routines used by all three programs.
rdcolmap.pas Code to read a colormap file for djpeg's "-map" switch.
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
transupp.pas Support code for jpegtran: lossless image manipulations.
fcache.pas
rdswitch.pas Code to process some of cjpeg's more complex switches.
Also used by jpegtran.
Image file writer modules for djpeg:
wrbmp.pas BMP file output.
wrppm.pas PPM/PGM file output.
wrtarga.pas Targa file output.
Image file reader modules for cjpeg:
rdbmp.pas BMP file input.
rdppm.pas PPM/PGM file input.
rdtarga.pas Targa file input. - NOT READY YET
This program does not depend on the JPEG library
rdjpgcom.pas Stand-alone rdjpgcom application.
Translation
===========
TP is unit-centric, exported type definitions and routines are declared
in the "interface" part of the unit, "make" files are not needed.
Macros are not supported, they were either copied as needed or translated
to Pascal routines (procedure). The procedures will be replaced by code in
later releases.
Conditional defines that indicate whether to include various optional
functions are defined in the file JCONFIG.INC. This file is included first
in all source files.
The base type definitions are in the unit JMORECFG.PAS. The error handling
macros have been converted to procedures in JERROR.PAS. The error codes are
in JDEFERR.PAS. jpegint.h and jpeglib.h were merged into one large unit
JPEGLIB.PAS containing type definitions with global scope.
The translation of the header file is the most sophisticated work, a good
understanding of the syntax is required. Once the header files are done,
the translation turns into a lot of editing work. Each C source file was
converted to a unit by editing the syntax (separate variable definition
and usage, define labels, group variable definitions, expanding macros, etc).
The IJG source labels routines GLOBAL, METHODDEF and LOCAL. All globals
routines are in the interface section of the units. The "far" directive is
used for methods (METHODDEF).
Some C -> Pascal examples.
* "{" -> "begin" "->" -> "^." " = " -> " := " "<<" -> " shl "
"}" -> "end;" "!=" -> "<>" " == " -> " = " ">>" -> " shr "
"/*" -> "{" routine -> function "0x" -> "$"
"*/" -> "}" (void) procedure "NULL" -> "NIL"
* structs are records, Unions are variable records, pointers are always far,
the operators && and || (and/or) have not the same priority in both
languages, so parenthesis are important. The Pascal "case" doesn't have the
falltrough option of the C "switch" statement, my work around is to split
one "switch" statement into many case statements.
* The pointer type in C is not readily interchangeable. It is used to address
an array (Pascal pointer to an array) or in pointer arithmetic a pointer to
a single element. I've used the Inc() statement with type casting to
translate pointer arithmetic most of the time.
C example:
typedef JSAMPLE* JSAMPROW; /* ptr to one image row of pixel samples. */
Pascal
type
JSAMPLE_PTR = ^JSAMPLE; { ptr to a single pixel sample. }
jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1;
JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far}
JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. }
The following code
JSAMPROW buffer0, buffer1; /* ptr to a JSAMPLE buffer. */
...
buffer1 = buffer0 + i;
can be translated to
var
buffer0, buffer1 : JSAMPROW;
...
buffer1 := buffer0;
Inc(JSAMPLE_PTR(buffer1), i);
or
buffer1 := JSAMPROW(@ buffer0^[i]);
Declaring the variables as JSAMPLE_PTR may reduce type casting in some
places. I use help pointers to handle negative array offsets.
While translating the type of function parameter from C to Pascal, one can
often use "var", "const", or "array of" parameters instead of pointers.
While translating for(;;)-loops with more than one induction variable to
Pascal "for to/downto do"-loops, the extra induction variables have to be
manually updated at the end of the loop and before "continue"-statements.
Legal issues
============
Copyright (C) 1996,1998 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
[1] Thomas G. Lane, JPEG FAQ
in comp.graphics.misc and related newsgroups
[2] Wallace, Gregory K.: The JPEG Still Picture Compression Standard
ftp.uu.net, graphics/jpeg/wallace.ps.Z
[3] The Independent JPEG Group C library for JPEG encoding and decoding,
rev 6b.
ftp://ftp.uu.net/graphics/jpeg/
or SimTel in msdos/graphics/
[4] JPEG implementation, written by the PVRG group at Stanford,
ftp havefun.stanford.edu:/pub/jpeg/JPEGv1.2.tar.Z.
[5] PASJPEG.ZIP at NView ftp site
ftp://druckfix.physik.tu-chemnitz.de/pub/nv/
http://www.tu-chemnitz.de/~nomssi/pub/pasjpeg.zip
[6] The PasJPEG home page with links
http://www.tu-chemnitz.de/~nomssi/pasjpeg.html
_____________________________________________________________________________

520
Imaging/ZLib/dzlib.pas Normal file
View File

@@ -0,0 +1,520 @@
{*******************************************************}
{ }
{ Delphi Supplemental Components }
{ ZLIB Data Compression Interface Unit }
{ }
{ Copyright (c) 1997 Borland International }
{ Copyright (c) 1998 Jacques Nomssi Nzali }
{ }
{*******************************************************}
{
Modified for
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
You can choose which pascal zlib implementation will be
used. IMPASZLIB and FPCPASZLIB are translations of zlib
to pascal so they don't need any *.obj files.
The others are interfaces to *.obj files (Windows) or
*.so libraries (Linux).
Default implementation is IMPASZLIB because it can be compiled
by all supported compilers and works on all supported platforms.
I usually use implementation with the fastest decompression
when building release Win32 binaries.
FPCPASZLIB is useful for Lazarus applications. FPC's zlib is linked
to exe by default so there is no need to link additional (and almost identical)
IMPASZLIB.
There is a small speed comparison table of some of the
supported implementations (TGA image 28 311 570 bytes, compression level = 6,
Delphi 9, Win32, Athlon XP 1900).
ZLib version Decompression Compression Comp. Size
IMPASZLIB | 1.1.2 | 824 ms | 4 280 ms | 18 760 133 B
ZLIBEX | 1.2.2 | 710 ms | 1 590 ms* | 19 056 621 B
DELPHIZLIB | 1.0.4 | 976 ms | 9 190 ms | 18 365 562 B
ZLIBPAS | 1.2.3 | 680 ms | 3 790 ms | 18 365 387 B
* obj files are compiled with compression level hardcoded to 1 (fastest)
}
unit dzlib;
{$I ImagingOptions.inc}
interface
{ $DEFINE ZLIBEX}
{ $DEFINE DELPHIZLIB}
{ $DEFINE ZLIBPAS}
{$DEFINE IMPASZLIB}
{ $DEFINE FPCPASZLIB}
{ Automatically use FPC's PasZLib when compiling with Lazarus.}
{$IFDEF LCL}
{$UNDEF IMPASZLIB}
{$DEFINE FPCPASZLIB}
{$ENDIF}
uses
{$IF Defined(ZLIBEX)}
{ Use ZlibEx unit.}
ZLibEx,
{$ELSEIF Defined(DELPHIZLIB)}
{ Use ZLib unit shipped with Delphi.}
ZLib,
{$ELSEIF Defined(ZLIBPAS)}
{ Pascal interface to ZLib shipped with ZLib C source.}
zlibpas,
{$ELSEIF Defined(IMPASZLIB)}
{ Use paszlib modified by me for Delphi and FPC.}
imzdeflate, imzinflate, impaszlib,
{$ELSEIF Defined(FPCPASZLIB)}
{ Use FPC's paszlib.}
zbase, paszlib,
{$IFEND}
SysUtils, Classes;
{$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)}
type
TZStreamRec = z_stream;
{$IFEND}
{$IFDEF ZLIBEX}
const
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_SYNC_FLUSH = 2;
Z_FULL_FLUSH = 3;
Z_FINISH = 4;
Z_OK = 0;
Z_STREAM_END = 1;
Z_NEED_DICT = 2;
Z_ERRNO = -1;
Z_STREAM_ERROR = -2;
Z_DATA_ERROR = -3;
Z_MEM_ERROR = -4;
Z_BUF_ERROR = -5;
Z_VERSION_ERROR = -6;
Z_NO_COMPRESSION = 0;
Z_BEST_SPEED = 1;
Z_BEST_COMPRESSION = 9;
Z_DEFAULT_COMPRESSION = -1;
Z_FILTERED = 1;
Z_HUFFMAN_ONLY = 2;
Z_RLE = 3;
Z_DEFAULT_STRATEGY = 0;
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
{$ENDIF}
type
{ Abstract ancestor class }
TCustomZlibStream = class(TStream)
private
FStrm: TStream;
FStrmPos: Integer;
FOnProgress: TNotifyEvent;
FZRec: TZStreamRec;
FBuffer: array [Word] of Char;
protected
procedure Progress(Sender: TObject); dynamic;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
constructor Create(Strm: TStream);
end;
{ TCompressionStream compresses data on the fly as data is written to it, and
stores the compressed data to another stream.
TCompressionStream is write-only and strictly sequential. Reading from the
stream will raise an exception. Using Seek to move the stream pointer
will raise an exception.
Output data is cached internally, written to the output stream only when
the internal output buffer is full. All pending output data is flushed
when the stream is destroyed.
The Position property returns the number of uncompressed bytes of
data that have been written to the stream so far.
CompressionRate returns the on-the-fly percentage by which the original
data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100
If raw data size = 100 and compressed data size = 25, the CompressionRate
is 75%
The OnProgress event is called each time the output buffer is filled and
written to the output stream. This is useful for updating a progress
indicator when you are writing a large chunk of data to the compression
stream in a single call.}
TCompressionLevel = (clNone, clFastest, clDefault, clMax);
TCompressionStream = class(TCustomZlibStream)
private
function GetCompressionRate: Single;
public
constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
property CompressionRate: Single read GetCompressionRate;
property OnProgress;
end;
{ TDecompressionStream decompresses data on the fly as data is read from it.
Compressed data comes from a separate source stream. TDecompressionStream
is read-only and unidirectional; you can seek forward in the stream, but not
backwards. The special case of setting the stream position to zero is
allowed. Seeking forward decompresses data until the requested position in
the uncompressed data has been reached. Seeking backwards, seeking relative
to the end of the stream, requesting the size of the stream, and writing to
the stream will raise an exception.
The Position property returns the number of bytes of uncompressed data that
have been read from the stream so far.
The OnProgress event is called each time the internal input buffer of
compressed data is exhausted and the next block is read from the input stream.
This is useful for updating a progress indicator when you are reading a
large chunk of data from the decompression stream in a single call.}
TDecompressionStream = class(TCustomZlibStream)
public
constructor Create(Source: TStream);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
property OnProgress;
end;
{ CompressBuf compresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer;
CompressLevel: Integer = Z_DEFAULT_COMPRESSION);
{ DecompressBuf decompresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
OutEstimate = zero, or est. size of the decompressed data
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
type
EZlibError = class(Exception);
ECompressionError = class(EZlibError);
EDecompressionError = class(EZlibError);
implementation
const
ZErrorMessages: array[0..9] of PChar = (
'need dictionary', // Z_NEED_DICT (2)
'stream end', // Z_STREAM_END (1)
'', // Z_OK (0)
'file error', // Z_ERRNO (-1)
'stream error', // Z_STREAM_ERROR (-2)
'data error', // Z_DATA_ERROR (-3)
'insufficient memory', // Z_MEM_ERROR (-4)
'buffer error', // Z_BUF_ERROR (-5)
'incompatible version', // Z_VERSION_ERROR (-6)
'');
function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer;
begin
GetMem(Result, Items*Size);
end;
procedure zlibFreeMem(AppData, Block: Pointer);
begin
FreeMem(Block);
end;
function CCheck(code: Integer): Integer;
begin
Result := code;
if code < 0 then
raise ECompressionError.Create('zlib: ' + ZErrorMessages[2 - code]);
end;
function DCheck(code: Integer): Integer;
begin
Result := code;
if code < 0 then
raise EDecompressionError.Create('zlib: ' + ZErrorMessages[2 - code]);
end;
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer;
CompressLevel: Integer);
var
strm: TZStreamRec;
P: Pointer;
begin
FillChar(strm, sizeof(strm), 0);
{$IFNDEF FPCPASZLIB}
strm.zalloc := @zlibAllocMem;
strm.zfree := @zlibFreeMem;
{$ENDIF}
OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
CCheck(deflateInit_(strm, CompressLevel, zlib_version, sizeof(strm)));
try
while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, 256);
ReallocMem(OutBuf, OutBytes);
strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.avail_out := 256;
end;
finally
CCheck(deflateEnd(strm));
end;
ReallocMem(OutBuf, strm.total_out);
OutBytes := strm.total_out;
except
zlibFreeMem(nil, OutBuf);
raise
end;
end;
procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer);
var
strm: TZStreamRec;
P: Pointer;
BufInc: Integer;
begin
FillChar(strm, sizeof(strm), 0);
{$IFNDEF FPCPASZLIB}
strm.zalloc := @zlibAllocMem;
strm.zfree := @zlibFreeMem;
{$ENDIF}
BufInc := (InBytes + 255) and not 255;
if OutEstimate = 0 then
OutBytes := BufInc
else
OutBytes := OutEstimate;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
try
while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.avail_out := BufInc;
end;
finally
DCheck(inflateEnd(strm));
end;
ReallocMem(OutBuf, strm.total_out);
OutBytes := strm.total_out;
except
zlibFreeMem(nil, OutBuf);
raise
end;
end;
{ TCustomZlibStream }
constructor TCustomZLibStream.Create(Strm: TStream);
begin
inherited Create;
FStrm := Strm;
FStrmPos := Strm.Position;
{$IFNDEF FPCPASZLIB}
FZRec.zalloc := @zlibAllocMem;
FZRec.zfree := @zlibFreeMem;
{$ENDIF}
end;
procedure TCustomZLibStream.Progress(Sender: TObject);
begin
if Assigned(FOnProgress) then FOnProgress(Sender);
end;
{ TCompressionStream }
constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel;
Dest: TStream);
const
Levels: array [TCompressionLevel] of ShortInt =
(Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
begin
inherited Create(Dest);
FZRec.next_out := @FBuffer;
FZRec.avail_out := sizeof(FBuffer);
CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec)));
end;
destructor TCompressionStream.Destroy;
begin
FZRec.next_in := nil;
FZRec.avail_in := 0;
try
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
and (FZRec.avail_out = 0) do
begin
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
FZRec.next_out := @FBuffer;
FZRec.avail_out := sizeof(FBuffer);
end;
if FZRec.avail_out < sizeof(FBuffer) then
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out);
finally
deflateEnd(FZRec);
end;
inherited Destroy;
end;
function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
raise ECompressionError.Create('Invalid stream operation');
end;
function TCompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
FZRec.next_in := @Buffer;
FZRec.avail_in := Count;
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (FZRec.avail_in > 0) do
begin
CCheck(deflate(FZRec, 0));
if FZRec.avail_out = 0 then
begin
FStrm.WriteBuffer(FBuffer, sizeof(FBuffer));
FZRec.next_out := @FBuffer;
FZRec.avail_out := sizeof(FBuffer);
FStrmPos := FStrm.Position;
Progress(Self);
end;
end;
Result := Count;
end;
function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
if (Offset = 0) and (Origin = soFromCurrent) then
Result := FZRec.total_in
else
raise ECompressionError.Create('Invalid stream operation');
end;
function TCompressionStream.GetCompressionRate: Single;
begin
if FZRec.total_in = 0 then
Result := 0
else
Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
end;
{ TDecompressionStream }
constructor TDecompressionStream.Create(Source: TStream);
begin
inherited Create(Source);
FZRec.next_in := @FBuffer;
FZRec.avail_in := 0;
DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
end;
destructor TDecompressionStream.Destroy;
begin
inflateEnd(FZRec);
inherited Destroy;
end;
function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
FZRec.next_out := @Buffer;
FZRec.avail_out := Count;
if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (FZRec.avail_out > 0) do
begin
if FZRec.avail_in = 0 then
begin
FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
if FZRec.avail_in = 0 then
begin
Result := Count - Integer(FZRec.avail_out);
Exit;
end;
FZRec.next_in := @FBuffer;
FStrmPos := FStrm.Position;
Progress(Self);
end;
CCheck(inflate(FZRec, 0));
end;
Result := Count;
end;
function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
raise EDecompressionError.Create('Invalid stream operation');
end;
function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
var
I: Integer;
Buf: array [0..4095] of Char;
begin
if (Offset = 0) and (Origin = soFromBeginning) then
begin
DCheck(inflateReset(FZRec));
FZRec.next_in := @FBuffer;
FZRec.avail_in := 0;
FStrm.Position := 0;
FStrmPos := 0;
end
else if ( (Offset >= 0) and (Origin = soFromCurrent)) or
( ((Offset - Integer(FZRec.total_out)) > 0) and (Origin = soFromBeginning)) then
begin
if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
if Offset > 0 then
begin
for I := 1 to Offset div sizeof(Buf) do
ReadBuffer(Buf, sizeof(Buf));
ReadBuffer(Buf, Offset mod sizeof(Buf));
end;
end
else
raise EDecompressionError.Create('Invalid stream operation');
Result := FZRec.total_out;
end;
end.

114
Imaging/ZLib/imadler.pas Normal file
View File

@@ -0,0 +1,114 @@
Unit imadler;
{
adler32.c -- compute the Adler-32 checksum of a data stream
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil;
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
return the updated checksum. If buf is NIL, this function returns
the required initial value for the checksum.
An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
much faster. Usage example:
var
adler : uLong;
begin
adler := adler32(0, Z_NULL, 0);
while (read_buffer(buffer, length) <> EOF) do
adler := adler32(adler, buffer, length);
if (adler <> original_adler) then
error();
end;
}
implementation
const
BASE = uLong(65521); { largest prime smaller than 65536 }
{NMAX = 5552; original code with unsigned 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 }
NMAX = 3854; { code with signed 32 bit integer }
{ NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 }
{ The penalty is the time loss in the extra MOD-calls. }
{ ========================================================================= }
function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong;
var
s1, s2 : uLong;
k : int;
begin
s1 := adler and $ffff;
s2 := (adler shr 16) and $ffff;
if not Assigned(buf) then
begin
adler32 := uLong(1);
exit;
end;
while (len > 0) do
begin
if len < NMAX then
k := len
else
k := NMAX;
Dec(len, k);
{
while (k >= 16) do
begin
DO16(buf);
Inc(buf, 16);
Dec(k, 16);
end;
if (k <> 0) then
repeat
Inc(s1, buf^);
Inc(puf);
Inc(s2, s1);
Dec(k);
until (k = 0);
}
while (k > 0) do
begin
Inc(s1, buf^);
Inc(s2, s1);
Inc(buf);
Dec(k);
end;
s1 := s1 mod BASE;
s2 := s2 mod BASE;
end;
adler32 := (s2 shl 16) or s1;
end;
{
#define DO1(buf,i)
begin
Inc(s1, buf[i]);
Inc(s2, s1);
end;
#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
#define DO16(buf) DO8(buf,0); DO8(buf,8);
}
end.

951
Imaging/ZLib/iminfblock.pas Normal file
View File

@@ -0,0 +1,951 @@
Unit iminfblock;
{ infblock.h and
infblock.c -- interpret and process block types to last block
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
{$IFDEF DEBUG}
SysUtils, strutils,
{$ENDIF}
imzutil, impaszlib;
function inflate_blocks_new(var z : z_stream;
c : check_func; { check function }
w : uInt { window size }
) : pInflate_blocks_state;
function inflate_blocks (var s : inflate_blocks_state;
var z : z_stream;
r : int { initial return code }
) : int;
procedure inflate_blocks_reset (var s : inflate_blocks_state;
var z : z_stream;
c : puLong); { check value on output }
function inflate_blocks_free(s : pInflate_blocks_state;
var z : z_stream) : int;
procedure inflate_set_dictionary(var s : inflate_blocks_state;
const d : array of byte; { dictionary }
n : uInt); { dictionary length }
function inflate_blocks_sync_point(var s : inflate_blocks_state) : int;
implementation
uses
iminfcodes, iminftrees, iminfutil;
{ Tables for deflate from PKZIP's appnote.txt. }
Const
border : Array [0..18] Of Word { Order of the bit length code lengths }
= (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
{ Notes beyond the 1.93a appnote.txt:
1. Distance pointers never point before the beginning of the output
stream.
2. Distance pointers can point back across blocks, up to 32k away.
3. There is an implied maximum of 7 bits for the bit length table and
15 bits for the actual data.
4. If only one code exists, then it is encoded using one bit. (Zero
would be more efficient, but perhaps a little confusing.) If two
codes exist, they are coded using one bit each (0 and 1).
5. There is no way of sending zero distance codes--a dummy must be
sent if there are none. (History: a pre 2.0 version of PKZIP would
store blocks with no distance codes, but this was discovered to be
too harsh a criterion.) Valid only for 1.93a. 2.04c does allow
zero distance codes, which is sent as one code of zero bits in
length.
6. There are up to 286 literal/length codes. Code 256 represents the
end-of-block. Note however that the static length tree defines
288 codes just to fill out the Huffman codes. Codes 286 and 287
cannot be used though, since there is no length base or extra bits
defined for them. Similarily, there are up to 30 distance codes.
However, static trees define 32 codes (all 5 bits) to fill out the
Huffman codes, but the last two had better not show up in the data.
7. Unzip can check dynamic Huffman blocks for complete code sets.
The exception is that a single code would not be complete (see #4).
8. The five bits following the block type is really the number of
literal codes sent minus 257.
9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits
(1+6+6). Therefore, to output three times the length, you output
three codes (1+1+1), whereas to output four times the same length,
you only need two codes (1+3). Hmm.
10. In the tree reconstruction algorithm, Code = Code + Increment
only if BitLength(i) is not zero. (Pretty obvious.)
11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19)
12. Note: length code 284 can represent 227-258, but length code 285
really is 258. The last length deserves its own, short code
since it gets used a lot in very redundant files. The length
258 is special since 258 - 3 (the min match length) is 255.
13. The literal/length and distance code bit lengths are read as a
single stream of lengths. It is possible (and advantageous) for
a repeat code (16, 17, or 18) to go across the boundary between
the two sets of lengths. }
procedure inflate_blocks_reset (var s : inflate_blocks_state;
var z : z_stream;
c : puLong); { check value on output }
begin
if (c <> Z_NULL) then
c^ := s.check;
if (s.mode = BTREE) or (s.mode = DTREE) then
ZFREE(z, s.sub.trees.blens);
if (s.mode = CODES) then
inflate_codes_free(s.sub.decode.codes, z);
s.mode := ZTYPE;
s.bitk := 0;
s.bitb := 0;
s.write := s.window;
s.read := s.window;
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(uLong(0), pBytef(NIL), 0);
z.adler := s.check;
end;
{$IFDEF DEBUG}
Tracev('inflate: blocks reset');
{$ENDIF}
end;
function inflate_blocks_new(var z : z_stream;
c : check_func; { check function }
w : uInt { window size }
) : pInflate_blocks_state;
var
s : pInflate_blocks_state;
begin
s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) );
if (s = Z_NULL) then
begin
inflate_blocks_new := s;
exit;
end;
s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) );
if (s^.hufts = Z_NULL) then
begin
ZFREE(z, s);
inflate_blocks_new := Z_NULL;
exit;
end;
s^.window := pBytef( ZALLOC(z, 1, w) );
if (s^.window = Z_NULL) then
begin
ZFREE(z, s^.hufts);
ZFREE(z, s);
inflate_blocks_new := Z_NULL;
exit;
end;
s^.zend := s^.window;
Inc(s^.zend, w);
s^.checkfn := c;
s^.mode := ZTYPE;
{$IFDEF DEBUG}
Tracev('inflate: blocks allocated');
{$ENDIF}
inflate_blocks_reset(s^, z, Z_NULL);
inflate_blocks_new := s;
end;
function inflate_blocks (var s : inflate_blocks_state;
var z : z_stream;
r : int) : int; { initial return code }
label
start_btree, start_dtree,
start_blkdone, start_dry,
start_codes;
var
t : uInt; { temporary storage }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
{ fixed code blocks }
var
bl, bd : uInt;
tl, td : pInflate_huft;
var
h : pInflate_huft;
i, j, c : uInt;
var
cs : pInflate_codes_state;
begin
{ copy input/output information to locals }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ decompress an inflated block }
{ process input based on current state }
while True do
Case s.mode of
ZTYPE:
begin
{NEEDBITS(3);}
while (k < 3) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := uInt(b) and 7;
s.last := boolean(t and 1);
case (t shr 1) of
0: { stored }
begin
{$IFDEF DEBUG}
if s.last then
Tracev('inflate: stored block (last)')
else
Tracev('inflate: stored block');
{$ENDIF}
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
t := k and 7; { go to byte boundary }
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
s.mode := LENS; { get length of stored block }
end;
1: { fixed }
begin
begin
{$IFDEF DEBUG}
if s.last then
Tracev('inflate: fixed codes blocks (last)')
else
Tracev('inflate: fixed codes blocks');
{$ENDIF}
inflate_trees_fixed(bl, bd, tl, td, z);
s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z);
if (s.sub.decode.codes = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := CODES;
end;
2: { dynamic }
begin
{$IFDEF DEBUG}
if s.last then
Tracev('inflate: dynamic codes block (last)')
else
Tracev('inflate: dynamic codes block');
{$ENDIF}
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := TABLE;
end;
3:
begin { illegal }
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
s.mode := BLKBAD;
z.msg := 'invalid block type';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
end;
LENS:
begin
{NEEDBITS(32);}
while (k < 32) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
if (((not b) shr 16) and $ffff) <> (b and $ffff) then
begin
s.mode := BLKBAD;
z.msg := 'invalid stored block lengths';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.left := uInt(b) and $ffff;
k := 0;
b := 0; { dump bits }
{$IFDEF DEBUG}
Tracev('inflate: stored length '+IntToStr(s.sub.left));
{$ENDIF}
if s.sub.left <> 0 then
s.mode := STORED
else
if s.last then
s.mode := DRY
else
s.mode := ZTYPE;
end;
STORED:
begin
if (n = 0) then
begin
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
t := s.sub.left;
if (t > n) then
t := n;
if (t > m) then
t := m;
zmemcpy(q, p, t);
Inc(p, t); Dec(n, t);
Inc(q, t); Dec(m, t);
Dec(s.sub.left, t);
if (s.sub.left = 0) then
begin
{$IFDEF DEBUG}
if (ptr2int(q) >= ptr2int(s.read)) then
Tracev('inflate: stored end '+
IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out')
else
Tracev('inflate: stored end '+
IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) +
ptr2int(q) - ptr2int(s.window)) + ' total out');
{$ENDIF}
if s.last then
s.mode := DRY
else
s.mode := ZTYPE;
end;
end;
TABLE:
begin
{NEEDBITS(14);}
while (k < 14) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := uInt(b) and $3fff;
s.sub.trees.table := t;
{$ifndef PKZIP_BUG_WORKAROUND}
if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then
begin
s.mode := BLKBAD;
z.msg := 'too many length or distance symbols';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{$endif}
t := 258 + (t and $1f) + ((t shr 5) and $1f);
s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) );
if (s.sub.trees.blens = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{DUMPBITS(14);}
b := b shr 14;
Dec(k, 14);
s.sub.trees.index := 0;
{$IFDEF DEBUG}
Tracev('inflate: table sizes ok');
{$ENDIF}
s.mode := BTREE;
{ fall trough case is handled by the while }
{ try GOTO for speed - Nomssi }
goto start_btree;
end;
BTREE:
begin
start_btree:
while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do
begin
{NEEDBITS(3);}
while (k < 3) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7;
Inc(s.sub.trees.index);
{DUMPBITS(3);}
b := b shr 3;
Dec(k, 3);
end;
while (s.sub.trees.index < 19) do
begin
s.sub.trees.blens^[border[s.sub.trees.index]] := 0;
Inc(s.sub.trees.index);
end;
s.sub.trees.bb := 7;
t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb,
s.sub.trees.tb, s.hufts^, z);
if (t <> Z_OK) then
begin
ZFREE(z, s.sub.trees.blens);
r := t;
if (r = Z_DATA_ERROR) then
s.mode := BLKBAD;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.trees.index := 0;
{$IFDEF DEBUG}
Tracev('inflate: bits tree ok');
{$ENDIF}
s.mode := DTREE;
{ fall through again }
goto start_dtree;
end;
DTREE:
begin
start_dtree:
while TRUE do
begin
t := s.sub.trees.table;
if not (s.sub.trees.index < 258 +
(t and $1f) + ((t shr 5) and $1f)) then
break;
t := s.sub.trees.bb;
{NEEDBITS(t);}
while (k < t) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
h := s.sub.trees.tb;
Inc(h, uInt(b) and inflate_mask[t]);
t := h^.Bits;
c := h^.Base;
if (c < 16) then
begin
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
s.sub.trees.blens^[s.sub.trees.index] := c;
Inc(s.sub.trees.index);
end
else { c = 16..18 }
begin
if c = 18 then
begin
i := 7;
j := 11;
end
else
begin
i := c - 14;
j := 3;
end;
{NEEDBITS(t + i);}
while (k < t + i) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
{DUMPBITS(t);}
b := b shr t;
Dec(k, t);
Inc(j, uInt(b) and inflate_mask[i]);
{DUMPBITS(i);}
b := b shr i;
Dec(k, i);
i := s.sub.trees.index;
t := s.sub.trees.table;
if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or
((c = 16) and (i < 1)) then
begin
ZFREE(z, s.sub.trees.blens);
s.mode := BLKBAD;
z.msg := 'invalid bit length repeat';
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
if c = 16 then
c := s.sub.trees.blens^[i - 1]
else
c := 0;
repeat
s.sub.trees.blens^[i] := c;
Inc(i);
Dec(j);
until (j=0);
s.sub.trees.index := i;
end;
end; { while }
s.sub.trees.tb := Z_NULL;
begin
bl := 9; { must be <= 9 for lookahead assumptions }
bd := 6; { must be <= 9 for lookahead assumptions }
t := s.sub.trees.table;
t := inflate_trees_dynamic(257 + (t and $1f),
1 + ((t shr 5) and $1f),
s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z);
ZFREE(z, s.sub.trees.blens);
if (t <> Z_OK) then
begin
if (t = uInt(Z_DATA_ERROR)) then
s.mode := BLKBAD;
r := t;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
{$IFDEF DEBUG}
Tracev('inflate: trees ok');
{$ENDIF}
{ c renamed to cs }
cs := inflate_codes_new(bl, bd, tl, td, z);
if (cs = Z_NULL) then
begin
r := Z_MEM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.sub.decode.codes := cs;
end;
s.mode := CODES;
{ yet another falltrough }
goto start_codes;
end;
CODES:
begin
start_codes:
{ update pointers }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
r := inflate_codes(s, z, r);
if (r <> Z_STREAM_END) then
begin
inflate_blocks := inflate_flush(s, z, r);
exit;
end;
r := Z_OK;
inflate_codes_free(s.sub.decode.codes, z);
{ load local pointers }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{$IFDEF DEBUG}
if (ptr2int(q) >= ptr2int(s.read)) then
Tracev('inflate: codes end '+
IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out')
else
Tracev('inflate: codes end '+
IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) +
ptr2int(q) - ptr2int(s.window)) + ' total out');
{$ENDIF}
if (not s.last) then
begin
s.mode := ZTYPE;
continue; { break for switch statement in C-code }
end;
{$ifndef patch112}
if (k > 7) then { return unused byte, if any }
begin
{$IFDEF DEBUG}
Assert(k < 16, 'inflate_codes grabbed too many bytes');
{$ENDIF}
Dec(k, 8);
Inc(n);
Dec(p); { can always return one }
end;
{$endif}
s.mode := DRY;
{ another falltrough }
goto start_dry;
end;
DRY:
begin
start_dry:
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
{ not needed anymore, we are done:
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
}
if (s.read <> s.write) then
begin
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
s.mode := BLKDONE;
goto start_blkdone;
end;
BLKDONE:
begin
start_blkdone:
r := Z_STREAM_END;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
BLKBAD:
begin
r := Z_DATA_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
else
begin
r := Z_STREAM_ERROR;
{ update pointers and return }
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_blocks := inflate_flush(s,z,r);
exit;
end;
end; { Case s.mode of }
end;
function inflate_blocks_free(s : pInflate_blocks_state;
var z : z_stream) : int;
begin
inflate_blocks_reset(s^, z, Z_NULL);
ZFREE(z, s^.window);
ZFREE(z, s^.hufts);
ZFREE(z, s);
{$IFDEF DEBUG}
Trace('inflate: blocks freed');
{$ENDIF}
inflate_blocks_free := Z_OK;
end;
procedure inflate_set_dictionary(var s : inflate_blocks_state;
const d : array of byte; { dictionary }
n : uInt); { dictionary length }
begin
zmemcpy(s.window, pBytef(@d), n);
s.write := s.window;
Inc(s.write, n);
s.read := s.write;
end;
{ Returns true if inflate is currently at the end of a block generated
by Z_SYNC_FLUSH or Z_FULL_FLUSH.
IN assertion: s <> Z_NULL }
function inflate_blocks_sync_point(var s : inflate_blocks_state) : int;
begin
inflate_blocks_sync_point := int(s.mode = LENS);
end;
end.

576
Imaging/ZLib/iminfcodes.pas Normal file
View File

@@ -0,0 +1,576 @@
Unit iminfcodes;
{ infcodes.c -- process literals and length/distance pairs
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
{$IFDEF DEBUG}
SysUtils, strutils,
{$ENDIF}
imzutil, impaszlib;
function inflate_codes_new (bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var z : z_stream): pInflate_codes_state;
function inflate_codes(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
procedure inflate_codes_free(c : pInflate_codes_state;
var z : z_stream);
implementation
uses
iminfutil, iminffast;
function inflate_codes_new (bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var z : z_stream): pInflate_codes_state;
var
c : pInflate_codes_state;
begin
c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) );
if (c <> Z_NULL) then
begin
c^.mode := START;
c^.lbits := Byte(bl);
c^.dbits := Byte(bd);
c^.ltree := tl;
c^.dtree := td;
{$IFDEF DEBUG}
Tracev('inflate: codes new');
{$ENDIF}
end;
inflate_codes_new := c;
end;
function inflate_codes(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
j : uInt; { temporary storage }
t : pInflate_huft; { temporary pointer }
e : uInt; { extra bits or operation }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
f : pBytef; { pointer to copy strings from }
var
c : pInflate_codes_state;
begin
c := s.sub.decode.codes; { codes state }
{ copy input/output information to locals }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ process input and output based on current state }
while True do
case (c^.mode) of
{ waiting for "i:"=input, "o:"=output, "x:"=nothing }
START: { x: set up for LEN }
begin
{$ifndef SLOW}
if (m >= 258) and (n >= 10) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z);
{LOAD}
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
if (r <> Z_OK) then
begin
if (r = Z_STREAM_END) then
c^.mode := WASH
else
c^.mode := BADCODE;
continue; { break for switch-statement in C }
end;
end;
{$endif} { not SLOW }
c^.sub.code.need := c^.lbits;
c^.sub.code.tree := c^.ltree;
c^.mode := LEN; { falltrough }
end;
LEN: { i: get length/literal/eob next }
begin
j := c^.sub.code.need;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := c^.sub.code.tree;
Inc(t, uInt(b) and inflate_mask[j]);
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
e := uInt(t^.exop);
if (e = 0) then { literal }
begin
c^.sub.lit := t^.base;
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: literal '+char(t^.base))
else
Tracevv('inflate: literal '+IntToStr(t^.base));
{$ENDIF}
c^.mode := LIT;
continue; { break switch statement }
end;
if (e and 16 <> 0) then { length }
begin
c^.sub.copy.get := e and 15;
c^.len := t^.base;
c^.mode := LENEXT;
continue; { break C-switch statement }
end;
if (e and 64 = 0) then { next table }
begin
c^.sub.code.need := e;
c^.sub.code.tree := @huft_ptr(t)^[t^.base];
continue; { break C-switch statement }
end;
if (e and 32 <> 0) then { end of block }
begin
{$IFDEF DEBUG}
Tracevv('inflate: end of block');
{$ENDIF}
c^.mode := WASH;
continue; { break C-switch statement }
end;
c^.mode := BADCODE; { invalid code }
z.msg := 'invalid literal/length code';
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
LENEXT: { i: getting length extra (have base) }
begin
j := c^.sub.copy.get;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
Inc(c^.len, uInt(b and inflate_mask[j]));
{DUMPBITS(j);}
b := b shr j;
Dec(k, j);
c^.sub.code.need := c^.dbits;
c^.sub.code.tree := c^.dtree;
{$IFDEF DEBUG}
Tracevv('inflate: length '+IntToStr(c^.len));
{$ENDIF}
c^.mode := DIST;
{ falltrough }
end;
DIST: { i: get distance next }
begin
j := c^.sub.code.need;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]];
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
e := uInt(t^.exop);
if (e and 16 <> 0) then { distance }
begin
c^.sub.copy.get := e and 15;
c^.sub.copy.dist := t^.base;
c^.mode := DISTEXT;
continue; { break C-switch statement }
end;
if (e and 64 = 0) then { next table }
begin
c^.sub.code.need := e;
c^.sub.code.tree := @huft_ptr(t)^[t^.base];
continue; { break C-switch statement }
end;
c^.mode := BADCODE; { invalid code }
z.msg := 'invalid distance code';
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
DISTEXT: { i: getting distance extra }
begin
j := c^.sub.copy.get;
{NEEDBITS(j);}
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]);
{DUMPBITS(j);}
b := b shr j;
Dec(k, j);
{$IFDEF DEBUG}
Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist));
{$ENDIF}
c^.mode := COPY;
{ falltrough }
end;
COPY: { o: copying bytes in window, waiting for space }
begin
f := q;
Dec(f, c^.sub.copy.dist);
if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then
begin
f := s.zend;
Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window)));
end;
while (c^.len <> 0) do
begin
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
{OUTBYTE( *f++)}
q^ := f^;
Inc(q);
Inc(f);
Dec(m);
if (f = s.zend) then
f := s.window;
Dec(c^.len);
end;
c^.mode := START;
{ C-switch break; not needed }
end;
LIT: { o: got literal, waiting for output space }
begin
{NEEDOUT}
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
{OUTBYTE(c^.sub.lit);}
q^ := c^.sub.lit;
Inc(q);
Dec(m);
c^.mode := START;
{break;}
end;
WASH: { o: got eob, possibly more output }
begin
{$ifdef patch112}
if (k > 7) then { return unused byte, if any }
begin
{$IFDEF DEBUG}
Assert(k < 16, 'inflate_codes grabbed too many bytes');
{$ENDIF}
Dec(k, 8);
Inc(n);
Dec(p); { can always return one }
end;
{$endif}
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
if (s.read <> s.write) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
c^.mode := ZEND;
{ falltrough }
end;
ZEND:
begin
r := Z_STREAM_END;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
BADCODE: { x: got error }
begin
r := Z_DATA_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
else
begin
r := Z_STREAM_ERROR;
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_codes := inflate_flush(s,z,r);
exit;
end;
end;
{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this }
inflate_codes := Z_STREAM_ERROR;
end;
procedure inflate_codes_free(c : pInflate_codes_state;
var z : z_stream);
begin
ZFREE(z, c);
{$IFDEF DEBUG}
Tracev('inflate: codes free');
{$ENDIF}
end;
end.

318
Imaging/ZLib/iminffast.pas Normal file
View File

@@ -0,0 +1,318 @@
Unit iminffast;
{
inffast.h and
inffast.c -- process literals and length/distance pairs fast
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
{$ifdef DEBUG}
SysUtils, strutils,
{$ENDIF}
imzutil, impaszlib;
function inflate_fast( bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var s : inflate_blocks_state;
var z : z_stream) : int;
implementation
uses
iminfutil;
{ Called with number of bytes left to write in window at least 258
(the maximum string length) and number of input bytes available
at least ten. The ten bytes are six bytes for the longest length/
distance pair plus four bytes for overloading the bit buffer. }
function inflate_fast( bl : uInt;
bd : uInt;
tl : pInflate_huft;
td : pInflate_huft;
var s : inflate_blocks_state;
var z : z_stream) : int;
var
t : pInflate_huft; { temporary pointer }
e : uInt; { extra bits or operation }
b : uLong; { bit buffer }
k : uInt; { bits in bit buffer }
p : pBytef; { input data pointer }
n : uInt; { bytes available there }
q : pBytef; { output window write pointer }
m : uInt; { bytes to end of window or read pointer }
ml : uInt; { mask for literal/length tree }
md : uInt; { mask for distance tree }
c : uInt; { bytes to copy }
d : uInt; { distance back to copy from }
r : pBytef; { copy source pointer }
begin
{ load input, output, bit values (macro LOAD) }
p := z.next_in;
n := z.avail_in;
b := s.bitb;
k := s.bitk;
q := s.write;
if ptr2int(q) < ptr2int(s.read) then
m := uInt(ptr2int(s.read)-ptr2int(q)-1)
else
m := uInt(ptr2int(s.zend)-ptr2int(q));
{ initialize masks }
ml := inflate_mask[bl];
md := inflate_mask[bd];
{ do until not enough input or output space for fast loop }
repeat { assume called with (m >= 258) and (n >= 10) }
{ get literal/length code }
{GRABBITS(20);} { max bits for literal/length code }
while (k < 20) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @(huft_ptr(tl)^[uInt(b) and ml]);
e := t^.exop;
if (e = 0) then
begin
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
else
Tracevv('inflate: * literal '+ IntToStr(t^.base));
{$ENDIF}
q^ := Byte(t^.base);
Inc(q);
Dec(m);
continue;
end;
repeat
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
if (e and 16 <> 0) then
begin
{ get extra bits for length }
e := e and 15;
c := t^.base + (uInt(b) and inflate_mask[e]);
{DUMPBITS(e);}
b := b shr e;
Dec(k, e);
{$IFDEF DEBUG}
Tracevv('inflate: * length ' + IntToStr(c));
{$ENDIF}
{ decode distance base of block to copy }
{GRABBITS(15);} { max bits for distance code }
while (k < 15) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
t := @huft_ptr(td)^[uInt(b) and md];
e := t^.exop;
repeat
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
if (e and 16 <> 0) then
begin
{ get extra bits to add to distance base }
e := e and 15;
{GRABBITS(e);} { get extra bits (up to 13) }
while (k < e) do
begin
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
d := t^.base + (uInt(b) and inflate_mask[e]);
{DUMPBITS(e);}
b := b shr e;
Dec(k, e);
{$IFDEF DEBUG}
Tracevv('inflate: * distance '+IntToStr(d));
{$ENDIF}
{ do the copy }
Dec(m, c);
if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest }
begin { just copy }
r := q;
Dec(r, d);
q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, }
q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little }
end
else { else offset after destination }
begin
e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end }
r := s.zend;
Dec(r, e); { pointer to offset }
if (c > e) then { if source crosses, }
begin
Dec(c, e); { copy to end of window }
repeat
q^ := r^;
Inc(q);
Inc(r);
Dec(e);
until (e=0);
r := s.window; { copy rest from start of window }
end;
end;
repeat { copy all or what's left }
q^ := r^;
Inc(q);
Inc(r);
Dec(c);
until (c = 0);
break;
end
else
if (e and 64 = 0) then
begin
Inc(t, t^.base + (uInt(b) and inflate_mask[e]));
e := t^.exop;
end
else
begin
z.msg := 'invalid distance code';
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_DATA_ERROR;
exit;
end;
until FALSE;
break;
end;
if (e and 64 = 0) then
begin
{t += t->base;
e = (t += ((uInt)b & inflate_mask[e]))->exop;}
Inc(t, t^.base + (uInt(b) and inflate_mask[e]));
e := t^.exop;
if (e = 0) then
begin
{DUMPBITS(t^.bits);}
b := b shr t^.bits;
Dec(k, t^.bits);
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
else
Tracevv('inflate: * literal '+IntToStr(t^.base));
{$ENDIF}
q^ := Byte(t^.base);
Inc(q);
Dec(m);
break;
end;
end
else
if (e and 32 <> 0) then
begin
{$IFDEF DEBUG}
Tracevv('inflate: * end of block');
{$ENDIF}
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_STREAM_END;
exit;
end
else
begin
z.msg := 'invalid literal/length code';
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_DATA_ERROR;
exit;
end;
until FALSE;
until (m < 258) or (n < 10);
{ not enough input or output--restore pointers and return }
{UNGRAB}
c := z.avail_in-n;
if (k shr 3) < c then
c := k shr 3;
Inc(n, c);
Dec(p, c);
Dec(k, c shl 3);
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in));
z.next_in := p;
s.write := q;
inflate_fast := Z_OK;
end;
end.

781
Imaging/ZLib/iminftrees.pas Normal file
View File

@@ -0,0 +1,781 @@
Unit iminftrees;
{ inftrees.h -- header to use inftrees.c
inftrees.c -- generate Huffman trees for efficient decoding
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
Interface
{$I imzconf.inc}
uses
imzutil, impaszlib;
{ Maximum size of dynamic tree. The maximum found in a long but non-
exhaustive search was 1004 huft structures (850 for length/literals
and 154 for distances, the latter actually the result of an
exhaustive search). The actual maximum is not known, but the
value below is more than safe. }
const
MANY = 1440;
{$ifdef DEBUG}
var
inflate_hufts : uInt;
{$endif}
function inflate_trees_bits(
var c : array of uIntf; { 19 code lengths }
var bb : uIntf; { bits tree desired/actual depth }
var tb : pinflate_huft; { bits tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
function inflate_trees_dynamic(
nl : uInt; { number of literal/length codes }
nd : uInt; { number of distance codes }
var c : Array of uIntf; { that many (total) code lengths }
var bl : uIntf; { literal desired/actual bit depth }
var bd : uIntf; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
function inflate_trees_fixed (
var bl : uInt; { literal desired/actual bit depth }
var bd : uInt; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var z : z_stream { for memory allocation }
) : int;
implementation
const
inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler';
{
If you use the zlib library in a product, an acknowledgment is welcome
in the documentation of your product. If for some reason you cannot
include such an acknowledgment, I would appreciate that you keep this
copyright string in the executable of your product.
}
const
{ Tables for deflate from PKZIP's appnote.txt. }
cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 }
= (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0);
{ actually lengths - 2; also see note #13 above about 258 }
invalid_code = 112;
cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 }
= (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code);
cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 }
= (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
8193, 12289, 16385, 24577);
cpdext : Array [0..29] Of uInt { Extra bits for distance codes }
= (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
7, 7, 8, 8, 9, 9, 10, 10, 11, 11,
12, 12, 13, 13);
{ Huffman code decoding is performed using a multi-level table lookup.
The fastest way to decode is to simply build a lookup table whose
size is determined by the longest code. However, the time it takes
to build this table can also be a factor if the data being decoded
is not very long. The most common codes are necessarily the
shortest codes, so those codes dominate the decoding time, and hence
the speed. The idea is you can have a shorter table that decodes the
shorter, more probable codes, and then point to subsidiary tables for
the longer codes. The time it costs to decode the longer codes is
then traded against the time it takes to make longer tables.
This results of this trade are in the variables lbits and dbits
below. lbits is the number of bits the first level table for literal/
length codes can decode in one step, and dbits is the same thing for
the distance codes. Subsequent tables are also less than or equal to
those sizes. These values may be adjusted either when all of the
codes are shorter than that, in which case the longest code length in
bits is used, or when the shortest code is *longer* than the requested
table size, in which case the length of the shortest code in bits is
used.
There are two different values for the two tables, since they code a
different number of possibilities each. The literal/length table
codes 286 possible values, or in a flat code, a little over eight
bits. The distance table codes 30 possible values, or a little less
than five bits, flat. The optimum values for speed end up being
about one bit more than those, so lbits is 8+1 and dbits is 5+1.
The optimum values may differ though from machine to machine, and
possibly even between compilers. Your mileage may vary. }
{ If BMAX needs to be larger than 16, then h and x[] should be uLong. }
const
BMAX = 15; { maximum bit length of any code }
{$DEFINE USE_PTR}
function huft_build(
var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) }
n : uInt; { number of codes (assumed <= N_MAX) }
s : uInt; { number of simple-valued codes (0..s-1) }
const d : array of uIntf; { list of base values for non-simple codes }
{ array of word }
const e : array of uIntf; { list of extra bits for non-simple codes }
{ array of byte }
t : ppInflate_huft; { result: starting table }
var m : uIntf; { maximum lookup bits, returns actual }
var hp : array of inflate_huft; { space for trees }
var hn : uInt; { hufts used in space }
var v : array of uIntf { working area: values in order of bit length }
) : int;
{ Given a list of code lengths and a maximum table size, make a set of
tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR
if the given code set is incomplete (the tables are still built in this
case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of
lengths), or Z_MEM_ERROR if not enough memory. }
Var
a : uInt; { counter for codes of length k }
c : Array [0..BMAX] Of uInt; { bit length count table }
f : uInt; { i repeats in table every f entries }
g : int; { maximum code length }
h : int; { table level }
i : uInt; {register} { counter, current code }
j : uInt; {register} { counter }
k : Int; {register} { number of bits in current code }
l : int; { bits per table (returned in m) }
mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP }
p : ^uIntf; {register} { pointer into c[], b[], or v[] }
q : pInflate_huft; { points to current table }
r : inflate_huft; { table entry for structure assignment }
u : Array [0..BMAX-1] Of pInflate_huft; { table stack }
w : int; {register} { bits before this table = (l*h) }
x : Array [0..BMAX] Of uInt; { bit offsets, then code stack }
{$IFDEF USE_PTR}
xp : puIntf; { pointer into x }
{$ELSE}
xp : uInt;
{$ENDIF}
y : int; { number of dummy codes added }
z : uInt; { number of entries in current table }
Begin
{ Generate counts for each bit length }
FillChar(c,SizeOf(c),0) ; { clear c[] }
for i := 0 to n-1 do
Inc (c[b[i]]); { assume all entries <= BMAX }
If (c[0] = n) Then { null input--all zero length codes }
Begin
t^ := pInflate_huft(NIL);
m := 0 ;
huft_build := Z_OK ;
Exit;
End ;
{ Find minimum and maximum length, bound [m] by those }
l := m;
for j:=1 To BMAX do
if (c[j] <> 0) then
break;
k := j ; { minimum code length }
if (uInt(l) < j) then
l := j;
for i := BMAX downto 1 do
if (c[i] <> 0) then
break ;
g := i ; { maximum code length }
if (uInt(l) > i) then
l := i;
m := l;
{ Adjust last length count to fill out codes, if needed }
y := 1 shl j ;
while (j < i) do
begin
Dec(y, c[j]) ;
if (y < 0) then
begin
huft_build := Z_DATA_ERROR; { bad input: more codes than bits }
exit;
end ;
Inc(j) ;
y := y shl 1
end;
Dec (y, c[i]) ;
if (y < 0) then
begin
huft_build := Z_DATA_ERROR; { bad input: more codes than bits }
exit;
end;
Inc(c[i], y);
{ Generate starting offsets into the value table FOR each length }
{$IFDEF USE_PTR}
x[1] := 0;
j := 0;
p := @c[1];
xp := @x[2];
dec(i); { note that i = g from above }
WHILE (i > 0) DO
BEGIN
inc(j, p^);
xp^ := j;
inc(p);
inc(xp);
dec(i);
END;
{$ELSE}
x[1] := 0;
j := 0 ;
for i := 1 to g do
begin
x[i] := j;
Inc(j, c[i]);
end;
{$ENDIF}
{ Make a table of values in order of bit lengths }
for i := 0 to n-1 do
begin
j := b[i];
if (j <> 0) then
begin
v[ x[j] ] := i;
Inc(x[j]);
end;
end;
n := x[g]; { set n to length of v }
{ Generate the Huffman codes and for each, make the table entries }
i := 0 ;
x[0] := 0 ; { first Huffman code is zero }
p := Addr(v) ; { grab values in bit order }
h := -1 ; { no tables yet--level -1 }
w := -l ; { bits decoded = (l*h) }
u[0] := pInflate_huft(NIL); { just to keep compilers happy }
q := pInflate_huft(NIL); { ditto }
z := 0 ; { ditto }
{ go through the bit lengths (k already is bits in shortest code) }
while (k <= g) Do
begin
a := c[k] ;
while (a<>0) Do
begin
Dec (a) ;
{ here i is the Huffman code of length k bits for value p^ }
{ make tables up to required level }
while (k > w + l) do
begin
Inc (h) ;
Inc (w, l); { add bits already decoded }
{ previous table always l bits }
{ compute minimum size table less than or equal to l bits }
{ table size upper limit }
z := g - w;
If (z > uInt(l)) Then
z := l;
{ try a k-w bit table }
j := k - w;
f := 1 shl j;
if (f > a+1) Then { too few codes for k-w bit table }
begin
Dec(f, a+1); { deduct codes from patterns left }
{$IFDEF USE_PTR}
xp := Addr(c[k]);
if (j < z) then
begin
Inc(j);
while (j < z) do
begin { try smaller tables up to z bits }
f := f shl 1;
Inc (xp) ;
If (f <= xp^) Then
break; { enough codes to use up j bits }
Dec(f, xp^); { else deduct codes from patterns }
Inc(j);
end;
end;
{$ELSE}
xp := k;
if (j < z) then
begin
Inc (j) ;
While (j < z) Do
begin { try smaller tables up to z bits }
f := f * 2;
Inc (xp) ;
if (f <= c[xp]) then
Break ; { enough codes to use up j bits }
Dec (f, c[xp]) ; { else deduct codes from patterns }
Inc (j);
end;
end;
{$ENDIF}
end;
z := 1 shl j; { table entries for j-bit table }
{ allocate new table }
if (hn + z > MANY) then { (note: doesn't matter for fixed) }
begin
huft_build := Z_MEM_ERROR; { not enough memory }
exit;
end;
q := @hp[hn];
u[h] := q;
Inc(hn, z);
{ connect to last table, if there is one }
if (h <> 0) then
begin
x[h] := i; { save pattern for backing up }
r.bits := Byte(l); { bits to dump before this table }
r.exop := Byte(j); { bits in this table }
j := i shr (w - l);
{r.base := uInt( q - u[h-1] -j);} { offset to this table }
r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j;
huft_Ptr(u[h-1])^[j] := r; { connect to last table }
end
else
t^ := q; { first table is returned result }
end;
{ set up table entry in r }
r.bits := Byte(k - w);
{ C-code: if (p >= v + n) - see ZUTIL.PAS for comments }
if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? }
r.exop := 128 + 64 { out of values--invalid code }
else
if (p^ < s) then
begin
if (p^ < 256) then { 256 is end-of-block code }
r.exop := 0
Else
r.exop := 32 + 64; { EOB_code; }
r.base := p^; { simple code is just the value }
Inc(p);
end
Else
begin
r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists }
r.base := d[p^-s];
Inc (p);
end ;
{ fill code-like entries with r }
f := 1 shl (k - w);
j := i shr w;
while (j < z) do
begin
huft_Ptr(q)^[j] := r;
Inc(j, f);
end;
{ backwards increment the k-bit code i }
j := 1 shl (k-1) ;
while (i and j) <> 0 do
begin
i := i xor j; { bitwise exclusive or }
j := j shr 1
end ;
i := i xor j;
{ backup over finished tables }
mask := (1 shl w) - 1; { needed on HP, cc -O bug }
while ((i and mask) <> x[h]) do
begin
Dec(h); { don't need to update q }
Dec(w, l);
mask := (1 shl w) - 1;
end;
end;
Inc(k);
end;
{ Return Z_BUF_ERROR if we were given an incomplete table }
if (y <> 0) And (g <> 1) then
huft_build := Z_BUF_ERROR
else
huft_build := Z_OK;
end; { huft_build}
function inflate_trees_bits(
var c : array of uIntf; { 19 code lengths }
var bb : uIntf; { bits tree desired/actual depth }
var tb : pinflate_huft; { bits tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
var
r : int;
hn : uInt; { hufts used in space }
v : PuIntArray; { work area for huft_build }
begin
hn := 0;
v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) );
if (v = Z_NULL) then
begin
inflate_trees_bits := Z_MEM_ERROR;
exit;
end;
r := huft_build(c, 19, 19, cplens, cplext,
{puIntf(Z_NULL), puIntf(Z_NULL),}
@tb, bb, hp, hn, v^);
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed dynamic bit lengths tree'
else
if (r = Z_BUF_ERROR) or (bb = 0) then
begin
z.msg := 'incomplete dynamic bit lengths tree';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_bits := r;
end;
function inflate_trees_dynamic(
nl : uInt; { number of literal/length codes }
nd : uInt; { number of distance codes }
var c : Array of uIntf; { that many (total) code lengths }
var bl : uIntf; { literal desired/actual bit depth }
var bd : uIntf; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var hp : array of Inflate_huft; { space for trees }
var z : z_stream { for messages }
) : int;
var
r : int;
hn : uInt; { hufts used in space }
v : PuIntArray; { work area for huft_build }
begin
hn := 0;
{ allocate work area }
v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) );
if (v = Z_NULL) then
begin
inflate_trees_dynamic := Z_MEM_ERROR;
exit;
end;
{ build literal/length tree }
r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^);
if (r <> Z_OK) or (bl = 0) then
begin
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed literal/length tree'
else
if (r <> Z_MEM_ERROR) then
begin
z.msg := 'incomplete literal/length tree';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_dynamic := r;
exit;
end;
{ build distance tree }
r := huft_build(puIntArray(@c[nl])^, nd, 0,
cpdist, cpdext, @td, bd, hp, hn, v^);
if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then
begin
if (r = Z_DATA_ERROR) then
z.msg := 'oversubscribed literal/length tree'
else
if (r = Z_BUF_ERROR) then
begin
{$ifdef PKZIP_BUG_WORKAROUND}
r := Z_OK;
end;
{$else}
z.msg := 'incomplete literal/length tree';
r := Z_DATA_ERROR;
end
else
if (r <> Z_MEM_ERROR) then
begin
z.msg := 'empty distance tree with lengths';
r := Z_DATA_ERROR;
end;
ZFREE(z, v);
inflate_trees_dynamic := r;
exit;
{$endif}
end;
{ done }
ZFREE(z, v);
inflate_trees_dynamic := Z_OK;
end;
{$UNDEF BUILDFIXED}
{ build fixed tables only once--keep them here }
{$IFNDEF BUILDFIXED}
{ locals }
var
fixed_built : Boolean = false;
const
FIXEDH = 544; { number of hufts used by fixed tables }
var
fixed_mem : array[0..FIXEDH-1] of inflate_huft;
fixed_bl : uInt;
fixed_bd : uInt;
fixed_tl : pInflate_huft;
fixed_td : pInflate_huft;
{$ELSE}
{ inffixed.h -- table for decoding fixed codes }
{local}
const
fixed_bl = uInt(9);
{local}
const
fixed_bd = uInt(5);
{local}
const
fixed_tl : array [0..288-1] of inflate_huft = (
Exop, { number of extra bits or operation }
bits : Byte; { number of bits in this code or subcode }
{pad : uInt;} { pad structure to a power of 2 (4 bytes for }
{ 16-bit, 8 bytes for 32-bit int's) }
base : uInt; { literal, length base, or distance base }
{ or table offset }
((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31),
((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96),
((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64),
((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144),
((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17),
((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136),
((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20),
((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200),
((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4),
((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92),
((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60),
((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184),
((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3),
((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114),
((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34),
((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228),
((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67),
((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106),
((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74),
((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0),
((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15),
((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134),
((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30),
((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220),
((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14),
((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81),
((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49),
((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162),
((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6),
((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121),
((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41),
((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242),
((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43),
((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101),
((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69),
((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154),
((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23),
((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141),
((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19),
((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198),
((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3),
((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91),
((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59),
((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182),
((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5),
((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119),
((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39),
((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238),
((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99),
((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111),
((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79),
((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115),
((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10),
((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128),
((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24),
((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209),
((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8),
((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84),
((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52),
((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169),
((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8),
((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124),
((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44),
((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249),
((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35),
((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98),
((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66),
((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149),
((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19),
((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138),
((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22),
((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205),
((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6),
((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94),
((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62),
((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189),
((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256),
((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113),
((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33),
((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227),
((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59),
((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105),
((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73),
((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258),
((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13),
((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133),
((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29),
((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219),
((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13),
((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83),
((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51),
((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167),
((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7),
((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123),
((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43),
((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247),
((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51),
((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103),
((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71),
((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159),
((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27),
((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143),
((0,8),79), ((0,9),255)
);
{local}
const
fixed_td : array[0..32-1] of inflate_huft = (
(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17),
(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025),
(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3),
(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193),
(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129),
(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385),
(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7),
(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577),
(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49),
(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073),
(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577)
);
{$ENDIF}
function inflate_trees_fixed(
var bl : uInt; { literal desired/actual bit depth }
var bd : uInt; { distance desired/actual bit depth }
var tl : pInflate_huft; { literal/length tree result }
var td : pInflate_huft; { distance tree result }
var z : z_stream { for memory allocation }
) : int;
type
pFixed_table = ^fixed_table;
fixed_table = array[0..288-1] of uIntf;
var
k : int; { temporary variable }
c : pFixed_table; { length list for huft_build }
v : PuIntArray; { work area for huft_build }
var
f : uInt; { number of hufts used in fixed_mem }
begin
{ build fixed tables if not already (multiple overlapped executions ok) }
if not fixed_built then
begin
f := 0;
{ allocate memory }
c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) );
if (c = Z_NULL) then
begin
inflate_trees_fixed := Z_MEM_ERROR;
exit;
end;
v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) );
if (v = Z_NULL) then
begin
ZFREE(z, c);
inflate_trees_fixed := Z_MEM_ERROR;
exit;
end;
{ literal table }
for k := 0 to Pred(144) do
c^[k] := 8;
for k := 144 to Pred(256) do
c^[k] := 9;
for k := 256 to Pred(280) do
c^[k] := 7;
for k := 280 to Pred(288) do
c^[k] := 8;
fixed_bl := 9;
huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl,
fixed_mem, f, v^);
{ distance table }
for k := 0 to Pred(30) do
c^[k] := 5;
fixed_bd := 5;
huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd,
fixed_mem, f, v^);
{ done }
ZFREE(z, v);
ZFREE(z, c);
fixed_built := True;
end;
bl := fixed_bl;
bd := fixed_bd;
tl := fixed_tl;
td := fixed_td;
inflate_trees_fixed := Z_OK;
end; { inflate_trees_fixed }
end.

222
Imaging/ZLib/iminfutil.pas Normal file
View File

@@ -0,0 +1,222 @@
Unit iminfutil;
{ types and macros common to blocks and codes
Copyright (C) 1995-1998 Mark Adler
WARNING: this file should *not* be used by applications. It is
part of the implementation of the compression library and is
subject to change.
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil, impaszlib;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
{ And'ing with mask[n] masks the lower n bits }
const
inflate_mask : array[0..17-1] of uInt = (
$0000,
$0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff,
$01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff);
{procedure GRABBITS(j : int);}
{procedure DUMPBITS(j : int);}
{procedure NEEDBITS(j : int);}
implementation
{ macros for bit input with no checking and for returning unused bytes }
procedure GRABBITS(j : int);
begin
{while (k < j) do
begin
Dec(z^.avail_in);
Inc(z^.total_in);
b := b or (uLong(z^.next_in^) shl k);
Inc(z^.next_in);
Inc(k, 8);
end;}
end;
procedure DUMPBITS(j : int);
begin
{b := b shr j;
Dec(k, j);}
end;
procedure NEEDBITS(j : int);
begin
(*
while (k < j) do
begin
{NEEDBYTE;}
if (n <> 0) then
r :=Z_OK
else
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
Dec(n);
b := b or (uLong(p^) shl k);
Inc(p);
Inc(k, 8);
end;
*)
end;
procedure NEEDOUT;
begin
(*
if (m = 0) then
begin
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{FLUSH}
s.write := q;
r := inflate_flush(s,z,r);
q := s.write;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
{WRAP}
if (q = s.zend) and (s.read <> s.window) then
begin
q := s.window;
if LongInt(q) < LongInt(s.read) then
m := uInt(LongInt(s.read)-LongInt(q)-1)
else
m := uInt(LongInt(s.zend)-LongInt(q));
end;
if (m = 0) then
begin
{UPDATE}
s.bitb := b;
s.bitk := k;
z.avail_in := n;
Inc(z.total_in, LongInt(p)-LongInt(z.next_in));
z.next_in := p;
s.write := q;
result := inflate_flush(s,z,r);
exit;
end;
end;
end;
r := Z_OK;
*)
end;
{ copy as much as possible from the sliding window to the output area }
function inflate_flush(var s : inflate_blocks_state;
var z : z_stream;
r : int) : int;
var
n : uInt;
p : pBytef;
q : pBytef;
begin
{ local copies of source and destination pointers }
p := z.next_out;
q := s.read;
{ compute number of bytes to copy as far as end of window }
if ptr2int(q) <= ptr2int(s.write) then
n := uInt(ptr2int(s.write) - ptr2int(q))
else
n := uInt(ptr2int(s.zend) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec(z.avail_out, n);
Inc(z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy as far as end of window }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
{ see if more to copy at beginning of window }
if (q = s.zend) then
begin
{ wrap pointers }
q := s.window;
if (s.write = s.zend) then
s.write := s.window;
{ compute bytes to copy }
n := uInt(ptr2int(s.write) - ptr2int(q));
if (n > z.avail_out) then
n := z.avail_out;
if (n <> 0) and (r = Z_BUF_ERROR) then
r := Z_OK;
{ update counters }
Dec( z.avail_out, n);
Inc( z.total_out, n);
{ update check information }
if Assigned(s.checkfn) then
begin
s.check := s.checkfn(s.check, q, n);
z.adler := s.check;
end;
{ copy }
zmemcpy(p, q, n);
Inc(p, n);
Inc(q, n);
end;
{ update pointers }
z.next_out := p;
s.read := q;
{ done }
inflate_flush := r;
end;
end.

520
Imaging/ZLib/impaszlib.pas Normal file
View File

@@ -0,0 +1,520 @@
Unit impaszlib;
{ Original:
zlib.h -- interface of the 'zlib' general purpose compression library
version 1.1.0, Feb 24th, 1998
Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Jean-loup Gailly Mark Adler
jloup@gzip.org madler@alumni.caltech.edu
The data format used by the zlib library is described by RFCs (Request for
Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt
(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil;
{ zconf.h -- configuration of the zlib compression library }
{ zutil.c -- target dependent utility functions for the compression library }
{ The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The library also supports reading and writing files in gzip (.gz) format
with an interface similar to that of stdio.
The library does not install any signal handler. The decoder checks
the consistency of the compressed data, so the library should never
crash even in case of corrupted input. }
{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more
than 64k bytes at a time (needed on systems with 16-bit int). }
{ Maximum value for memLevel in deflateInit2 }
const
MAX_MEM_LEVEL = 9;
DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 }
{ Maximum value for windowBits in deflateInit2 and inflateInit2 }
const
MAX_WBITS = 15; { 32K LZ77 window }
{ default windowBits for decompression. MAX_WBITS is for compression only }
const
DEF_WBITS = MAX_WBITS;
{ The memory requirements for deflate are (in bytes):
1 shl (windowBits+2) + 1 shl (memLevel+9)
that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)
plus a few kilobytes for small objects. For example, if you want to reduce
the default memory requirements from 256K to 128K, compile with
DMAX_WBITS=14 DMAX_MEM_LEVEL=7
Of course this will generally degrade compression (there's no free lunch).
The memory requirements for inflate are (in bytes) 1 shl windowBits
that is, 32K for windowBits=15 (default value) plus a few kilobytes
for small objects. }
{ Huffman code lookup table entry--this entry is four bytes for machines
that have 16-bit pointers (e.g. PC's in the small or medium model). }
type
pInflate_huft = ^inflate_huft;
inflate_huft = Record
Exop, { number of extra bits or operation }
bits : Byte; { number of bits in this code or subcode }
{pad : uInt;} { pad structure to a power of 2 (4 bytes for }
{ 16-bit, 8 bytes for 32-bit int's) }
base : uInt; { literal, length base, or distance base }
{ or table offset }
End;
type
huft_field = Array[0..(MaxInt div SizeOf(inflate_huft))-1] of inflate_huft;
huft_ptr = ^huft_field;
type
ppInflate_huft = ^pInflate_huft;
type
inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing }
START, { x: set up for LEN }
LEN, { i: get length/literal/eob next }
LENEXT, { i: getting length extra (have base) }
DIST, { i: get distance next }
DISTEXT, { i: getting distance extra }
COPY, { o: copying bytes in window, waiting for space }
LIT, { o: got literal, waiting for output space }
WASH, { o: got eob, possibly still output waiting }
ZEND, { x: got eob and all data flushed }
BADCODE); { x: got error }
{ inflate codes private state }
type
pInflate_codes_state = ^inflate_codes_state;
inflate_codes_state = record
mode : inflate_codes_mode; { current inflate_codes mode }
{ mode dependent information }
len : uInt;
sub : record { submode }
Case Byte of
0:(code : record { if LEN or DIST, where in tree }
tree : pInflate_huft; { pointer into tree }
need : uInt; { bits needed }
end);
1:(lit : uInt); { if LIT, literal }
2:(copy: record { if EXT or COPY, where and how much }
get : uInt; { bits to get for extra }
dist : uInt; { distance back to copy from }
end);
end;
{ mode independent information }
lbits : Byte; { ltree bits decoded per branch }
dbits : Byte; { dtree bits decoder per branch }
ltree : pInflate_huft; { literal/length/eob tree }
dtree : pInflate_huft; { distance tree }
end;
type
check_func = function(check : uLong;
buf : pBytef;
{const buf : array of byte;}
len : uInt) : uLong;
type
inflate_block_mode =
(ZTYPE, { get type bits (3, including end bit) }
LENS, { get lengths for stored }
STORED, { processing stored block }
TABLE, { get table lengths }
BTREE, { get bit lengths tree for a dynamic block }
DTREE, { get length, distance trees for a dynamic block }
CODES, { processing fixed or dynamic block }
DRY, { output remaining window bytes }
BLKDONE, { finished last block, done }
BLKBAD); { got a data error--stuck here }
type
pInflate_blocks_state = ^inflate_blocks_state;
{ inflate blocks semi-private state }
inflate_blocks_state = record
mode : inflate_block_mode; { current inflate_block mode }
{ mode dependent information }
sub : record { submode }
case Byte of
0:(left : uInt); { if STORED, bytes left to copy }
1:(trees : record { if DTREE, decoding info for trees }
table : uInt; { table lengths (14 bits) }
index : uInt; { index into blens (or border) }
blens : PuIntArray; { bit lengths of codes }
bb : uInt; { bit length tree depth }
tb : pInflate_huft; { bit length decoding tree }
end);
2:(decode : record { if CODES, current state }
tl : pInflate_huft;
td : pInflate_huft; { trees to free }
codes : pInflate_codes_state;
end);
end;
last : boolean; { true if this block is the last block }
{ mode independent information }
bitk : uInt; { bits in bit buffer }
bitb : uLong; { bit buffer }
hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space }
window : pBytef; { sliding window }
zend : pBytef; { one byte after sliding window }
read : pBytef; { window read pointer }
write : pBytef; { window write pointer }
checkfn : check_func; { check function }
check : uLong; { check on output }
end;
type
inflate_mode = (
METHOD, { waiting for method byte }
FLAG, { waiting for flag byte }
DICT4, { four dictionary check bytes to go }
DICT3, { three dictionary check bytes to go }
DICT2, { two dictionary check bytes to go }
DICT1, { one dictionary check byte to go }
DICT0, { waiting for inflateSetDictionary }
BLOCKS, { decompressing blocks }
CHECK4, { four check bytes to go }
CHECK3, { three check bytes to go }
CHECK2, { two check bytes to go }
CHECK1, { one check byte to go }
DONE, { finished check, done }
BAD); { got an error--stay here }
{ inflate private state }
type
pInternal_state = ^internal_state; { or point to a deflate_state record }
internal_state = record
mode : inflate_mode; { current inflate mode }
{ mode dependent information }
sub : record { submode }
case byte of
0:(method : uInt); { if FLAGS, method byte }
1:(check : record { if CHECK, check values to compare }
was : uLong; { computed check value }
need : uLong; { stream check value }
end);
2:(marker : uInt); { if BAD, inflateSync's marker bytes count }
end;
{ mode independent information }
nowrap : boolean; { flag for no wrapper }
wbits : uInt; { log2(window size) (8..15, defaults to 15) }
blocks : pInflate_blocks_state; { current inflate_blocks state }
end;
type
alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf;
free_func = procedure(opaque : voidpf; address : voidpf);
type
z_streamp = ^z_stream;
z_stream = record
next_in : pBytef; { next input byte }
avail_in : uInt; { number of bytes available at next_in }
total_in : uLong; { total nb of input bytes read so far }
next_out : pBytef; { next output byte should be put there }
avail_out : uInt; { remaining free space at next_out }
total_out : uLong; { total nb of bytes output so far }
msg : string[255]; { last error message, '' if no error }
state : pInternal_state; { not visible by applications }
zalloc : alloc_func; { used to allocate the internal state }
zfree : free_func; { used to free the internal state }
opaque : voidpf; { private data object passed to zalloc and zfree }
data_type : int; { best guess about the data type: ascii or binary }
adler : uLong; { adler32 value of the uncompressed data }
reserved : uLong; { reserved for future use }
end;
{ The application must update next_in and avail_in when avail_in has
dropped to zero. It must update next_out and avail_out when avail_out
has dropped to zero. The application must initialize zalloc, zfree and
opaque before calling the init function. All other fields are set by the
compression library and must not be updated by the application.
The opaque value provided by the application will be passed as the first
parameter for calls of zalloc and zfree. This can be useful for custom
memory management. The compression library attaches no meaning to the
opaque value.
zalloc must return Z_NULL if there is not enough memory for the object.
On 16-bit systems, the functions zalloc and zfree must be able to allocate
exactly 65536 bytes, but will not be required to allocate more than this
if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,
pointers returned by zalloc for objects of exactly 65536 bytes *must*
have their offset normalized to zero. The default allocation function
provided by this library ensures this (see zutil.c). To reduce memory
requirements and avoid any allocation of 64K objects, at the expense of
compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).
The fields total_in and total_out can be used for statistics or
progress reports. After compression, total_in holds the total size of
the uncompressed data and may be saved for use in the decompressor
(particularly if the decompressor wants to decompress everything in
a single step). }
const { constants }
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_SYNC_FLUSH = 2;
Z_FULL_FLUSH = 3;
Z_FINISH = 4;
{ Allowed flush values; see deflate() below for details }
Z_OK = 0;
Z_STREAM_END = 1;
Z_NEED_DICT = 2;
Z_ERRNO = (-1);
Z_STREAM_ERROR = (-2);
Z_DATA_ERROR = (-3);
Z_MEM_ERROR = (-4);
Z_BUF_ERROR = (-5);
Z_VERSION_ERROR = (-6);
{ Return codes for the compression/decompression functions. Negative
values are errors, positive values are used for special but normal events.}
Z_NO_COMPRESSION = 0;
Z_BEST_SPEED = 1;
Z_BEST_COMPRESSION = 9;
Z_DEFAULT_COMPRESSION = (-1);
{ compression levels }
Z_FILTERED = 1;
Z_HUFFMAN_ONLY = 2;
Z_DEFAULT_STRATEGY = 0;
{ compression strategy; see deflateInit2() below for details }
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
{ Possible values of the data_type field }
Z_DEFLATED = 8;
{ The deflate compression method (the only one supported in this version) }
Z_NULL = NIL; { for initializing zalloc, zfree, opaque }
{$IFDEF GZIO}
var
errno : int;
{$ENDIF}
{ common constants }
{ The three kinds of block type }
const
STORED_BLOCK = 0;
STATIC_TREES = 1;
DYN_TREES = 2;
{ The minimum and maximum match lengths }
const
MIN_MATCH = 3;
MAX_MATCH = 258;
const
PRESET_DICT = $20; { preset dictionary flag in zlib header }
{$IFDEF DEBUG}
procedure Assert(cond : boolean; msg : string);
{$ENDIF}
procedure Trace(x : string);
procedure Tracev(x : string);
procedure Tracevv(x : string);
procedure Tracevvv(x : string);
procedure Tracec(c : boolean; x : string);
procedure Tracecv(c : boolean; x : string);
function zlibVersion : string;
{ The application can compare zlibVersion and ZLIB_VERSION for consistency.
If the first character differs, the library code actually used is
not compatible with the zlib.h header file used by the application.
This check is automatically made by deflateInit and inflateInit. }
function zError(err : int) : string;
function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
procedure ZFREE (var strm : z_stream; ptr : voidpf);
procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
const
ZLIB_VERSION : string[10] = '1.1.2';
const
z_errbase = Z_NEED_DICT;
z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error }
('need dictionary', { Z_NEED_DICT 2 }
'stream end', { Z_STREAM_END 1 }
'', { Z_OK 0 }
'file error', { Z_ERRNO (-1) }
'stream error', { Z_STREAM_ERROR (-2) }
'data error', { Z_DATA_ERROR (-3) }
'insufficient memory', { Z_MEM_ERROR (-4) }
'buffer error', { Z_BUF_ERROR (-5) }
'incompatible version',{ Z_VERSION_ERROR (-6) }
'');
const
z_verbose : int = 1;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
Stream_size: LongInt): LongInt;
function inflateInit_(var Stream: z_stream; const Version: string;
Stream_size: Longint): LongInt;
{$IFDEF DEBUG}
procedure z_error (m : string);
{$ENDIF}
implementation
uses
imzdeflate, imzinflate;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
Stream_size: LongInt): LongInt;
begin
Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size);
end;
function inflateInit_(var Stream: z_stream; const Version: string;
Stream_size: Longint): LongInt;
begin
Result := imzinflate.inflateInit_(@Stream, Version, Stream_size);
end;
function zError(err : int) : string;
begin
zError := z_errmsg[Z_NEED_DICT-err];
end;
function zlibVersion : string;
begin
zlibVersion := ZLIB_VERSION;
end;
procedure z_error (m : string);
begin
WriteLn(output, m);
Write('Zlib - Halt...');
ReadLn;
Halt(1);
end;
procedure Assert(cond : boolean; msg : string);
begin
if not cond then
z_error(msg);
end;
procedure Trace(x : string);
begin
WriteLn(x);
end;
procedure Tracev(x : string);
begin
if (z_verbose>0) then
WriteLn(x);
end;
procedure Tracevv(x : string);
begin
if (z_verbose>1) then
WriteLn(x);
end;
procedure Tracevvv(x : string);
begin
if (z_verbose>2) then
WriteLn(x);
end;
procedure Tracec(c : boolean; x : string);
begin
if (z_verbose>0) and (c) then
WriteLn(x);
end;
procedure Tracecv(c : boolean; x : string);
begin
if (z_verbose>1) and c then
WriteLn(x);
end;
function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
begin
ZALLOC := strm.zalloc(strm.opaque, items, size);
end;
procedure ZFREE (var strm : z_stream; ptr : voidpf);
begin
strm.zfree(strm.opaque, ptr);
end;
procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
begin
{if @strm <> Z_NULL then}
strm.zfree(strm.opaque, ptr);
end;
end.

2249
Imaging/ZLib/imtrees.pas Normal file
View File

File diff suppressed because it is too large Load Diff

25
Imaging/ZLib/imzconf.inc Normal file
View File

@@ -0,0 +1,25 @@
{ -------------------------------------------------------------------- }
{$DEFINE MAX_MATCH_IS_258}
{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more
than 64k bytes at a time (needed on systems with 16-bit int). }
{$UNDEF MAXSEG_64K}
{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! }
{$UNDEF DYNAMIC_CRC_TABLE}
{$UNDEF FASTEST}
{$DEFINE Use32}
{$DEFINE patch112} { apply patch from the zlib home page }
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$UNDEF DEBUG} // for Delphi 2007 in DEBUG mode
{$RANGECHECKS OFF}
{$OVERFLOWCHECKS OFF}
{ -------------------------------------------------------------------- }

2129
Imaging/ZLib/imzdeflate.pas Normal file
View File

File diff suppressed because it is too large Load Diff

750
Imaging/ZLib/imzinflate.pas Normal file
View File

@@ -0,0 +1,750 @@
Unit imzinflate;
{ inflate.c -- zlib interface to inflate modules
Copyright (C) 1995-1998 Mark Adler
Pascal tranlastion
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
uses
imzutil, impaszlib, iminfblock, iminfutil;
function inflateInit(var z : z_stream) : int;
{ Initializes the internal stream state for decompression. The fields
zalloc, zfree and opaque must be initialized before by the caller. If
zalloc and zfree are set to Z_NULL, inflateInit updates them to use default
allocation functions.
inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not
enough memory, Z_VERSION_ERROR if the zlib library version is incompatible
with the version assumed by the caller. msg is set to null if there is no
error message. inflateInit does not perform any decompression: this will be
done by inflate(). }
function inflateInit_(z : z_streamp;
const version : string;
stream_size : int) : int;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
stream_size : int) : int;
function inflateInit2(var z: z_stream;
windowBits : int) : int;
{
This is another version of inflateInit with an extra parameter. The
fields next_in, avail_in, zalloc, zfree and opaque must be initialized
before by the caller.
The windowBits parameter is the base two logarithm of the maximum window
size (the size of the history buffer). It should be in the range 8..15 for
this version of the library. The default value is 15 if inflateInit is used
instead. If a compressed stream with a larger window size is given as
input, inflate() will return with the error code Z_DATA_ERROR instead of
trying to allocate a larger window.
inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative
memLevel). msg is set to null if there is no error message. inflateInit2
does not perform any decompression apart from reading the zlib header if
present: this will be done by inflate(). (So next_in and avail_in may be
modified, but next_out and avail_out are unchanged.)
}
function inflateEnd(var z : z_stream) : int;
{
All dynamically allocated data structures for this stream are freed.
This function discards any unprocessed input and does not flush any
pending output.
inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state
was inconsistent. In the error case, msg may be set but then points to a
static string (which must not be deallocated).
}
function inflateReset(var z : z_stream) : int;
{
This function is equivalent to inflateEnd followed by inflateInit,
but does not free and reallocate all the internal decompression state.
The stream will keep attributes that may have been set by inflateInit2.
inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
stream state was inconsistent (such as zalloc or state being NULL).
}
function inflate(var z : z_stream;
f : int) : int;
{
inflate decompresses as much data as possible, and stops when the input
buffer becomes empty or the output buffer becomes full. It may introduce
some output latency (reading input without producing any output)
except when forced to flush.
The detailed semantics are as follows. inflate performs one or both of the
following actions:
- Decompress more input starting at next_in and update next_in and avail_in
accordingly. If not all input can be processed (because there is not
enough room in the output buffer), next_in is updated and processing
will resume at this point for the next call of inflate().
- Provide more output starting at next_out and update next_out and avail_out
accordingly. inflate() provides as much output as possible, until there
is no more input data or no more space in the output buffer (see below
about the flush parameter).
Before the call of inflate(), the application should ensure that at least
one of the actions is possible, by providing more input and/or consuming
more output, and updating the next_* and avail_* values accordingly.
The application can consume the uncompressed output when it wants, for
example when the output buffer is full (avail_out == 0), or after each
call of inflate(). If inflate returns Z_OK and with zero avail_out, it
must be called again after making room in the output buffer because there
might be more output pending.
If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much
output as possible to the output buffer. The flushing behavior of inflate is
not specified for values of the flush parameter other than Z_SYNC_FLUSH
and Z_FINISH, but the current implementation actually flushes as much output
as possible anyway.
inflate() should normally be called until it returns Z_STREAM_END or an
error. However if all decompression is to be performed in a single step
(a single call of inflate), the parameter flush should be set to
Z_FINISH. In this case all pending input is processed and all pending
output is flushed; avail_out must be large enough to hold all the
uncompressed data. (The size of the uncompressed data may have been saved
by the compressor for this purpose.) The next operation on this stream must
be inflateEnd to deallocate the decompression state. The use of Z_FINISH
is never required, but can be used to inform inflate that a faster routine
may be used for the single inflate() call.
If a preset dictionary is needed at this point (see inflateSetDictionary
below), inflate sets strm-adler to the adler32 checksum of the
dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise
it sets strm->adler to the adler32 checksum of all output produced
so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or
an error code as described below. At the end of the stream, inflate()
checks that its computed adler32 checksum is equal to that saved by the
compressor and returns Z_STREAM_END only if the checksum is correct.
inflate() returns Z_OK if some progress has been made (more input processed
or more output produced), Z_STREAM_END if the end of the compressed data has
been reached and all uncompressed output has been produced, Z_NEED_DICT if a
preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
corrupted (input stream not conforming to the zlib format or incorrect
adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent
(for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not
enough memory, Z_BUF_ERROR if no progress is possible or if there was not
enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR
case, the application may then call inflateSync to look for a good
compression block.
}
function inflateSetDictionary(var z : z_stream;
dictionary : pBytef; {const array of byte}
dictLength : uInt) : int;
{
Initializes the decompression dictionary from the given uncompressed byte
sequence. This function must be called immediately after a call of inflate
if this call returned Z_NEED_DICT. The dictionary chosen by the compressor
can be determined from the Adler32 value returned by this call of
inflate. The compressor and decompressor must use exactly the same
dictionary (see deflateSetDictionary).
inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
parameter is invalid (such as NULL dictionary) or the stream state is
inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
expected one (incorrect Adler32 value). inflateSetDictionary does not
perform any decompression: this will be done by subsequent calls of
inflate().
}
function inflateSync(var z : z_stream) : int;
{
Skips invalid compressed data until a full flush point (see above the
description of deflate with Z_FULL_FLUSH) can be found, or until all
available input is skipped. No output is provided.
inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
if no more input was provided, Z_DATA_ERROR if no flush point has been found,
or Z_STREAM_ERROR if the stream structure was inconsistent. In the success
case, the application may save the current current value of total_in which
indicates where valid compressed data was found. In the error case, the
application may repeatedly call inflateSync, providing more input each time,
until success or end of the input data.
}
function inflateSyncPoint(var z : z_stream) : int;
implementation
uses
imadler;
function inflateReset(var z : z_stream) : int;
begin
if (z.state = Z_NULL) then
begin
inflateReset := Z_STREAM_ERROR;
exit;
end;
z.total_out := 0;
z.total_in := 0;
z.msg := '';
if z.state^.nowrap then
z.state^.mode := BLOCKS
else
z.state^.mode := METHOD;
inflate_blocks_reset(z.state^.blocks^, z, Z_NULL);
{$IFDEF DEBUG}
Tracev('inflate: reset');
{$ENDIF}
inflateReset := Z_OK;
end;
function inflateEnd(var z : z_stream) : int;
begin
if (z.state = Z_NULL) or not Assigned(z.zfree) then
begin
inflateEnd := Z_STREAM_ERROR;
exit;
end;
if (z.state^.blocks <> Z_NULL) then
inflate_blocks_free(z.state^.blocks, z);
ZFREE(z, z.state);
z.state := Z_NULL;
{$IFDEF DEBUG}
Tracev('inflate: end');
{$ENDIF}
inflateEnd := Z_OK;
end;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
stream_size : int) : int;
begin
if (version = '') or (version[1] <> ZLIB_VERSION[1]) or
(stream_size <> sizeof(z_stream)) then
begin
inflateInit2_ := Z_VERSION_ERROR;
exit;
end;
{ initialize state }
{ SetLength(strm.msg, 255); }
z.msg := '';
if not Assigned(z.zalloc) then
begin
{$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE}
z.zalloc := zcalloc;
{$endif}
z.opaque := voidpf(0);
end;
if not Assigned(z.zfree) then
{$IFDEF FPC} z.zfree := @zcfree; {$ELSE}
z.zfree := zcfree;
{$ENDIF}
z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) );
if (z.state = Z_NULL) then
begin
inflateInit2_ := Z_MEM_ERROR;
exit;
end;
z.state^.blocks := Z_NULL;
{ handle undocumented nowrap option (no zlib header or check) }
z.state^.nowrap := FALSE;
if (w < 0) then
begin
w := - w;
z.state^.nowrap := TRUE;
end;
{ set window size }
if (w < 8) or (w > 15) then
begin
inflateEnd(z);
inflateInit2_ := Z_STREAM_ERROR;
exit;
end;
z.state^.wbits := uInt(w);
{ create inflate_blocks state }
if z.state^.nowrap then
z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w)
else
{$IFDEF FPC}
z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w);
{$ELSE}
z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w);
{$ENDIF}
if (z.state^.blocks = Z_NULL) then
begin
inflateEnd(z);
inflateInit2_ := Z_MEM_ERROR;
exit;
end;
{$IFDEF DEBUG}
Tracev('inflate: allocated');
{$ENDIF}
{ reset state }
inflateReset(z);
inflateInit2_ := Z_OK;
end;
function inflateInit2(var z: z_stream; windowBits : int) : int;
begin
inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream));
end;
function inflateInit(var z : z_stream) : int;
{ inflateInit is a macro to allow checking the zlib version
and the compiler's view of z_stream: }
begin
inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream));
end;
function inflateInit_(z : z_streamp;
const version : string;
stream_size : int) : int;
begin
{ initialize state }
if (z = Z_NULL) then
inflateInit_ := Z_STREAM_ERROR
else
inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size);
end;
function inflate(var z : z_stream;
f : int) : int;
var
r : int;
b : uInt;
begin
if (z.state = Z_NULL) or (z.next_in = Z_NULL) then
begin
inflate := Z_STREAM_ERROR;
exit;
end;
if f = Z_FINISH then
f := Z_BUF_ERROR
else
f := Z_OK;
r := Z_BUF_ERROR;
while True do
case (z.state^.mode) of
BLOCKS:
begin
r := inflate_blocks(z.state^.blocks^, z, r);
if (r = Z_DATA_ERROR) then
begin
z.state^.mode := BAD;
z.state^.sub.marker := 0; { can try inflateSync }
continue; { break C-switch }
end;
if (r = Z_OK) then
r := f;
if (r <> Z_STREAM_END) then
begin
inflate := r;
exit;
end;
r := f;
inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was);
if (z.state^.nowrap) then
begin
z.state^.mode := DONE;
continue; { break C-switch }
end;
z.state^.mode := CHECK4; { falltrough }
end;
CHECK4:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.check.need := uLong(z.next_in^) shl 24;
Inc(z.next_in);
z.state^.mode := CHECK3; { falltrough }
end;
CHECK3:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);
Inc(z.next_in);
z.state^.mode := CHECK2; { falltrough }
end;
CHECK2:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);
Inc(z.next_in);
z.state^.mode := CHECK1; { falltrough }
end;
CHECK1:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) );
Inc(z.next_in);
if (z.state^.sub.check.was <> z.state^.sub.check.need) then
begin
z.state^.mode := BAD;
z.msg := 'incorrect data check';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
{$IFDEF DEBUG}
Tracev('inflate: zlib check ok');
{$ENDIF}
z.state^.mode := DONE; { falltrough }
end;
DONE:
begin
inflate := Z_STREAM_END;
exit;
end;
METHOD:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f; {}
{z.state^.sub.method := NEXTBYTE(z);}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.method := z.next_in^;
Inc(z.next_in);
if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then
begin
z.state^.mode := BAD;
z.msg := 'unknown compression method';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then
begin
z.state^.mode := BAD;
z.msg := 'invalid window size';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
z.state^.mode := FLAG;
{ fall trough }
end;
FLAG:
begin
{NEEDBYTE}
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f; {}
{b := NEXTBYTE(z);}
Dec(z.avail_in);
Inc(z.total_in);
b := z.next_in^;
Inc(z.next_in);
if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?}
begin
z.state^.mode := BAD;
z.msg := 'incorrect header check';
z.state^.sub.marker := 5; { can't try inflateSync }
continue; { break C-switch }
end;
{$IFDEF DEBUG}
Tracev('inflate: zlib header ok');
{$ENDIF}
if ((b and PRESET_DICT) = 0) then
begin
z.state^.mode := BLOCKS;
continue; { break C-switch }
end;
z.state^.mode := DICT4;
{ falltrough }
end;
DICT4:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;}
Dec(z.avail_in);
Inc(z.total_in);
z.state^.sub.check.need := uLong(z.next_in^) shl 24;
Inc(z.next_in);
z.state^.mode := DICT3; { falltrough }
end;
DICT3:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16);
Inc(z.next_in);
z.state^.mode := DICT2; { falltrough }
end;
DICT2:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
r := f;
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8);
Inc(z.next_in);
z.state^.mode := DICT1; { falltrough }
end;
DICT1:
begin
if (z.avail_in = 0) then
begin
inflate := r;
exit;
end;
{ r := f; --- wird niemals benutzt }
{Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );}
Dec(z.avail_in);
Inc(z.total_in);
Inc(z.state^.sub.check.need, uLong(z.next_in^) );
Inc(z.next_in);
z.adler := z.state^.sub.check.need;
z.state^.mode := DICT0;
inflate := Z_NEED_DICT;
exit;
end;
DICT0:
begin
z.state^.mode := BAD;
z.msg := 'need dictionary';
z.state^.sub.marker := 0; { can try inflateSync }
inflate := Z_STREAM_ERROR;
exit;
end;
BAD:
begin
inflate := Z_DATA_ERROR;
exit;
end;
else
begin
inflate := Z_STREAM_ERROR;
exit;
end;
end;
{$ifdef NEED_DUMMY_result}
result := Z_STREAM_ERROR; { Some dumb compilers complain without this }
{$endif}
end;
function inflateSetDictionary(var z : z_stream;
dictionary : pBytef; {const array of byte}
dictLength : uInt) : int;
var
length : uInt;
begin
length := dictLength;
if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then
begin
inflateSetDictionary := Z_STREAM_ERROR;
exit;
end;
if (adler32(Long(1), dictionary, dictLength) <> z.adler) then
begin
inflateSetDictionary := Z_DATA_ERROR;
exit;
end;
z.adler := Long(1);
if (length >= (uInt(1) shl z.state^.wbits)) then
begin
length := (1 shl z.state^.wbits)-1;
Inc( dictionary, dictLength - length);
end;
inflate_set_dictionary(z.state^.blocks^, dictionary^, length);
z.state^.mode := BLOCKS;
inflateSetDictionary := Z_OK;
end;
function inflateSync(var z : z_stream) : int;
const
mark : packed array[0..3] of byte = (0, 0, $ff, $ff);
var
n : uInt; { number of bytes to look at }
p : pBytef; { pointer to bytes }
m : uInt; { number of marker bytes found in a row }
r, w : uLong; { temporaries to save total_in and total_out }
begin
{ set up }
if (z.state = Z_NULL) then
begin
inflateSync := Z_STREAM_ERROR;
exit;
end;
if (z.state^.mode <> BAD) then
begin
z.state^.mode := BAD;
z.state^.sub.marker := 0;
end;
n := z.avail_in;
if (n = 0) then
begin
inflateSync := Z_BUF_ERROR;
exit;
end;
p := z.next_in;
m := z.state^.sub.marker;
{ search }
while (n <> 0) and (m < 4) do
begin
if (p^ = mark[m]) then
Inc(m)
else
if (p^ <> 0) then
m := 0
else
m := 4 - m;
Inc(p);
Dec(n);
end;
{ restore }
Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in));
z.next_in := p;
z.avail_in := n;
z.state^.sub.marker := m;
{ return no joy or set up to restart on a new block }
if (m <> 4) then
begin
inflateSync := Z_DATA_ERROR;
exit;
end;
r := z.total_in;
w := z.total_out;
inflateReset(z);
z.total_in := r;
z.total_out := w;
z.state^.mode := BLOCKS;
inflateSync := Z_OK;
end;
{
returns true if inflate is currently at the end of a block generated
by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP
implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH
but removes the length bytes of the resulting empty stored block. When
decompressing, PPP checks that at the end of input packet, inflate is
waiting for these length bytes.
}
function inflateSyncPoint(var z : z_stream) : int;
begin
if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then
begin
inflateSyncPoint := Z_STREAM_ERROR;
exit;
end;
inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^);
end;
end.

191
Imaging/ZLib/imzutil.pas Normal file
View File

@@ -0,0 +1,191 @@
Unit imzutil;
{
Copyright (C) 1998 by Jacques Nomssi Nzali
For conditions of distribution and use, see copyright notice in readme.txt
}
interface
{$I imzconf.inc}
{ Type declarations }
type
{Byte = usigned char; 8 bits}
Bytef = byte;
charf = byte;
int = longint;
intf = int;
uInt = cardinal; { 16 bits or more }
uIntf = uInt;
Long = longint;
uLong = Cardinal;
uLongf = uLong;
voidp = pointer;
voidpf = voidp;
pBytef = ^Bytef;
pIntf = ^intf;
puIntf = ^uIntf;
puLong = ^uLongf;
ptr2int = uInt;
{ a pointer to integer casting is used to do pointer arithmetic.
ptr2int must be an integer type and sizeof(ptr2int) must be less
than sizeof(pointer) - Nomssi }
type
zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef;
pzByteArray = ^zByteArray;
type
zIntfArray = array[0..(MaxInt div SizeOf(Intf))-1] of Intf;
pzIntfArray = ^zIntfArray;
type
zuIntArray = array[0..(MaxInt div SizeOf(uInt))-1] of uInt;
PuIntArray = ^zuIntArray;
{ Type declarations - only for deflate }
type
uch = Byte;
uchf = uch; { FAR }
ush = Word;
ushf = ush;
ulg = LongInt;
unsigned = uInt;
pcharf = ^charf;
puchf = ^uchf;
pushf = ^ushf;
type
zuchfArray = zByteArray;
puchfArray = ^zuchfArray;
type
zushfArray = array[0..(MaxInt div SizeOf(ushf))-1] of ushf;
pushfArray = ^zushfArray;
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
procedure zmemzero(destp : pBytef; len : uInt);
procedure zcfree(opaque : voidpf; ptr : voidpf);
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
implementation
procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
begin
Move(sourcep^, destp^, len);
end;
function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
var
j : uInt;
source,
dest : pBytef;
begin
source := s1p;
dest := s2p;
for j := 0 to pred(len) do
begin
if (source^ <> dest^) then
begin
zmemcmp := 2*Ord(source^ > dest^)-1;
exit;
end;
Inc(source);
Inc(dest);
end;
zmemcmp := 0;
end;
procedure zmemzero(destp : pBytef; len : uInt);
begin
FillChar(destp^, len, 0);
end;
procedure zcfree(opaque : voidpf; ptr : voidpf);
{$ifdef Delphi16}
var
Handle : THandle;
{$endif}
{$IFDEF FPC}
var
memsize : uint;
{$ENDIF}
begin
(*
{$IFDEF DPMI}
{h :=} GlobalFreePtr(ptr);
{$ELSE}
{$IFDEF CALL_DOS}
dosFree(ptr);
{$ELSE}
{$ifdef HugeMem}
FreeMemHuge(ptr);
{$else}
{$ifdef Delphi16}
Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
GlobalUnLock(Handle);
GlobalFree(Handle);
{$else}
{$IFDEF FPC}
Dec(puIntf(ptr));
memsize := puIntf(ptr)^;
FreeMem(ptr, memsize+SizeOf(uInt));
{$ELSE}
FreeMem(ptr); { Delphi 2,3,4 }
{$ENDIF}
{$endif}
{$endif}
{$ENDIF}
{$ENDIF}
*)
FreeMem(ptr);
end;
function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
var
p : voidpf;
memsize : uLong;
{$ifdef Delphi16}
handle : THandle;
{$endif}
begin
memsize := uLong(items) * size;
(*
{ $IFDEF DPMI}
p := GlobalAllocPtr(gmem_moveable, memsize);
{ $ELSE}
{ $IFDEF CALLDOS}
p := dosAlloc(memsize);
{ $ELSE}
{$ifdef HugeMem}
GetMemHuge(p, memsize);
{ $else}
{ $ifdef Delphi16}
Handle := GlobalAlloc(HeapAllocFlags, memsize);
p := GlobalLock(Handle);
{ $else}
{ $IFDEF FPC}
GetMem(p, memsize+SizeOf(uInt));
puIntf(p)^:= memsize;
Inc(puIntf(p));
{ $ELSE}
GetMem(p, memsize); { Delphi: p := AllocMem(memsize); }
{ $ENDIF}
{ $endif}
{ $endif}
{ $ENDIF}
{ $ENDIF}
*)
GetMem(p, memsize);
zcalloc := p;
end;
end.

129
Imaging/ZLib/readme.txt Normal file
View File

@@ -0,0 +1,129 @@
_____________________________________________________________________________
PASZLIB 1.0 May 11th, 1998
Based on the zlib 1.1.2, a general purpose data compression library.
Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C.
[kn&n DES] See "Legal issues" for conditions of distribution and use.
_____________________________________________________________________________
Introduction
============
The 'zlib' compression library provides in-memory compression and
decompression functions, including integrity checks of the uncompressed
data. This version of the library supports only one compression method
(deflation) but other algorithms will be added later and will have the same
stream interface.
Compression can be done in a single step if the buffers are large
enough (for example if an input file is mmap'ed), or can be done by
repeated calls of the compression function. In the latter case, the
application must provide more input and/or consume the output
(providing more output space) before each call.
The default memory requirements for deflate are 256K plus a few kilobytes
for small objects. The default memory requirements for inflate are 32K
plus a few kilobytes for small objects.
Change Log
==========
March 24th 2000 - minizip code by Gilles Vollant ported to Pascal.
z_stream.msg defined as string[255] to avoid problems
with Delphi 2+ dynamic string handling.
changes to silence Delphi 5 compiler warning. If you
have Delphi 5, defines Delphi5 in zconf.inc
May 7th 1999 - Some changes for FPC
deflateCopy() has new parameters
trees.pas - record constant definition
June 17th 1998 - Applied official 1.1.2 patch.
Memcheck turned off by default.
zutil.pas patch for Delphi 1 memory allocation corrected.
dzlib.txt file added.
compress2() is now exported
June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was
missing in line 574;
File list
=========
Here is a road map to the files in the Paszlib distribution.
readme.txt Introduction, Documentation
dzlib.txt Changes to Delphi sources for Paszlib stream classes
include file
zconf.inc Configuration declarations.
Pascal source code files:
adler.pas compute the Adler-32 checksum of a data stream
crc.pas compute the CRC-32 of a data stream
gzio.pas IO on .gz files
infblock.pas interpret and process block types to last block
infcodes.pas process literals and length/distance pairs
inffast.pas process literals and length/distance pairs fast
inftrees.pas generate Huffman trees for efficient decoding
infutil.pas types and macros common to blocks and codes
strutils.pas string utilities
trees.pas output deflated data using Huffman coding
zcompres.pas compress a memory buffer
zdeflate.pas compress data using the deflation algorithm
zinflate.pas zlib interface to inflate modules
zlib.pas zlib data structures. read the comments there!
zuncompr.pas decompress a memory buffer
zutil.pas
minizip/ziputils.pas data structure and IO on .zip file
minizip/unzip.pas
minizip/zip.pas
Test applications
example.pas usage example of the zlib compression library
minigzip.pas simulate gzip using the zlib compression library
minizip/miniunz.pas simulates unzip using the zlib compression library
minizip/minizip.pas simulates zip using the zlib compression library
Legal issues
============
Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali
This software is provided 'as-is', without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source distribution.
Archive Locations:
==================
Check the Paszlib home page with links
http://www.tu-chemnitz.de/~nomssi/paszlib.html
The data format used by the zlib library is described by RFCs (Request for
Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt
(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
These documents are also available in other formats from
ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html.
____________________________________________________________________________
Jacques Nomssi Nzali <mailto:nomssi@physik.tu-chemnitz.de> March 24th, 2000