summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 01db5bc)
raw | patch | inline | side by side (parent: 01db5bc)
| author | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Fri, 22 Apr 2016 09:23:10 +0000 (12:23 +0300) | ||
| committer | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Fri, 22 Apr 2016 09:30:08 +0000 (12:30 +0300) |
95 files changed:
diff --git a/build.bat b/build.bat
index dbb5a2acd1ba614a9431ca0e93b85fdf2f0b323a..b58fbd9e47ad13a2cf8c7befb62029babb315e10 100644 (file)
--- a/build.bat
+++ b/build.bat
@echo off
cd "./src/game"
-fpc -dUSE_FMOD -MDELPHI -O2 -FE../../bin -FU../../tmp Doom2DF.dpr
+fpc -dUSE_FMOD -MDELPHI -O2 -Fi../lib/vampimg -Fi../lib/vampimg/JpegLib -Fi../lib/vampimg/ZLib -Fu../lib/vampimg -Fu../lib/vampimg/JpegLib -Fu../lib/vampimg/ZLib -FE../../bin -FU../../tmp Doom2DF.dpr
cd ".."
pause
\ No newline at end of file
diff --git a/build_headless.bat b/build_headless.bat
index 9580d698118e4261eb1b7f9fe4ca7c2ecb241b97..d5c317fbb8ad4b943afa54e609d539cb3e0e4fc5 100644 (file)
--- a/build_headless.bat
+++ b/build_headless.bat
@echo off
cd "./src/game"
-fpc -dUSE_FMOD -dHEADLESS -MDELPHI -O2 -FE../../bin -FU../../tmp -oDoom2DF_H.exe Doom2DF.dpr
+fpc -dUSE_FMOD -dHEADLESS -MDELPHI -O2 -Fi../lib/vampimg -Fi../lib/vampimg/JpegLib -Fi../lib/vampimg/ZLib -Fu../lib/vampimg -Fu../lib/vampimg/JpegLib -Fu../lib/vampimg/ZLib -FE../../bin -FU../../tmp -oDoom2DF_H.exe Doom2DF.dpr
cd ".."
pause
\ No newline at end of file
index cdfe09bcfb31823a3e3718f933782951e94eea52..d7bced43a353957e88aac4426d93027eb75a7ae0 100644 (file)
function e_CreateTexture(FileName: string; var ID: DWORD): Boolean;
function e_CreateTextureEx(FileName: string; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
-function e_CreateTextureMem(pData: Pointer; var ID: DWORD): Boolean;
-function e_CreateTextureMemEx(pData: Pointer; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
+function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean;
+function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
procedure e_GetTextureSize(ID: DWORD; Width, Height: PWord);
function e_GetTextureSize2(ID: DWORD): TRectWH;
procedure e_DeleteTexture(ID: DWORD);
Result := True;
end;
-function e_CreateTextureMem(pData: Pointer; var ID: DWORD): Boolean;
+function e_CreateTextureMem(pData: Pointer; dataSize: LongInt; var ID: DWORD): Boolean;
var
find_id: DWORD;
fmt: Word;
find_id := FindTexture;
- if not LoadTextureMem(pData, e_Textures[find_id].tx, e_Textures[find_id].Width,
- e_Textures[find_id].Height, @fmt) then exit;
+ if not LoadTextureMem(pData, dataSize, e_Textures[find_id].tx, e_Textures[find_id].Width, e_Textures[find_id].Height, @fmt) then exit;
id := find_id;
e_Textures[id].Fmt := fmt;
Result := True;
end;
-function e_CreateTextureMemEx(pData: Pointer; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
+function e_CreateTextureMemEx(pData: Pointer; dataSize: LongInt; var ID: DWORD; fX, fY, fWidth, fHeight: Word): Boolean;
var
find_id: DWORD;
fmt: Word;
find_id := FindTexture();
- if not LoadTextureMemEx(pData, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit;
+ if not LoadTextureMemEx(pData, dataSize, e_Textures[find_id].tx, fX, fY, fWidth, fHeight, @fmt) then exit;
e_Textures[find_id].Width := fWidth;
e_Textures[find_id].Height := fHeight;
index e53a3ef263fdd9033c454fe49b70b929c0f74685..19efb4b1659cd844b340281ee9ec243f6fceb5c2 100644 (file)
e_DummyTextures: Boolean = False;
TEXTUREFILTER: Integer = GL_NEAREST;
-function CreateTexture(var tex: GLTexture; Width, Height, aFormat: Word; pData: Pointer ): Boolean;
+function CreateTexture (var tex: GLTexture; Width, Height, aFormat: Word; pData: Pointer): Boolean;
// Standard set of images loading functions
-function LoadTexture( Filename: String; var Texture: GLTexture;
- var pWidth, pHeight: Word; Fmt: PWord = nil ): Boolean;
-
-function LoadTextureEx( Filename: String; var Texture: GLTexture;
- fX, fY, fWidth, fHeight: Word; Fmt: PWord = nil ): Boolean;
-
-function LoadTextureMem( pData: Pointer; var Texture: GLTexture;
- var pWidth, pHeight: Word; Fmt: PWord = nil ): Boolean;
-
-function LoadTextureMemEx( pData: Pointer; var Texture: GLTexture;
- fX, fY, fWidth, fHeight: Word; Fmt: PWord = nil ): Boolean;
+function LoadTexture (Filename: String; var Texture: GLTexture; var pWidth, pHeight: Word; Fmt: PWord=nil): Boolean;
+function LoadTextureEx (Filename: String; var Texture: GLTexture; fX, fY, fWidth, fHeight: Word; Fmt: PWord=nil): Boolean;
+function LoadTextureMem (pData: Pointer; dataSize: LongInt; var Texture: GLTexture; var pWidth, pHeight: Word; Fmt: PWord=nil): Boolean;
+function LoadTextureMemEx (pData: Pointer; dataSize: LongInt; var Texture: GLTexture; fX, fY, fWidth, fHeight: Word; Fmt: PWord=nil): Boolean;
implementation
-uses BinEditor, g_options;
+uses
+ Classes, BinEditor, g_options, utils,
+ ImagingTypes, Imaging, ImagingUtility;
function AlignP2 (n: Word): Word;
end;
+{
type
TTGAHeader = packed record
FileType: Byte;
BPP: Byte;
ImageInfo: Byte;
end;
+}
+
// This is auxiliary function that creates OpenGL texture from raw image data
function CreateTexture (var tex: GLTexture; Width, Height, aFormat: Word; pData: Pointer): Boolean;
Result := true;
end;
-function LoadTextureMem( pData: Pointer; var Texture: GLTexture;
- var pWidth, pHeight: Word; Fmt: PWord = nil ): Boolean;
+function LoadTextureMem (pData: Pointer; dataSize: LongInt; var Texture: GLTexture; var pWidth, pHeight: Word; Fmt: PWord=nil): Boolean;
var
- TGAHeader: TTGAHeader;
- image: Pointer;
- Width, Height: Integer;
- ImageSize: Integer;
- i: Integer;
- Front: ^Byte;
- Back: ^Byte;
- Temp: Byte;
- BPP: Byte;
- TFmt: Word;
-
+ image, ii: PByte;
+ width, height: Integer;
+ imageSize: Integer;
+ img: TImageData;
+ x, y: Integer;
+ clr: TColor32Rec;
begin
- Result := False;
+ result := false;
pWidth := 0;
pHeight := 0;
+ if Fmt <> nil then Fmt^ := GL_RGBA; // anyway
- CopyMemory( @TGAHeader, pData, SizeOf(TGAHeader) );
-
- if ( TGAHeader.ImageType <> 2 ) then
- begin
- e_WriteLog( 'Error loading texture: Bad ImageType', MSG_WARNING );
- Exit;
- end;
-
- if ( TGAHeader.ColorMapType <> 0 ) then
+ InitImage(img);
+ if not LoadImageFromMemory(pData, dataSize, img) then
begin
- e_WriteLog( 'Error loading texture: Bad ColorMapType', MSG_WARNING );
- Exit;
+ e_WriteLog('Error loading texture: unknown image format', MSG_WARNING);
+ exit;
end;
-
- if ( TGAHeader.BPP < 24 ) then
- begin
- e_WriteLog( 'Error loading texture: BPP less than 24', MSG_WARNING );
- Exit;
- end;
-
- if (TGAHeader.ImageInfo and $c0) <> 0 then
- begin
- e_WriteLog('Error loading texture: interleaved TGA', MSG_WARNING);
- Exit;
- end;
-
- Width := TGAHeader.Width[0] + TGAHeader.Width[1] * 256;
- Height := TGAHeader.Height[0] + TGAHeader.Height[1] * 256;
- BPP := TGAHeader.BPP;
-
- ImageSize := Width * Height * (BPP div 8);
-
- GetMem( Image, ImageSize );
- CopyMemory( Image, PByte(pData) + SizeOf(TGAHeader), ImageSize );
-
- for i := 0 to Width * Height - 1 do
- begin
- Front := PByte(Image) + i*(BPP div 8);
- Back := PByte(Image) + i*(BPP div 8) + 2;
- Temp := Front^;
- Front^ := Back^;
- Back^ := Temp;
+ try
+ if (img.width < 1) or (img.width > 32768) or (img.height < 1) or (img.height > 32768) then
+ begin
+ e_WriteLog('Error loading texture: invalid image dimensions', MSG_WARNING);
+ exit;
+ end;
+ //ConvertImage(img, ifA8R8G8B8);
+ width := img.width;
+ height := img.height;
+ pWidth := width;
+ pHeight := height;
+ imageSize := Width*Height*32;
+ GetMem(image, imageSize);
+ try
+ // it's slow, but i don't care for now
+ ii := image;
+ for y := height-1 downto 0 do
+ begin
+ for x := 0 to width-1 do
+ begin
+ clr := GetPixel32(img, x, y);
+ ii^ := clr.r; Inc(ii);
+ ii^ := clr.g; Inc(ii);
+ ii^ := clr.b; Inc(ii);
+ ii^ := clr.a; Inc(ii);
+ end;
+ end;
+ CreateTexture(Texture, width, height, GL_RGBA, image);
+ result := true;
+ finally
+ FreeMem(image);
+ end;
+ finally
+ FreeImage(img);
end;
-
- //if (TGAHeader.ImageInfo and $20) <> 0 then UpsideDown(Image, Width, Height);
-
- if ( BPP = 24 ) then
- TFmt := GL_RGB
- else
- TFmt := GL_RGBA;
-
- CreateTexture(Texture, Width, Height, TFmt, Image );
-
- FreeMem( Image );
-
- if Fmt <> nil then Fmt^ := TFmt;
-
- pWidth := Width;
- pHeight := Height;
-
- Result := True;
end;
-function LoadTextureMemEx( pData: Pointer; var Texture: GLTexture;
- fX, fY, fWidth, fHeight: Word; Fmt: PWord = nil ): Boolean;
-var
- TGAHeader: TTGAHeader;
- image, image2: Pointer;
- Width, Height: Integer;
- ImageSize: Integer;
- i, a, b: Integer;
- Front: ^Byte;
- Back: ^Byte;
- Temp: Byte;
- BPP: Byte;
- Base: PByte;
- TFmt: Word;
+function LoadTextureMemEx (pData: Pointer; dataSize: LongInt; var Texture: GLTexture; fX, fY, fWidth, fHeight: Word; Fmt: PWord=nil): Boolean;
+var
+ image, ii: PByte;
+ width, height: Integer;
+ imageSize: Integer;
+ img: TImageData;
+ x, y: Integer;
+ clr: TColor32Rec;
begin
- Result := False;
-
- CopyMemory( @TGAHeader, pData, SizeOf(TGAHeader) );
-
- if ( TGAHeader.ImageType <> 2 ) then
- begin
- e_WriteLog( 'Error loading texture: Bad ImageType', MSG_WARNING );
- Exit;
- end;
+ result := false;
+ if Fmt <> nil then Fmt^ := GL_RGBA; // anyway
- if ( TGAHeader.ColorMapType <> 0 ) then
+ InitImage(img);
+ if not LoadImageFromMemory(pData, dataSize, img) then
begin
- e_WriteLog( 'Error loading texture: Bad ColorMapType', MSG_WARNING );
- Exit;
- end;
-
- if ( TGAHeader.BPP < 24 ) then
- begin
- e_WriteLog( 'Error loading texture: BPP less than 24', MSG_WARNING );
- Exit;
- end;
-
- if (TGAHeader.ImageInfo and $c0) <> 0 then
- begin
- e_WriteLog('Error loading texture: interleaved TGA', MSG_WARNING);
- Exit;
+ e_WriteLog('Error loading texture: unknown image format', MSG_WARNING);
+ exit;
end;
-
- Width := TGAHeader.Width[0] + TGAHeader.Width[1] * 256;
- Height := TGAHeader.Height[0] + TGAHeader.Height[1] * 256;
- BPP := TGAHeader.BPP;
-
- if fX > Width then Exit;
- if fY > Height then Exit;
- if fX+fWidth > Width then Exit;
- if fY+fHeight > Height then Exit;
-
- ImageSize := Width * Height * (BPP div 8);
- GetMem( Image2, ImageSize );
- CopyMemory( Image2, PByte(pData) + SizeOf(TGAHeader), ImageSize );
-
- a := BPP div 8;
-
- for i := 0 to Width * Height - 1 do
- begin
- Front := PByte(Image2) + i * a;
- Back := PByte(Image2) + i * a + 2;
- Temp := Front^;
- Front^ := Back^;
- Back^ := Temp;
+ try
+ if (img.width < 1) or (img.width > 32768) or (img.height < 1) or (img.height > 32768) then
+ begin
+ e_WriteLog('Error loading texture: invalid image dimensions', MSG_WARNING);
+ exit;
+ end;
+ //ConvertImage(img, ifA8R8G8B8);
+ if fX > img.width then exit;
+ if fY > img.height then exit;
+ if fX+fWidth > img.width then exit;
+ if fY+fHeight > img.height then exit;
+ imageSize := img.width*img.height*32;
+ GetMem(image, imageSize);
+ try
+ // it's slow, but i don't care for now
+ ii := image;
+ for y := fY+fHeight-1 downto 0 do
+ begin
+ for x := fX to fX+fWidth-1 do
+ begin
+ clr := GetPixel32(img, x, y);
+ ii^ := clr.r; Inc(ii);
+ ii^ := clr.g; Inc(ii);
+ ii^ := clr.b; Inc(ii);
+ ii^ := clr.a; Inc(ii);
+ end;
+ end;
+ CreateTexture(Texture, fWidth, fHeight, GL_RGBA, image);
+ result := true;
+ finally
+ FreeMem(image);
+ end;
+ finally
+ FreeImage(img);
end;
-
- fY := Height - (fY + fHeight);
-
- ImageSize := fHeight * fWidth * (BPP div 8);
- GetMem( Image, ImageSize );
-
- Base := PByte( Image2 ) + fY * Width * (BPP div 8) + fX * (BPP div 8);
- a := fWidth * (BPP div 8);
- b := Width * (BPP div 8);
-
- for i := 0 to fHeight-1 do
- CopyMemory( PByte(image) + a*i, Base + b*i, a );
-
- //if (TGAHeader.ImageInfo and $20) <> 0 then UpsideDown(Image, Width, Height);
-
- if ( BPP = 24 ) then
- TFmt := GL_RGB
- else
- TFmt := GL_RGBA;
-
- CreateTexture(Texture, fWidth, fHeight, TFmt, Image );
-
- FreeMem( Image );
- FreeMem( Image2 );
-
- if Fmt <> nil then Fmt^ := TFmt;
-
- Result := True;
end;
-function LoadTexture( Filename: String; var Texture: GLTexture;
- var pWidth, pHeight: Word; Fmt: PWord = nil ): Boolean;
-var
- TGAHeader: TTGAHeader;
- TGAFile: File;
- bytesRead: Integer;
- image: Pointer;
- Width, Height: Integer;
- ImageSize: Integer;
- i: Integer;
- Front: ^Byte;
- Back: ^Byte;
- Temp: Byte;
- BPP: Byte;
- TFmt: Word;
+function LoadTexture (filename: AnsiString; var Texture: GLTexture; var pWidth, pHeight: Word; Fmt: PWord=nil): Boolean;
+var
+ fs: TStream;
+ img: Pointer;
+ imageSize: LongInt;
begin
- Result := False;
+ result := False;
pWidth := 0;
pHeight := 0;
+ if Fmt <> nil then Fmt^ := GL_RGBA; // anyway
+ fs := nil;
- if not FileExists(Filename) then
- begin
- e_WriteLog('Texture ' + Filename + ' not found', MSG_WARNING);
- Exit;
- end;
-
- AssignFile( TGAFile, Filename );
- Reset( TGAFile, 1 );
- BlockRead( TGAFile, TGAHeader, SizeOf(TGAHeader) );
-
- if ( TGAHeader.ImageType <> 2 ) then
- begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: Bad ImageType', MSG_WARNING );
- Exit;
+ try
+ fs := openDiskFileRO(filename);
+ except
+ fs := nil;
end;
-
- if ( TGAHeader.ColorMapType <> 0 ) then
+ if fs = nil then
begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: Bad ColorMapType', MSG_WARNING );
- Exit;
- end;
-
- if ( TGAHeader.BPP < 24 ) then
- begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: BPP less than 24', MSG_WARNING );
- Exit;
+ e_WriteLog('Texture "'+filename+'" not found', MSG_WARNING);
+ exit;
end;
- Width := TGAHeader.Width[0] + TGAHeader.Width[1] * 256;
- Height := TGAHeader.Height[0] + TGAHeader.Height[1] * 256;
- BPP := TGAHeader.BPP;
-
- ImageSize := Width * Height * (BPP div 8);
-
- GetMem( Image, ImageSize );
-
- BlockRead( TGAFile, image^, ImageSize, bytesRead );
- if ( bytesRead <> ImageSize ) then
- begin
- CloseFile( TGAFile );
- Exit;
- end;
-
- CloseFile( TGAFile );
-
- for i := 0 to Width * Height - 1 do
- begin
- Front := PByte(Image) + i * (BPP div 8);
- Back := PByte(Image) + i * (BPP div 8) + 2;
- Temp := Front^;
- Front^ := Back^;
- Back^ := Temp;
+ try
+ imageSize := fs.size;
+ GetMem(img, imageSize);
+ try
+ fs.readBuffer(img^, imageSize);
+ result := LoadTextureMem(img, imageSize, Texture, pWidth, pHeight, Fmt);
+ finally
+ FreeMem(img);
+ end;
+ finally
+ fs.Free();
end;
-
- if ( BPP = 24 ) then
- TFmt := GL_RGB
- else
- TFmt := GL_RGBA;
-
- CreateTexture(Texture, Width, Height, TFmt, Image );
-
- FreeMem( Image );
-
- if Fmt <> nil then Fmt^ := TFmt;
-
- pWidth := Width;
- pHeight := Height;
-
- Result := True;
end;
-function LoadTextureEx( Filename: String; var Texture: GLTexture;
- fX, fY, fWidth, fHeight: Word; Fmt: PWord = nil ): Boolean;
-var
- TGAHeader: TTGAHeader;
- TGAFile: File;
- image, image2: Pointer;
- Width, Height: Integer;
- ImageSize: Integer;
- i: Integer;
- Front: ^Byte;
- Back: ^Byte;
- Temp: Byte;
- BPP: Byte;
- Base: PByte;
- TFmt: Word;
+function LoadTextureEx (filename: AnsiString; var Texture: GLTexture; fX, fY, fWidth, fHeight: Word; Fmt: PWord=nil): Boolean;
+var
+ fs: TStream;
+ img: Pointer;
+ imageSize: LongInt;
begin
- Result := False;
-
- if not FileExists(Filename) then
- begin
- e_WriteLog( 'Texture ' + Filename + ' not found', MSG_WARNING );
- Exit;
- end;
-
- AssignFile( TGAFile, Filename );
- Reset( TGAFile, 1 );
- BlockRead( TGAFile, TGAHeader, SizeOf(TGAHeader) );
-
- if ( TGAHeader.ImageType <> 2 ) then
- begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: Bad ImageType', MSG_WARNING );
- Exit;
- end;
-
- if ( TGAHeader.ColorMapType <> 0 ) then
- begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: Bad ColorMapType', MSG_WARNING );
- Exit;
- end;
-
- if ( TGAHeader.BPP < 24 ) then
- begin
- CloseFile( TGAFile );
- e_WriteLog( 'Error loading texture: BPP less than 24', MSG_WARNING );
- Exit;
+ result := False;
+ if Fmt <> nil then Fmt^ := GL_RGBA; // anyway
+ fs := nil;
+
+ try
+ fs := openDiskFileRO(filename);
+ except
+ fs := nil;
end;
-
- Width := TGAHeader.Width[0] + TGAHeader.Width[1] * 256;
- Height := TGAHeader.Height[0] + TGAHeader.Height[1] * 256;
- BPP := TGAHeader.BPP;
-
- if fX > Width then Exit;
- if fY > Height then Exit;
- if fX+fWidth > Width then Exit;
- if fY+fHeight > Height then Exit;
-
- ImageSize := Width * Height * (BPP div 8);
- GetMem( Image2, ImageSize );
- BlockRead( TGAFile, Image2^, ImageSize );
-
- CloseFile( TGAFile );
-
- for i := 0 to Width * Height - 1 do
+ if fs = nil then
begin
- Front := PByte(Image2) + i * (BPP div 8);
- Back := PByte(Image2) + i * (BPP div 8) + 2;
- Temp := Front^;
- Front^ := Back^;
- Back^ := Temp;
+ e_WriteLog('Texture "'+filename+'" not found', MSG_WARNING);
+ exit;
end;
- fY := Height - (fY + fHeight);
-
- ImageSize := fHeight * fWidth * (BPP div 8);
- GetMem( Image, ImageSize );
-
- Base := PByte(Image2) + fY * Width * (BPP div 8) + fX * (BPP div 8);
-
- for i := 0 to fHeight-1 do
- begin
- CopyMemory( PByte(image) + fWidth * (BPP div 8) * i,
- Base + Width * (BPP div 8) * i, fWidth * (BPP div 8) );
+ try
+ imageSize := fs.size;
+ GetMem(img, imageSize);
+ try
+ fs.readBuffer(img^, imageSize);
+ result := LoadTextureMemEx(img, imageSize, Texture, fX, fY, fWidth, fHeight, Fmt);
+ finally
+ FreeMem(img);
+ end;
+ finally
+ fs.Free();
end;
-
- if ( BPP = 24 ) then
- TFmt := GL_RGB
- else
- TFmt := GL_RGBA;
-
- CreateTexture(Texture, fWidth, fHeight, TFmt, Image );
-
- FreeMem( Image );
- FreeMem( Image2 );
-
- if Fmt <> nil then Fmt^ := TFmt;
-
- Result := True;
end;
end.
diff --git a/src/game/Doom2DF.dpr b/src/game/Doom2DF.dpr
index ac174d86c59a4e1139f7d18bd9a984b6e9376c87..1c062498bddd7673711a5412121e4bed26b758d2 100644 (file)
--- a/src/game/Doom2DF.dpr
+++ b/src/game/Doom2DF.dpr
{$ENDIF}
BinEditor in '../shared/BinEditor.pas',
g_panel in 'g_panel.pas',
- g_language in 'g_language.pas';
+ g_language in 'g_language.pas',
+ ImagingTypes,
+ Imaging,
+ ImagingUtility;
{$IFDEF WINDOWS}
{$R *.res}
diff --git a/src/game/g_map.pas b/src/game/g_map.pas
index 25b1bfe8e086400f050d115a78c9ffc64010d0ab..8445e7825e307e89348d740d87c6779970f3362c 100644 (file)
--- a/src/game/g_map.pas
+++ b/src/game/g_map.pas
if WAD.GetResource(SectionName, TextureName, TextureData, ResLength) then
begin
SetLength(Textures, Length(Textures)+1);
- if not e_CreateTextureMem(TextureData, Textures[High(Textures)].TextureID) then
+ if not e_CreateTextureMem(TextureData, ResLength, Textures[High(Textures)].TextureID) then
Exit;
e_GetTextureSize(Textures[High(Textures)].TextureID,
@Textures[High(Textures)].Width,
with Textures[High(Textures)] do
begin
// Ñîçäàåì êàäðû àíèì. òåêñòóðû èç ïàìÿòè:
- if g_Frames_CreateMemory(@FramesID, '', TextureData,
+ if g_Frames_CreateMemory(@FramesID, '', TextureData, ResLength,
_width, _height, _framecount, _backanimation) then
begin
TextureName := RecName;
diff --git a/src/game/g_menu.pas b/src/game/g_menu.pas
index 62e4e8d6c0e80852a63bd2ae6064079d7323a2bf..8b3dc3163d65a40d806a81aacabf4d4a66f34108 100644 (file)
--- a/src/game/g_menu.pas
+++ b/src/game/g_menu.pas
chrwidth := config.ReadInt(IntToStr(a), 'Width', 0);
if chrwidth = 0 then Continue;
- if e_CreateTextureMemEx(fntdata, CharID, cwdt*(a mod 16), chgt*(a div 16),
+ if e_CreateTextureMemEx(fntdata, fntlen, CharID, cwdt*(a mod 16), chgt*(a div 16),
cwdt, chgt) then
e_CharFont_AddChar(FontID, CharID, Chr(a), chrwidth);
end;
index 7cb1eda9e73daef7156d92e48cb59b49b497cb09..8345e785c504fa6b621aeb77bb7c979dc19f2bb7 100644 (file)
function g_PlayerModel_Load(FileName: string): Boolean;
var
ID: DWORD;
- a, b, len, aa, bb, f: Integer;
+ a, b, len, lenpd, lenpd2, aa, bb, f: Integer;
cc: TDirection;
config: TConfig;
pData, pData2: Pointer;
SetLength(Gibs, ReadInt('Gibs', 'count', 0));
if (Gibs <> nil) and
- (WAD.GetResource('TEXTURES', config.ReadStr('Gibs', 'resource', 'GIBS'), pData, len)) and
- (WAD.GetResource('TEXTURES', config.ReadStr('Gibs', 'mask', 'GIBSMASK'), pData2, len)) then
+ (WAD.GetResource('TEXTURES', config.ReadStr('Gibs', 'resource', 'GIBS'), pData, lenpd)) and
+ (WAD.GetResource('TEXTURES', config.ReadStr('Gibs', 'mask', 'GIBSMASK'), pData2, lenpd2)) then
begin
for a := 0 to High(Gibs) do
- if e_CreateTextureMemEx(pData, Gibs[a].ID, a*32, 0, 32, 32) and
- e_CreateTextureMemEx(pData2, Gibs[a].MaskID, a*32, 0, 32, 32) then
+ if e_CreateTextureMemEx(pData, lenpd, Gibs[a].ID, a*32, 0, 32, 32) and
+ e_CreateTextureMemEx(pData2, lenpd2, Gibs[a].MaskID, a*32, 0, 32, 32) then
begin
Gibs[a].Rect := e_GetTextureSize2(Gibs[a].ID);
with Gibs[a].Rect do
index fba31e47a6c3ce8bee637f07cc4bf5dcce966124..bdf6605849405c044781a9cc89723a2a29c50060 100644 (file)
--- a/src/game/g_textures.pas
+++ b/src/game/g_textures.pas
FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
function g_Frames_CreateFile(ID: PDWORD; Name: ShortString; FileName: String;
FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
-function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer;
+function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer; dataSize: LongInt;
FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
//function g_Frames_CreateRevert(ID: PDWORD; Name: ShortString; Frames: string): Boolean;
function g_Frames_Get(var ID: DWORD; FramesName: ShortString): Boolean;
if WAD.GetResource(SectionName, ResourceName, TextureData, ResourceLength) then
begin
- if e_CreateTextureMem(TextureData, ID) then
+ if e_CreateTextureMem(TextureData, ResourceLength, ID) then
Result := True
else
FreeMem(TextureData);
if WAD.GetResource(SectionName, ResourceName, TextureData, ResourceLength) then
begin
- Result := e_CreateTextureMem(TextureData, TexturesArray[find_id].ID);
+ Result := e_CreateTextureMem(TextureData, ResourceLength, TexturesArray[find_id].ID);
if Result then
begin
e_GetTextureSize(TexturesArray[find_id].ID, @TexturesArray[find_id].Width,
Result := True;
end;
-function CreateFramesMem(pData: Pointer; ID: PDWORD; Name: ShortString;
+function CreateFramesMem(pData: Pointer; dataSize: LongInt; ID: PDWORD; Name: ShortString;
FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
var
find_id: DWORD;
else SetLength(FramesArray[find_id].TexturesID, FCount);
for a := 0 to FCount-1 do
- if not e_CreateTextureMemEx(pData, FramesArray[find_id].TexturesID[a],
+ if not e_CreateTextureMemEx(pData, dataSize, FramesArray[find_id].TexturesID[a],
a*FWidth, 0, FWidth, FHeight) then
begin
FreeMem(pData);
Exit;
end;
- if not CreateFramesMem(TextureData, ID, Name, FWidth, FHeight, FCount, BackAnimation) then
+ if not CreateFramesMem(TextureData, ResourceLength, ID, Name, FWidth, FHeight, FCount, BackAnimation) then
begin
WAD.Free();
Exit;
Result := True;
end;
-function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer;
+function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer; dataSize: LongInt;
FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
begin
- Result := CreateFramesMem(pData, ID, Name, FWidth, FHeight, FCount, BackAnimation);
+ Result := CreateFramesMem(pData, dataSize, ID, Name, FWidth, FHeight, FCount, BackAnimation);
end;
{function g_Frames_CreateRevert(ID: PDWORD; Name: ShortString; Frames: string): Boolean;
diff --git a/src/lib/vampimg/Imaging.pas b/src/lib/vampimg/Imaging.pas
--- /dev/null
@@ -0,0 +1,3608 @@
+{
+ $Id: Imaging.pas 173 2009-09-04 17:05: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 is heart of Imaging library. It contains basic functions for
+ manipulating image data as well as various image file format support.}
+unit Imaging;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, SysUtils, Classes;
+
+type
+ { Default Imaging excepton class.}
+ EImagingError = class(Exception);
+
+ { Dynamic array of TImageData records.}
+ TDynImageDataArray = array of TImageData;
+
+
+{ ------------------------------------------------------------------------
+ Low Level Interface Functions
+ ------------------------------------------------------------------------}
+
+{ General Functions }
+
+{ Initializes image (all is set to zeroes). Call this for each image
+ before using it (before calling every other function) to be sure there
+ are no random-filled bytes (which would cause errors later).}
+procedure InitImage(var Image: TImageData);
+{ Creates empty image of given dimensions and format. Image is filled with
+ transparent black color (A=0, R=0, G=0, B=0).}
+function NewImage(Width, Height: LongInt; Format: TImageFormat;
+ var Image: TImageData): Boolean;
+{ Returns True if given TImageData record is valid.}
+function TestImage(const Image: TImageData): Boolean;
+{ Frees given image data. Ater this call image is in the same state
+ as after calling InitImage. If image is not valid (dost not pass TestImage
+ test) it is only zeroed by calling InitImage.}
+procedure FreeImage(var Image: TImageData);
+{ Call FreeImage() on all images in given dynamic array and sets its
+ length to zero.}
+procedure FreeImagesInArray(var Images: TDynImageDataArray);
+{ Returns True if all TImageData records in given array are valid. Returns False
+ if at least one is invalid or if array is empty.}
+function TestImagesInArray(const Images: TDynImageDataArray): Boolean;
+{ Checks given file for every supported image file format and if
+ the file is in one of them returns its string identifier
+ (which can be used in LoadFromStream/LoadFromMem type functions).
+ If file is not in any of the supported formats empty string is returned.}
+function DetermineFileFormat(const FileName: string): string;
+{ Checks given stream for every supported image file format and if
+ the stream is in one of them returns its string identifier
+ (which can be used in LoadFromStream/LoadFromMem type functions).
+ If stream is not in any of the supported formats empty string is returned.}
+function DetermineStreamFormat(Stream: TStream): string;
+{ Checks given memory for every supported image file format and if
+ the memory is in one of them returns its string identifier
+ (which can be used in LoadFromStream/LoadFromMem type functions).
+ If memory is not in any of the supported formats empty string is returned.}
+function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string;
+{ Checks that an apropriate file format is supported purely from inspecting
+ the given file name's extension (not contents of the file itself).
+ The file need not exist.}
+function IsFileFormatSupported(const FileName: string): Boolean;
+{ Enumerates all registered image file formats. Descriptive name,
+ default extension, masks (like '*.jpg,*.jfif') and some capabilities
+ of each format are returned. To enumerate all formats start with Index at 0 and
+ call EnumFileFormats with given Index in loop until it returns False (Index is
+ automatically increased by 1 in function's body on successful call).}
+function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string;
+ var CanSaveImages, IsMultiImageFormat: Boolean): Boolean;
+
+{ Loading Functions }
+
+{ Loads single image from given file.}
+function LoadImageFromFile(const FileName: string; var Image: TImageData): Boolean;
+{ Loads single image from given stream. If function fails stream position
+ is not changed.}
+function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean;
+{ Loads single image from given memory location.}
+function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
+{ Loads multiple images from given file.}
+function LoadMultiImageFromFile(const FileName: string;
+ var Images: TDynImageDataArray): Boolean;
+{ Loads multiple images from given stream. If function fails stream position
+ is not changed.}
+function LoadMultiImageFromStream(Stream: TStream;
+ var Images: TDynImageDataArray): Boolean;
+{ Loads multiple images from given memory location.}
+function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
+ var Images: TDynImageDataArray): Boolean;
+
+{ Saving Functions }
+
+{ Saves single image to given file.}
+function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean;
+{ Saves single image to given stream. If function fails stream position
+ is not changed. Ext identifies desired image file format (jpg, png, dds, ...).}
+function SaveImageToStream(const Ext: string; Stream: TStream;
+ const Image: TImageData): Boolean;
+{ Saves single image to given memory location. Memory must be allocated and its
+ size is passed in Size parameter in which number of written bytes is returned.
+ Ext identifies desired image file format (jpg, png, dds, ...).}
+function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt;
+ const Image: TImageData): Boolean;
+{ Saves multiple images to given file. If format supports
+ only single level images and there are multiple images to be saved,
+ they are saved as sequence of files img000.jpg, img001.jpg ....).}
+function SaveMultiImageToFile(const FileName: string;
+ const Images: TDynImageDataArray): Boolean;
+{ Saves multiple images to given stream. If format supports
+ only single level images and there are multiple images to be saved,
+ they are saved one after another to the stream. If function fails stream
+ position is not changed. Ext identifies desired image file format (jpg, png, dds, ...).}
+function SaveMultiImageToStream(const Ext: string; Stream: TStream;
+ const Images: TDynImageDataArray): Boolean;
+{ Saves multiple images to given memory location. If format supports
+ only single level images and there are multiple images to be saved,
+ they are saved one after another to the memory. Memory must be allocated and
+ its size is passed in Size parameter in which number of written bytes is returned.
+ Ext identifies desired image file format (jpg, png, dds, ...).}
+function SaveMultiImageToMemory(const Ext: string; Data: Pointer;
+ var Size: LongInt; const Images: TDynImageDataArray): Boolean;
+
+{ Manipulation Functions }
+
+{ Creates identical copy of image data. Clone should be initialized
+ by InitImage or it should be vaild image which will be freed by CloneImage.}
+function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
+{ Converts image to the given format.}
+function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
+{ Flips given image. Reverses the image along its horizontal axis \97 the top
+ becomes the bottom and vice versa.}
+function FlipImage(var Image: TImageData): Boolean;
+{ Mirrors given image. Reverses the image along its vertical axis \97 the left
+ side becomes the right and vice versa.}
+function MirrorImage(var Image: TImageData): Boolean;
+{ Resizes given image to new dimensions. Nearest, bilinear, or bicubic filtering
+ can be used. Input Image must already be created - use NewImage to create new images.}
+function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
+ Filter: TResizeFilter): Boolean;
+{ Swaps SrcChannel and DstChannel color or alpha channels of image.
+ Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
+ identify channels.}
+function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean;
+{ Reduces the number of colors of the Image. Currently MaxColors must be in
+ range <2, 4096>. Color reduction works also for alpha channel. Note that for
+ large images and big number of colors it can be very slow.
+ Output format of the image is the same as input format.}
+function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
+{ Generates mipmaps for image. Levels is the number of desired mipmaps levels
+ with zero (or some invalid number) meaning all possible levels.}
+function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
+ var MipMaps: TDynImageDataArray): Boolean;
+{ Maps image to existing palette producing image in ifIndex8 format.
+ Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.
+ As resulting image is in 8bit indexed format Entries must be lower or
+ equal to 256.}
+function MapImageToPalette(var Image: TImageData; Pal: PPalette32;
+ Entries: LongInt): Boolean;
+{ Splits image into XChunks x YChunks subimages. Default size of each chunk is
+ ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of
+ the image are also ChunkWidth x ChunkHeight sized and empty space is filled
+ with Fill pixels. After calling this function XChunks contains number of
+ chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this
+ index: Chunks[Y * XChunks + X].}
+function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
+ ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
+ PreserveSize: Boolean; Fill: Pointer): Boolean;
+{ Creates palette with MaxColors based on the colors of images in Images array.
+ Use it when you want to convert several images to indexed format using
+ single palette for all of them. If ConvertImages is True images in array
+ are converted to indexed format using resulting palette. if it is False
+ images are left intact and only resulting palatte is returned in Pal.
+ Pal must be allocated to have at least MaxColors entries.}
+function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
+ MaxColors: LongInt; ConvertImages: Boolean): Boolean;
+{ Rotates image by Angle degrees counterclockwise. All angles are allowed.}
+function RotateImage(var Image: TImageData; Angle: Single): Boolean;
+
+{ Drawing/Pixel functions }
+
+{ 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).}
+function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
+ var DstImage: TImageData; DstX, DstY: LongInt): Boolean;
+{ Fills given rectangle of image with given pixel fill data. Fill should point
+ to the pixel in the same format as the given image is in.}
+function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; FillColor: Pointer): Boolean;
+{ 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.}
+function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
+ OldColor, NewColor: Pointer): Boolean;
+{ 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).}
+function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TResizeFilter): Boolean;
+{ Copies pixel of Image at [X, Y] to memory pointed at by Pixel. Doesn't
+ work with special formats.}
+procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+{ Copies pixel from memory pointed at by Pixel to Image at position [X, Y].
+ Doesn't work with special formats.}
+procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to 32 bit ARGB. Works for all image formats (except special)
+ so it is not very fast.}
+function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec;
+{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
+ native format and then written to Image. Works for all image formats (except special)
+ so it is not very fast.}
+procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to FP ARGB. Works for all image formats (except special)
+ so it is not very fast.}
+function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec;
+{ Procedure for setting pixel colors. Input FP ARGB color is translated to
+ native format and then written to Image. Works for all image formats (except special)
+ so it is not very fast.}
+procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
+
+{ Palette Functions }
+
+{ Allocates new palette with Entries ARGB color entries.}
+procedure NewPalette(Entries: LongInt; var Pal: PPalette32);
+{ Frees given palette.}
+procedure FreePalette(var Pal: PPalette32);
+{ Copies Count palette entries from SrcPal starting at index SrcIdx to
+ DstPal at index DstPal.}
+procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt);
+{ Returns index of color in palette or index of nearest color if exact match
+ is not found. Pal must have at least Entries color entries.}
+function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
+{ Creates grayscale palette where each color channel has the same value.
+ Pal must have at least Entries color entries.}
+procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt);
+{ Creates palette with given bitcount for each channel.
+ 2^(RBits + GBits + BBits) should be equl to Entries. Examples:
+ (3, 3, 2) will create palette with all possible colors of R3G3B2 format
+ and (8, 0, 0) will create palette with 256 shades of red.
+ Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
+procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
+ BBits: Byte; Alpha: Byte = $FF);
+{ Swaps SrcChannel and DstChannel color or alpha channels of palette.
+ Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
+ identify channels. Pal must be allocated to at least
+ Entries * SizeOf(TColor32Rec) bytes.}
+procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
+ DstChannel: LongInt);
+
+{ Options Functions }
+
+{ Sets value of integer option specified by OptionId parameter.
+ Option Ids are constans starting ImagingXXX.}
+function SetOption(OptionId, Value: LongInt): Boolean;
+{ Returns value of integer option specified by OptionId parameter. If OptionId is
+ invalid, InvalidOption is returned. Option Ids are constans
+ starting ImagingXXX.}
+function GetOption(OptionId: LongInt): LongInt;
+{ Pushes current values of all options on the stack. Returns True
+ if successfull (max stack depth is 8 now). }
+function PushOptions: Boolean;
+{ Pops back values of all options from the top of the stack. Returns True
+ if successfull (max stack depth is 8 now). }
+function PopOptions: Boolean;
+
+{ Image Format Functions }
+
+{ Returns short information about given image format.}
+function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
+{ Returns size in bytes of Width x Height area of pixels. Works for all formats.}
+function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+
+{ IO Functions }
+
+{ User can set his own file IO functions used when loading from/saving to
+ files by this function.}
+procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
+ TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc:
+ TSeekProc; TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
+{ Sets file IO functions to Imaging default.}
+procedure ResetFileIO;
+
+
+{ ------------------------------------------------------------------------
+ Other Imaging Stuff
+ ------------------------------------------------------------------------}
+
+type
+ { Set of TImageFormat enum.}
+ TImageFormats = set of TImageFormat;
+
+ { Record containg set of IO functions internaly used by image loaders/savers.}
+ TIOFunctions = record
+ OpenRead: TOpenReadProc;
+ OpenWrite: TOpenWriteProc;
+ Close: TCloseProc;
+ Eof: TEofProc;
+ Seek: TSeekProc;
+ Tell: TTellProc;
+ Read: TReadProc;
+ Write: TWriteProc;
+ end;
+ PIOFunctions = ^TIOFunctions;
+
+ { Base class for various image file format loaders/savers which
+ descend from this class. If you want to add support for new image file
+ format the best way is probably to look at TImageFileFormat descendants'
+ implementations that are already part of Imaging.}
+ {$TYPEINFO ON}
+ TImageFileFormat = class(TObject)
+ private
+ FExtensions: TStringList;
+ FMasks: TStringList;
+ { Does various checks and actions before LoadData method is called.}
+ function PrepareLoad(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstFrame: Boolean): Boolean;
+ { Processes some actions according to result of LoadData.}
+ function PostLoadCheck(var Images: TDynImageDataArray; LoadResult: Boolean): Boolean;
+ { Helper function to be called in SaveData methods of descendants (ensures proper
+ index and sets FFirstIdx and FLastIdx for multi-images).}
+ function PrepareSave(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ var Index: LongInt): Boolean;
+ protected
+ FName: string;
+ FCanLoad: Boolean;
+ FCanSave: Boolean;
+ FIsMultiImageFormat: Boolean;
+ FSupportedFormats: TImageFormats;
+ FFirstIdx, FLastIdx: LongInt;
+ { Defines filename masks for this image file format. AMasks should be
+ in format '*.ext1,*.ext2,umajo.*'.}
+ procedure AddMasks(const AMasks: string);
+ function GetFormatInfo(Format: TImageFormat): TImageFormatInfo;
+ { Returns set of TImageData formats that can be saved in this file format
+ without need for conversion.}
+ function GetSupportedFormats: TImageFormats; virtual;
+ { Method which must be overrided in descendants if they' are be capable
+ of loading images. Images are already freed and length is set to zero
+ whenever this method gets called. Also Handle is assured to be valid
+ and contains data that passed TestFormat method's check.}
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstFrame: Boolean): Boolean; virtual;
+ { Method which must be overrided in descendants if they are be capable
+ of saving images. Images are checked to have length >0 and
+ that they contain valid images. For single-image file formats
+ Index contain valid index to Images array (to image which should be saved).
+ Multi-image formats should use FFirstIdx and FLastIdx fields to
+ to get all images that are to be saved.}
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; virtual;
+ { This method is called internaly by MakeCompatible when input image
+ is in format not supported by this file format. Image is clone of
+ MakeCompatible's input and Info is its extended format info.}
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); virtual;
+ { Returns True if given image is supported for saving by this file format.
+ Most file formats don't need to override this method. It checks
+ (in this base class) if Image's format is in SupportedFromats set.
+ But you may override it if you want further checks
+ (proper widht and height for example).}
+ function IsSupported(const Image: TImageData): Boolean; virtual;
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+
+ { Loads images from file source.}
+ function LoadFromFile(const FileName: string; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean = False): Boolean;
+ { Loads images from stream source.}
+ function LoadFromStream(Stream: TStream; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean = False): Boolean;
+ { Loads images from memory source.}
+ function LoadFromMemory(Data: Pointer; Size: LongInt;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean;
+
+ { Saves images to file. If format supports only single level images and
+ there are multiple images to be saved, they are saved as sequence of
+ independent images (for example SaveToFile saves sequence of
+ files img000.jpg, img001.jpg ....).}
+ function SaveToFile(const FileName: string; const Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean = False): Boolean;
+ { Saves images to stream. If format supports only single level images and
+ there are multiple images to be saved, they are saved as sequence of
+ independent images.}
+ function SaveToStream(Stream: TStream; const Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean = False): Boolean;
+ { Saves images to memory. If format supports only single level images and
+ there are multiple images to be saved, they are saved as sequence of
+ independent images. Data must be already allocated and their size passed
+ as Size parameter, number of written bytes is then returned in the same
+ parameter.}
+ function SaveToMemory(Data: Pointer; var Size: LongInt;
+ const Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean;
+
+ { Makes Image compatible with this file format (that means it is in one
+ of data formats in Supported formats set). If input is already
+ in supported format then Compatible just use value from input
+ (Compatible := Image) so must not free it after you are done with it
+ (image bits pointer points to input image's bits).
+ If input is not in supported format then it is cloned to Compatible
+ and concerted to one of supported formats (which one dependeds on
+ this file format). If image is cloned MustBeFreed is set to True
+ to indicated that you must free Compatible after you are done with it.}
+ function MakeCompatible(const Image: TImageData; var Compatible: TImageData;
+ out MustBeFreed: Boolean): Boolean;
+ { Returns True if data located in source identified by Handle
+ represent valid image in current format.}
+ function TestFormat(Handle: TImagingHandle): Boolean; virtual;
+ { Resturns True if the given FileName matches filter for this file format.
+ For most formats it just checks filename extensions.
+ It uses filename masks in from Masks property so it can recognize
+ filenames like this 'umajoXXXumajo.j0j' if one of themasks is
+ 'umajo*umajo.j?j'.}
+ function TestFileName(const FileName: string): Boolean;
+ { Descendants use this method to check if their options (registered with
+ constant Ids for SetOption/GetOption interface or accessible as properties
+ of descendants) have valid values and make necessary changes.}
+ procedure CheckOptionsValidity; virtual;
+
+ { Description of this format.}
+ property Name: string read FName;
+ { Indicates whether images in this format can be loaded.}
+ property CanLoad: Boolean read FCanLoad;
+ { Indicates whether images in this format can be saved.}
+ property CanSave: Boolean read FCanSave;
+ { Indicates whether images in this format can contain multiple image levels.}
+ property IsMultiImageFormat: Boolean read FIsMultiImageFormat;
+ { List of filename extensions for this format.}
+ property Extensions: TStringList read FExtensions;
+ { List of filename mask that are used to associate filenames
+ with TImageFileFormat descendants. Typical mask looks like
+ '*.bmp' or 'texture.*' (supports file formats which use filename instead
+ of extension to identify image files).}
+ property Masks: TStringList read FMasks;
+ { Set of TImageFormats supported by saving functions of this format. Images
+ can be saved only in one those formats.}
+ property SupportedFormats: TImageFormats read GetSupportedFormats;
+ end;
+ {$TYPEINFO OFF}
+
+ { Class reference for TImageFileFormat class}
+ TImageFileFormatClass = class of TImageFileFormat;
+
+{ Returns symbolic name of given format.}
+function GetFormatName(Format: TImageFormat): string;
+{ Returns string with information about given Image.}
+function ImageToStr(const Image: TImageData): string;
+{ Returns Imaging version string in format 'Major.Minor.Patch'.}
+function GetVersionStr: string;
+{ If Condition is True then TruePart is retured, otherwise FalsePart is returned.}
+function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat;
+{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo
+ functions.}
+procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
+{ Registers new option so it can be used by SetOption and GetOption functions.
+ Returns True if registration was succesful - that is Id is valid and is
+ not already taken by another option.}
+function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean;
+{ Returns image format loader/saver according to given extension
+ or nil if not found.}
+function FindImageFileFormatByExt(const Ext: string): TImageFileFormat;
+{ Returns image format loader/saver according to given filename
+ or nil if not found.}
+function FindImageFileFormatByName(const FileName: string): TImageFileFormat;
+{ Returns image format loader/saver based on its class
+ or nil if not found or not registered.}
+function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat;
+{ Returns number of registered image file format loaders/saver.}
+function GetFileFormatCount: LongInt;
+{ Returns image file format loader/saver at given index. Index must be
+ in range [0..GetFileFormatCount - 1] otherwise nil is returned.}
+function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat;
+{ Returns filter string for usage with open and save picture dialogs
+ which contains all registered image file formats.
+ Set OpenFileFilter to True if you want filter for open dialog
+ and to False if you want save dialog filter (formats that cannot save to files
+ are not added then).
+ For open dialog filter for all known graphic files
+ (like All(*.jpg;*.png;....) is added too at the first index.}
+function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string;
+{ Returns file extension (without dot) of image format selected
+ by given filter index. Used filter string is defined by GetImageFileFormatsFilter
+ function. This function can be used with save dialogs (with filters created
+ by GetImageFileFormatsFilter) to get the extension of file format selected
+ in dialog quickly. Index is in range 1..N (as FilterIndex property
+ of TOpenDialog/TSaveDialog)}
+function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string;
+{ Returns filter index of image file format of file specified by FileName. Used filter
+ string is defined by GetImageFileFormatsFilter function.
+ Returned index is in range 1..N (as FilterIndex property of TOpenDialog/TSaveDialog)}
+function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt;
+{ Returns current IO functions.}
+function GetIO: TIOFunctions;
+{ Raises EImagingError with given message.}
+procedure RaiseImaging(const Msg: string; const Args: array of const);
+
+implementation
+
+uses
+{$IFNDEF DONT_LINK_BITMAP}
+ ImagingBitmap,
+{$ENDIF}
+{$IFNDEF DONT_LINK_JPEG}
+ ImagingJpeg,
+{$ENDIF}
+{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
+ ImagingNetworkGraphics,
+{$IFEND}
+{$IFNDEF DONT_LINK_GIF}
+ ImagingGif,
+{$ENDIF}
+{$IFNDEF DONT_LINK_DDS}
+ ImagingDds,
+{$ENDIF}
+{$IFNDEF DONT_LINK_TARGA}
+ ImagingTarga,
+{$ENDIF}
+{$IFNDEF DONT_LINK_PNM}
+ ImagingPortableMaps,
+{$ENDIF}
+{$IFNDEF DONT_LINK_EXTRAS}
+ ImagingExtras,
+{$ENDIF}
+ ImagingFormats, ImagingUtility, ImagingIO;
+
+resourcestring
+ SImagingTitle = 'Vampyre Imaging Library';
+ SExceptMsg = 'Exception Message';
+ SAllFilter = 'All Images';
+ SUnknownFormat = 'Unknown and unsupported format';
+ SErrorFreeImage = 'Error while freeing image. %s';
+ SErrorCloneImage = 'Error while cloning image. %s';
+ SErrorFlipImage = 'Error while flipping image. %s';
+ SErrorMirrorImage = 'Error while mirroring image. %s';
+ SErrorResizeImage = 'Error while resizing image. %s';
+ SErrorSwapImage = 'Error while swapping channels of image. %s';
+ SFileFormatCanNotLoad = 'Image Format "%s" does not support loading images.';
+ SFileFormatCanNotSave = 'Image Format "%s" does not support saving images.';
+ SErrorNewImage = 'Error while creating image data with params: Width=%d ' +
+ 'Height=%d Format=%s.';
+ SErrorConvertImage = 'Error while converting image to format "%s". %s';
+ SImageInfo = 'Image @%p info: Width = %dpx, Height = %dpx, ' +
+ 'Format = %s, Size = %.0n %s, Bits @%p, Palette @%p.';
+ SImageInfoInvalid = 'Access violation encountered when getting info on ' +
+ 'image at address %p.';
+ SFileNotValid = 'File "%s" is not valid image in "%s" format.';
+ SStreamNotValid = 'Stream %p does not contain valid image in "%s" format.';
+ SMemoryNotValid = 'Memory %p (%d Bytes) does not contain valid image ' +
+ 'in "%s" format.';
+ SErrorLoadingFile = 'Error while loading images from file "%s" (file format: %s).';
+ SErrorLoadingStream = 'Error while loading images from stream %p (file format: %s).';
+ SErrorLoadingMemory = 'Error while loading images from memory %p (%d Bytes) (file format: %s).';
+ SErrorSavingFile = 'Error while saving images to file "%s" (file format: %s).';
+ SErrorSavingStream = 'Error while saving images to stream %p (file format: %s).';
+ SErrorSavingMemory = 'Error while saving images to memory %p (%d Bytes) (file format: %s).';
+ SErrorFindColor = 'Error while finding color in palette @%p with %d entries.';
+ SErrorGrayscalePalette = 'Error while filling grayscale palette @%p with %d entries.';
+ SErrorCustomPalette = 'Error while filling custom palette @%p with %d entries.';
+ SErrorSwapPalette = 'Error while swapping channels of palette @%p with %d entries.';
+ SErrorReduceColors = 'Error while reducing number of colors of image to %d. %s';
+ SErrorGenerateMipMaps = 'Error while generating %d mipmap levels for image %s';
+ SImagesNotValid = 'One or more images are not valid.';
+ SErrorCopyRect = 'Error while copying rect from image %s to image %s.';
+ SErrorMapImage = 'Error while mapping image %s to palette.';
+ SErrorFillRect = 'Error while filling rectangle X:%d Y:%d W:%d H:%d in image %s';
+ SErrorSplitImage = 'Error while splitting image %s to %dx%d sized chunks.';
+ SErrorMakePaletteForImages = 'Error while making %d color palette for %d images.';
+ SErrorNewPalette = 'Error while creating new palette with %d entries';
+ SErrorFreePalette = 'Error while freeing palette @%p';
+ SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p';
+ SErrorReplaceColor = 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s';
+ SErrorRotateImage = 'Error while rotating image %s by %.2n degrees';
+ SErrorStretchRect = 'Error while stretching rect from image %s to image %s.';
+ SErrorEmptyStream = 'Input stream has no data. Check Position property.';
+
+const
+ // initial size of array with options information
+ InitialOptions = 256;
+ // max depth of the option stack
+ OptionStackDepth = 8;
+ // do not change the default format now, its too late
+ DefaultImageFormat: TImageFormat = ifA8R8G8B8;
+
+type
+ TOptionArray = array of PLongInt;
+ TOptionValueArray = array of LongInt;
+
+ TOptionStack = class(TObject)
+ private
+ FStack: array[0..OptionStackDepth - 1] of TOptionValueArray;
+ FPosition: LongInt;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ function Push: Boolean;
+ function Pop: Boolean;
+ end;
+
+var
+ // currently set IO functions
+ IO: TIOFunctions;
+ // list with all registered TImageFileFormat classes
+ ImageFileFormats: TList = nil;
+ // array with registered options (pointers to their values)
+ Options: TOptionArray = nil;
+ // array containing addional infomation about every image format
+ ImageFormatInfos: TImageFormatInfoArray;
+ // stack used by PushOptions/PopOtions functions
+ OptionStack: TOptionStack = nil;
+var
+ // variable for ImagingColorReduction option
+ ColorReductionMask: LongInt = $FF;
+ // variable for ImagingLoadOverrideFormat option
+ LoadOverrideFormat: TImageFormat = ifUnknown;
+ // variable for ImagingSaveOverrideFormat option
+ SaveOverrideFormat: TImageFormat = ifUnknown;
+ // variable for ImagingSaveOverrideFormat option
+ MipMapFilter: TSamplingFilter = sfLinear;
+
+
+{ Internal unit functions }
+
+{ Modifies option value to be in the allowed range. Works only
+ for options registered in this unit.}
+function CheckOptionValue(OptionId, Value: LongInt): LongInt; forward;
+{ Sets IO functions to file IO.}
+procedure SetFileIO; forward;
+{ Sets IO functions to stream IO.}
+procedure SetStreamIO; forward;
+{ Sets IO functions to memory IO.}
+procedure SetMemoryIO; forward;
+{ Inits image format infos array.}
+procedure InitImageFormats; forward;
+{ Freew image format infos array.}
+procedure FreeImageFileFormats; forward;
+{ Creates options array and stack.}
+procedure InitOptions; forward;
+{ Frees options array and stack.}
+procedure FreeOptions; forward;
+
+{$IFDEF USE_INLINE}
+{ Those inline functions are copied here from ImagingFormats
+ because Delphi 9/10 cannot inline them if they are declared in
+ circularly dependent units.}
+
+procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); inline;
+begin
+ case BytesPerPixel of
+ 1: PByte(Dest)^ := PByte(Src)^;
+ 2: PWord(Dest)^ := PWord(Src)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
+ 4: PLongWord(Dest)^ := PLongWord(Src)^;
+ 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
+ 8: PInt64(Dest)^ := PInt64(Src)^;
+ 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
+ end;
+end;
+
+function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; inline;
+begin
+ case BytesPerPixel of
+ 1: Result := PByte(PixelA)^ = PByte(PixelB)^;
+ 2: Result := PWord(PixelA)^ = PWord(PixelB)^;
+ 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and
+ (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
+ 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
+ 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and
+ (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
+ 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
+ 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and
+ (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1);
+ else
+ Result := False;
+ end;
+end;
+{$ENDIF}
+
+{ ------------------------------------------------------------------------
+ Low Level Interface Functions
+ ------------------------------------------------------------------------}
+
+{ General Functions }
+
+procedure InitImage(var Image: TImageData);
+begin
+ FillChar(Image, SizeOf(Image), 0);
+end;
+
+function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image:
+ TImageData): Boolean;
+var
+ FInfo: PImageFormatInfo;
+begin
+ Assert((Width > 0) and (Height >0));
+ Assert(IsImageFormatValid(Format));
+ Result := False;
+ FreeImage(Image);
+ try
+ Image.Width := Width;
+ Image.Height := Height;
+ // Select default data format if selected
+ if (Format = ifDefault) then
+ Image.Format := DefaultImageFormat
+ else
+ Image.Format := Format;
+ // Get extended format info
+ FInfo := ImageFormatInfos[Image.Format];
+ if FInfo = nil then
+ begin
+ InitImage(Image);
+ Exit;
+ end;
+ // Check image dimensions and calculate its size in bytes
+ FInfo.CheckDimensions(FInfo.Format, Image.Width, Image.Height);
+ Image.Size := FInfo.GetPixelsSize(FInfo.Format, Image.Width, Image.Height);
+ if Image.Size = 0 then
+ begin
+ InitImage(Image);
+ Exit;
+ end;
+ // Image bits are allocated and set to zeroes
+ GetMem(Image.Bits, Image.Size);
+ FillChar(Image.Bits^, Image.Size, 0);
+ // Palette is allocated and set to zeroes
+ if FInfo.PaletteEntries > 0 then
+ begin
+ GetMem(Image.Palette, FInfo.PaletteEntries * SizeOf(TColor32Rec));
+ FillChar(Image.Palette^, FInfo.PaletteEntries * SizeOf(TColor32Rec), 0);
+ end;
+ Result := TestImage(Image);
+ except
+ RaiseImaging(SErrorNewImage, [Width, Height, GetFormatName(Format)]);
+ end;
+end;
+
+function TestImage(const Image: TImageData): Boolean;
+begin
+ try
+ Result := (LongInt(Image.Format) >= LongInt(Low(TImageFormat))) and
+ (LongInt(Image.Format) <= LongInt(High(TImageFormat))) and
+ (ImageFormatInfos[Image.Format] <> nil) and
+ (Assigned(ImageFormatInfos[Image.Format].GetPixelsSize) and
+ (ImageFormatInfos[Image.Format].GetPixelsSize(Image.Format,
+ Image.Width, Image.Height) = Image.Size));
+ except
+ // Possible int overflows or other errors
+ Result := False;
+ end;
+end;
+
+procedure FreeImage(var Image: TImageData);
+begin
+ try
+ if TestImage(Image) then
+ begin
+ FreeMemNil(Image.Bits);
+ FreeMemNil(Image.Palette);
+ end;
+ InitImage(Image);
+ except
+ RaiseImaging(SErrorFreeImage, [ImageToStr(Image)]);
+ end;
+end;
+
+procedure FreeImagesInArray(var Images: TDynImageDataArray);
+var
+ I: LongInt;
+begin
+ if Length(Images) > 0 then
+ begin
+ for I := 0 to Length(Images) - 1 do
+ FreeImage(Images[I]);
+ SetLength(Images, 0);
+ end;
+end;
+
+function TestImagesInArray(const Images: TDynImageDataArray): Boolean;
+var
+ I: LongInt;
+begin
+ if Length(Images) > 0 then
+ begin
+ Result := True;
+ for I := 0 to Length(Images) - 1 do
+ begin
+ Result := Result and TestImage(Images[I]);
+ if not Result then
+ Break;
+ end;
+ end
+ else
+ Result := False;
+end;
+
+function DetermineFileFormat(const FileName: string): string;
+var
+ I: LongInt;
+ Fmt: TImageFileFormat;
+ Handle: TImagingHandle;
+begin
+ Assert(FileName <> '');
+ Result := '';
+ SetFileIO;
+ try
+ Handle := IO.OpenRead(PChar(FileName));
+ try
+ // First file format according to FileName and test if the data in
+ // file is really in that format
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFileName(FileName) and Fmt.TestFormat(Handle) then
+ begin
+ Result := Fmt.Extensions[0];
+ Exit;
+ end;
+ end;
+ // No file format was found with filename search so try data-based search
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
+ begin
+ Result := Fmt.Extensions[0];
+ Exit;
+ end;
+ end;
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ Result := '';
+ end;
+end;
+
+function DetermineStreamFormat(Stream: TStream): string;
+var
+ I: LongInt;
+ Fmt: TImageFileFormat;
+ Handle: TImagingHandle;
+begin
+ Assert(Stream <> nil);
+ Result := '';
+ SetStreamIO;
+ try
+ Handle := IO.OpenRead(Pointer(Stream));
+ try
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
+ begin
+ Result := Fmt.Extensions[0];
+ Exit;
+ end;
+ end;
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ Result := '';
+ end;
+end;
+
+function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string;
+var
+ I: LongInt;
+ Fmt: TImageFileFormat;
+ Handle: TImagingHandle;
+ IORec: TMemoryIORec;
+begin
+ Assert((Data <> nil) and (Size > 0));
+ Result := '';
+ SetMemoryIO;
+ IORec.Data := Data;
+ IORec.Position := 0;
+ IORec.Size := Size;
+ try
+ Handle := IO.OpenRead(@IORec);
+ try
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
+ begin
+ Result := Fmt.Extensions[0];
+ Exit;
+ end;
+ end;
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ Result := '';
+ end;
+end;
+
+function IsFileFormatSupported(const FileName: string): Boolean;
+begin
+ Result := FindImageFileFormatByName(FileName) <> nil;
+end;
+
+function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string;
+ var CanSaveImages, IsMultiImageFormat: Boolean): Boolean;
+var
+ FileFmt: TImageFileFormat;
+begin
+ FileFmt := GetFileFormatAtIndex(Index);
+ Result := FileFmt <> nil;
+ if Result then
+ begin
+ Name := FileFmt.Name;
+ DefaultExt := FileFmt.Extensions[0];
+ Masks := FileFmt.Masks.DelimitedText;
+ CanSaveImages := FileFmt.CanSave;
+ IsMultiImageFormat := FileFmt.IsMultiImageFormat;
+ Inc(Index);
+ end
+ else
+ begin
+ Name := '';
+ DefaultExt := '';
+ Masks := '';
+ CanSaveImages := False;
+ IsMultiImageFormat := False;
+ end;
+end;
+
+{ Loading Functions }
+
+function LoadImageFromFile(const FileName: string; var Image: TImageData):
+ Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+ I: LongInt;
+begin
+ Assert(FileName <> '');
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineFileFormat(FileName));
+ if Format <> nil then
+ begin
+ FreeImage(Image);
+ Result := Format.LoadFromFile(FileName, IArray, True);
+ if Result and (Length(IArray) > 0) then
+ begin
+ Image := IArray[0];
+ for I := 1 to Length(IArray) - 1 do
+ FreeImage(IArray[I]);
+ end
+ else
+ Result := False;
+ end;
+end;
+
+function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+ I: LongInt;
+begin
+ Assert(Stream <> nil);
+ if Stream.Size - Stream.Position = 0 then
+ RaiseImaging(SErrorEmptyStream, []);
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
+ if Format <> nil then
+ begin
+ FreeImage(Image);
+ Result := Format.LoadFromStream(Stream, IArray, True);
+ if Result and (Length(IArray) > 0) then
+ begin
+ Image := IArray[0];
+ for I := 1 to Length(IArray) - 1 do
+ FreeImage(IArray[I]);
+ end
+ else
+ Result := False;
+ end;
+end;
+
+function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+ I: LongInt;
+begin
+ Assert((Data <> nil) and (Size > 0));
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size));
+ if Format <> nil then
+ begin
+ FreeImage(Image);
+ Result := Format.LoadFromMemory(Data, Size, IArray, True);
+ if Result and (Length(IArray) > 0) then
+ begin
+ Image := IArray[0];
+ for I := 1 to Length(IArray) - 1 do
+ FreeImage(IArray[I]);
+ end
+ else
+ Result := False;
+ end;
+end;
+
+function LoadMultiImageFromFile(const FileName: string; var Images:
+ TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert(FileName <> '');
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineFileFormat(FileName));
+ if Format <> nil then
+ begin
+ FreeImagesInArray(Images);
+ Result := Format.LoadFromFile(FileName, Images);
+ end;
+end;
+
+function LoadMultiImageFromStream(Stream: TStream; var Images: TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert(Stream <> nil);
+ if Stream.Size - Stream.Position = 0 then
+ RaiseImaging(SErrorEmptyStream, []);
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
+ if Format <> nil then
+ begin
+ FreeImagesInArray(Images);
+ Result := Format.LoadFromStream(Stream, Images);
+ end;
+end;
+
+function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
+ var Images: TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert((Data <> nil) and (Size > 0));
+ Result := False;
+ Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size));
+ if Format <> nil then
+ begin
+ FreeImagesInArray(Images);
+ Result := Format.LoadFromMemory(Data, Size, Images);
+ end;
+end;
+
+{ Saving Functions }
+
+function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+begin
+ Assert(FileName <> '');
+ Result := False;
+ Format := FindImageFileFormatByName(FileName);
+ if Format <> nil then
+ begin
+ SetLength(IArray, 1);
+ IArray[0] := Image;
+ Result := Format.SaveToFile(FileName, IArray, True);
+ end;
+end;
+
+function SaveImageToStream(const Ext: string; Stream: TStream;
+ const Image: TImageData): Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+begin
+ Assert((Ext <> '') and (Stream <> nil));
+ Result := False;
+ Format := FindImageFileFormatByExt(Ext);
+ if Format <> nil then
+ begin
+ SetLength(IArray, 1);
+ IArray[0] := Image;
+ Result := Format.SaveToStream(Stream, IArray, True);
+ end;
+end;
+
+function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt;
+ const Image: TImageData): Boolean;
+var
+ Format: TImageFileFormat;
+ IArray: TDynImageDataArray;
+begin
+ Assert((Ext <> '') and (Data <> nil) and (Size > 0));
+ Result := False;
+ Format := FindImageFileFormatByExt(Ext);
+ if Format <> nil then
+ begin
+ SetLength(IArray, 1);
+ IArray[0] := Image;
+ Result := Format.SaveToMemory(Data, Size, IArray, True);
+ end;
+end;
+
+function SaveMultiImageToFile(const FileName: string;
+ const Images: TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert(FileName <> '');
+ Result := False;
+ Format := FindImageFileFormatByName(FileName);
+ if Format <> nil then
+ Result := Format.SaveToFile(FileName, Images);
+end;
+
+function SaveMultiImageToStream(const Ext: string; Stream: TStream;
+ const Images: TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert((Ext <> '') and (Stream <> nil));
+ Result := False;
+ Format := FindImageFileFormatByExt(Ext);
+ if Format <> nil then
+ Result := Format.SaveToStream(Stream, Images);
+end;
+
+function SaveMultiImageToMemory(const Ext: string; Data: Pointer;
+ var Size: LongInt; const Images: TDynImageDataArray): Boolean;
+var
+ Format: TImageFileFormat;
+begin
+ Assert((Ext <> '') and (Data <> nil) and (Size > 0));
+ Result := False;
+ Format := FindImageFileFormatByExt(Ext);
+ if Format <> nil then
+ Result := Format.SaveToMemory(Data, Size, Images);
+end;
+
+{ Manipulation Functions }
+
+function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
+var
+ Info: PImageFormatInfo;
+begin
+ Result := False;
+ if TestImage(Image) then
+ try
+ if TestImage(Clone) and (Image.Bits <> Clone.Bits) then
+ FreeImage(Clone)
+ else
+ InitImage(Clone);
+
+ Info := ImageFormatInfos[Image.Format];
+ Clone.Width := Image.Width;
+ Clone.Height := Image.Height;
+ Clone.Format := Image.Format;
+ Clone.Size := Image.Size;
+
+ if Info.PaletteEntries > 0 then
+ begin
+ GetMem(Clone.Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
+ Move(Image.Palette^, Clone.Palette^, Info.PaletteEntries *
+ SizeOf(TColor32Rec));
+ end;
+
+ GetMem(Clone.Bits, Clone.Size);
+ Move(Image.Bits^, Clone.Bits^, Clone.Size);
+ Result := True;
+ except
+ RaiseImaging(SErrorCloneImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
+var
+ NewData: Pointer;
+ NewPal: PPalette32;
+ NewSize, NumPixels: LongInt;
+ SrcInfo, DstInfo: PImageFormatInfo;
+begin
+ Assert(IsImageFormatValid(DestFormat));
+ Result := False;
+ if TestImage(Image) then
+ with Image do
+ try
+ // If default format is set we use DefaultImageFormat
+ if DestFormat = ifDefault then
+ DestFormat := DefaultImageFormat;
+ SrcInfo := ImageFormatInfos[Format];
+ DstInfo := ImageFormatInfos[DestFormat];
+ if SrcInfo = DstInfo then
+ begin
+ // There is nothing to convert - src is alredy in dest format
+ Result := True;
+ Exit;
+ end;
+ // Exit Src or Dest format is invalid
+ if (SrcInfo = nil) or (DstInfo = nil) then Exit;
+ // If dest format is just src with swapped channels we call
+ // SwapChannels instead
+ if (SrcInfo.RBSwapFormat = DestFormat) and
+ (DstInfo.RBSwapFormat = SrcInfo.Format) then
+ begin
+ Result := SwapChannels(Image, ChannelRed, ChannelBlue);
+ Image.Format := SrcInfo.RBSwapFormat;
+ Exit;
+ end;
+
+ if (not SrcInfo.IsSpecial) and (not DstInfo.IsSpecial) then
+ begin
+ NumPixels := Width * Height;
+ NewSize := NumPixels * DstInfo.BytesPerPixel;
+ GetMem(NewData, NewSize);
+ FillChar(NewData^, NewSize, 0);
+ GetMem(NewPal, DstInfo.PaletteEntries * SizeOf(TColor32Rec));
+ FillChar(NewPal^, DstInfo.PaletteEntries * SizeOf(TColor32Rec), 0);
+
+ if SrcInfo.IsIndexed then
+ begin
+ // Source: indexed format
+ if DstInfo.IsIndexed then
+ IndexToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette, NewPal)
+ else if DstInfo.HasGrayChannel then
+ IndexToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette)
+ else if DstInfo.IsFloatingPoint then
+ IndexToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette)
+ else
+ IndexToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette);
+ end
+ else if SrcInfo.HasGrayChannel then
+ begin
+ // Source: grayscale format
+ if DstInfo.IsIndexed then
+ GrayToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
+ else if DstInfo.HasGrayChannel then
+ GrayToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else if DstInfo.IsFloatingPoint then
+ GrayToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else
+ GrayToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
+ end
+ else if SrcInfo.IsFloatingPoint then
+ begin
+ // Source: floating point format
+ if DstInfo.IsIndexed then
+ FloatToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
+ else if DstInfo.HasGrayChannel then
+ FloatToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else if DstInfo.IsFloatingPoint then
+ FloatToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else
+ FloatToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
+ end
+ else
+ begin
+ // Source: standard multi channel image
+ if DstInfo.IsIndexed then
+ ChannelToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
+ else if DstInfo.HasGrayChannel then
+ ChannelToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else if DstInfo.IsFloatingPoint then
+ ChannelToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
+ else
+ ChannelToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
+ end;
+
+ FreeMemNil(Bits);
+ FreeMemNil(Palette);
+ Format := DestFormat;
+ Bits := NewData;
+ Size := NewSize;
+ Palette := NewPal;
+ end
+ else
+ ConvertSpecial(Image, SrcInfo, DstInfo);
+
+ Assert(SrcInfo.Format <> Image.Format);
+
+ Result := True;
+ except
+ RaiseImaging(SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]);
+ end;
+end;
+
+function FlipImage(var Image: TImageData): Boolean;
+var
+ P1, P2, Buff: Pointer;
+ WidthBytes, I: LongInt;
+ OldFmt: TImageFormat;
+begin
+ Result := False;
+ OldFmt := Image.Format;
+ if TestImage(Image) then
+ with Image do
+ try
+ if ImageFormatInfos[OldFmt].IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ WidthBytes := Width * ImageFormatInfos[Format].BytesPerPixel;
+ GetMem(Buff, WidthBytes);
+ try
+ // Swap all scanlines of image
+ for I := 0 to Height div 2 - 1 do
+ begin
+ P1 := @PByteArray(Bits)[I * WidthBytes];
+ P2 := @PByteArray(Bits)[(Height - I - 1) * WidthBytes];
+ Move(P1^, Buff^, WidthBytes);
+ Move(P2^, P1^, WidthBytes);
+ Move(Buff^, P2^, WidthBytes);
+ end;
+ finally
+ FreeMemNil(Buff);
+ end;
+
+ if OldFmt <> Format then
+ ConvertImage(Image, OldFmt);
+
+ Result := True;
+ except
+ RaiseImaging(SErrorFlipImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function MirrorImage(var Image: TImageData): Boolean;
+var
+ Scanline: PByte;
+ Buff: TColorFPRec;
+ Bpp, Y, X, WidthDiv2, WidthBytes, XLeft, XRight: LongInt;
+ OldFmt: TImageFormat;
+begin
+ Result := False;
+ OldFmt := Image.Format;
+ if TestImage(Image) then
+ with Image do
+ try
+ if ImageFormatInfos[OldFmt].IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ Bpp := ImageFormatInfos[Format].BytesPerPixel;
+ WidthDiv2 := Width div 2;
+ WidthBytes := Width * Bpp;
+ // Mirror all pixels on each scanline of image
+ for Y := 0 to Height - 1 do
+ begin
+ Scanline := @PByteArray(Bits)[Y * WidthBytes];
+ XLeft := 0;
+ XRight := (Width - 1) * Bpp;
+ for X := 0 to WidthDiv2 - 1 do
+ begin
+ CopyPixel(@PByteArray(Scanline)[XLeft], @Buff, Bpp);
+ CopyPixel(@PByteArray(Scanline)[XRight],
+ @PByteArray(Scanline)[XLeft], Bpp);
+ CopyPixel(@Buff, @PByteArray(Scanline)[XRight], Bpp);
+ Inc(XLeft, Bpp);
+ Dec(XRight, Bpp);
+ end;
+ end;
+
+ if OldFmt <> Format then
+ ConvertImage(Image, OldFmt);
+
+ Result := True;
+ except
+ RaiseImaging(SErrorMirrorImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
+ Filter: TResizeFilter): Boolean;
+var
+ WorkImage: TImageData;
+begin
+ Assert((NewWidth > 0) and (NewHeight > 0));
+ Result := False;
+ if TestImage(Image) and ((Image.Width <> NewWidth) or (Image.Height <> NewHeight)) then
+ try
+ InitImage(WorkImage);
+ // Create new image with desired dimensions
+ NewImage(NewWidth, NewHeight, Image.Format, WorkImage);
+ // Stretch pixels from old image to new one
+ StretchRect(Image, 0, 0, Image.Width, Image.Height,
+ WorkImage, 0, 0, WorkImage.Width, WorkImage.Height, Filter);
+ // Free old image and assign new image to it
+ FreeMemNil(Image.Bits);
+ if Image.Palette <> nil then
+ begin
+ FreeMem(WorkImage.Palette);
+ WorkImage.Palette := Image.Palette;
+ end;
+ Image := WorkImage;
+ Result := True;
+ except
+ RaiseImaging(SErrorResizeImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean;
+var
+ I, NumPixels: LongInt;
+ Info: PImageFormatInfo;
+ Swap, Alpha: Word;
+ Data: PByte;
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+ SwapF: Single;
+begin
+ Assert((SrcChannel in [0..3]) and (DstChannel in [0..3]));
+ Result := False;
+ if TestImage(Image) and (SrcChannel <> DstChannel) then
+ with Image do
+ try
+ NumPixels := Width * Height;
+ Info := ImageFormatInfos[Format];
+ Data := Bits;
+
+ if (Info.Format = ifR8G8B8) or ((Info.Format = ifA8R8G8B8) and
+ (SrcChannel <> ChannelAlpha) and (DstChannel <> ChannelAlpha)) then
+ begin
+ // Swap channels of most common formats R8G8B8 and A8R8G8B8 (no alpha)
+ for I := 0 to NumPixels - 1 do
+ with PColor24Rec(Data)^ do
+ begin
+ Swap := Channels[SrcChannel];
+ Channels[SrcChannel] := Channels[DstChannel];
+ Channels[DstChannel] := Swap;
+ Inc(Data, Info.BytesPerPixel);
+ end;
+ end
+ else if Info.IsIndexed then
+ begin
+ // Swap palette channels of indexed images
+ SwapChannelsOfPalette(Palette, Info.PaletteEntries, SrcChannel, DstChannel)
+ end
+ else if Info.IsFloatingPoint then
+ begin
+ // Swap channels of floating point images
+ for I := 0 to NumPixels - 1 do
+ begin
+ FloatGetSrcPixel(Data, Info, PixF);
+ with PixF do
+ begin
+ SwapF := Channels[SrcChannel];
+ Channels[SrcChannel] := Channels[DstChannel];
+ Channels[DstChannel] := SwapF;
+ end;
+ FloatSetDstPixel(Data, Info, PixF);
+ Inc(Data, Info.BytesPerPixel);
+ end;
+ end
+ else if Info.IsSpecial then
+ begin
+ // Swap channels of special format images
+ ConvertImage(Image, ifDefault);
+ SwapChannels(Image, SrcChannel, DstChannel);
+ ConvertImage(Image, Info.Format);
+ end
+ else if Info.HasGrayChannel and Info.HasAlphaChannel and
+ ((SrcChannel = ChannelAlpha) or (DstChannel = ChannelAlpha)) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ // If we have grayscale image with alpha and alpha is channel
+ // to be swapped, we swap it. No other alternative for gray images,
+ // just alpha and something
+ GrayGetSrcPixel(Data, Info, Pix64, Alpha);
+ Swap := Alpha;
+ Alpha := Pix64.A;
+ Pix64.A := Swap;
+ GraySetDstPixel(Data, Info, Pix64, Alpha);
+ Inc(Data, Info.BytesPerPixel);
+ end;
+ end
+ else
+ begin
+ // Then do general swap on other channel image formats
+ for I := 0 to NumPixels - 1 do
+ begin
+ ChannelGetSrcPixel(Data, Info, Pix64);
+ with Pix64 do
+ begin
+ Swap := Channels[SrcChannel];
+ Channels[SrcChannel] := Channels[DstChannel];
+ Channels[DstChannel] := Swap;
+ end;
+ ChannelSetDstPixel(Data, Info, Pix64);
+ Inc(Data, Info.BytesPerPixel);
+ end;
+ end;
+
+ Result := True;
+ except
+ RaiseImaging(SErrorSwapImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
+var
+ TmpInfo: TImageFormatInfo;
+ Data, Index: PWord;
+ I, NumPixels: LongInt;
+ Pal: PPalette32;
+ Col:PColor32Rec;
+ OldFmt: TImageFormat;
+begin
+ Result := False;
+ if TestImage(Image) then
+ with Image do
+ try
+ // First create temp image info and allocate output bits and palette
+ MaxColors := ClampInt(MaxColors, 2, High(Word));
+ OldFmt := Format;
+ FillChar(TmpInfo, SizeOf(TmpInfo), 0);
+ TmpInfo.PaletteEntries := MaxColors;
+ TmpInfo.BytesPerPixel := 2;
+ NumPixels := Width * Height;
+ GetMem(Data, NumPixels * TmpInfo.BytesPerPixel);
+ GetMem(Pal, MaxColors * SizeOf(TColor32Rec));
+ ConvertImage(Image, ifA8R8G8B8);
+ // We use median cut algorithm to create reduced palette and to
+ // fill Data with indices to this palette
+ ReduceColorsMedianCut(NumPixels, Bits, PByte(Data),
+ ImageFormatInfos[Format], @TmpInfo, MaxColors, ColorReductionMask, Pal);
+ Col := Bits;
+ Index := Data;
+ // Then we write reduced colors to the input image
+ for I := 0 to NumPixels - 1 do
+ begin
+ Col.Color := Pal[Index^].Color;
+ Inc(Col);
+ Inc(Index);
+ end;
+ FreeMemNil(Data);
+ FreeMemNil(Pal);
+ // And convert it to its original format
+ ConvertImage(Image, OldFmt);
+ Result := True;
+ except
+ RaiseImaging(SErrorReduceColors, [MaxColors, ImageToStr(Image)]);
+ end;
+end;
+
+function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
+ var MipMaps: TDynImageDataArray): Boolean;
+var
+ Width, Height, I, Count: LongInt;
+ Info: TImageFormatInfo;
+ CompatibleCopy: TImageData;
+begin
+ Result := False;
+ if TestImage(Image) then
+ try
+ Width := Image.Width;
+ Height := Image.Height;
+ // We compute number of possible mipmap levels and if
+ // the given levels are invalid or zero we use this value
+ Count := GetNumMipMapLevels(Width, Height);
+ if (Levels <= 0) or (Levels > Count) then
+ Levels := Count;
+
+ // If we have special format image we create copy to allow pixel access.
+ // This is also done in FillMipMapLevel which is called for each level
+ // but then the main big image would be converted to compatible
+ // for every level.
+ GetImageFormatInfo(Image.Format, Info);
+ if Info.IsSpecial then
+ begin
+ InitImage(CompatibleCopy);
+ CloneImage(Image, CompatibleCopy);
+ ConvertImage(CompatibleCopy, ifDefault);
+ end
+ else
+ CompatibleCopy := Image;
+
+ FreeImagesInArray(MipMaps);
+ SetLength(MipMaps, Levels);
+ CloneImage(Image, MipMaps[0]);
+
+ for I := 1 to Levels - 1 do
+ begin
+ Width := Width shr 1;
+ Height := Height shr 1;
+ if Width < 1 then Width := 1;
+ if Height < 1 then Height := 1;
+ FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]);
+ end;
+
+ if CompatibleCopy.Format <> MipMaps[0].Format then
+ begin
+ // Must convert smaller levels to proper format
+ for I := 1 to High(MipMaps) do
+ ConvertImage(MipMaps[I], MipMaps[0].Format);
+ FreeImage(CompatibleCopy);
+ end;
+
+ Result := True;
+ except
+ RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]);
+ end;
+end;
+
+function MapImageToPalette(var Image: TImageData; Pal: PPalette32;
+ Entries: LongInt): Boolean;
+
+ function FindNearestColor(Pal: PPalette32; Entries: LongInt; Col: TColor32Rec): LongInt;
+ var
+ I, MinDif, Dif: LongInt;
+ begin
+ Result := 0;
+ MinDif := 1020;
+ for I := 0 to Entries - 1 do
+ with Pal[I] do
+ begin
+ Dif := Abs(R - Col.R);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(G - Col.G);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(B - Col.B);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(A - Col.A);
+ if Dif < MinDif then
+ begin
+ MinDif := Dif;
+ Result := I;
+ end;
+ end;
+ end;
+
+var
+ I, MaxEntries: LongInt;
+ PIndex: PByte;
+ PColor: PColor32Rec;
+ CloneARGB: TImageData;
+ Info: PImageFormatInfo;
+begin
+ Assert((Entries >= 2) and (Entries <= 256));
+ Result := False;
+
+ if TestImage(Image) then
+ try
+ // We create clone of source image in A8R8G8B8 and
+ // then recreate source image in ifIndex8 format
+ // with palette taken from Pal parameter
+ InitImage(CloneARGB);
+ CloneImage(Image, CloneARGB);
+ ConvertImage(CloneARGB, ifA8R8G8B8);
+ FreeImage(Image);
+ NewImage(CloneARGB.Width, CloneARGB.Height, ifIndex8, Image);
+
+ Info := ImageFormatInfos[Image.Format];
+ MaxEntries := Min(Info.PaletteEntries, Entries);
+ Move(Pal^, Image.Palette^, MaxEntries * SizeOf(TColor32Rec));
+ PIndex := Image.Bits;
+ PColor := CloneARGB.Bits;
+
+ // For every pixel of ARGB clone we find closest color in
+ // given palette and assign its index to resulting image's pixel
+ // procedure used here is very slow but simple and memory usage friendly
+ // (contrary to other methods)
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ PIndex^ := Byte(FindNearestColor(Image.Palette, MaxEntries, PColor^));
+ Inc(PIndex);
+ Inc(PColor);
+ end;
+
+ FreeImage(CloneARGB);
+ Result := True;
+ except
+ RaiseImaging(SErrorMapImage, [ImageToStr(Image)]);
+ end;
+end;
+
+function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
+ ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
+ PreserveSize: Boolean; Fill: Pointer): Boolean;
+var
+ X, Y, XTrunc, YTrunc: LongInt;
+ NotOnEdge: Boolean;
+ Info: PImageFormatInfo;
+ OldFmt: TImageFormat;
+begin
+ Assert((ChunkWidth > 0) and (ChunkHeight > 0));
+ Result := False;
+ OldFmt := Image.Format;
+ FreeImagesInArray(Chunks);
+
+ if TestImage(Image) then
+ try
+ Info := ImageFormatInfos[Image.Format];
+ if Info.IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ // We compute make sure that chunks are not larger than source image or negative
+ ChunkWidth := ClampInt(ChunkWidth, 0, Image.Width);
+ ChunkHeight := ClampInt(ChunkHeight, 0, Image.Height);
+ // Number of chunks along X and Y axes is computed
+ XChunks := Trunc(Ceil(Image.Width / ChunkWidth));
+ YChunks := Trunc(Ceil(Image.Height / ChunkHeight));
+ SetLength(Chunks, XChunks * YChunks);
+
+ // For every chunk we create new image and copy a portion of
+ // the source image to it. If chunk is on the edge of the source image
+ // we fill enpty space with Fill pixel data if PreserveSize is set or
+ // make the chunk smaller if it is not set
+ for Y := 0 to YChunks - 1 do
+ for X := 0 to XChunks - 1 do
+ begin
+ // Determine if current chunk is on the edge of original image
+ NotOnEdge := ((X < XChunks - 1) and (Y < YChunks - 1)) or
+ ((Image.Width mod ChunkWidth = 0) and (Image.Height mod ChunkHeight = 0));
+
+ if PreserveSize or NotOnEdge then
+ begin
+ // We should preserve chunk sizes or we are somewhere inside original image
+ NewImage(ChunkWidth, ChunkHeight, Image.Format, Chunks[Y * XChunks + X]);
+ if (not NotOnEdge) and (Fill <> nil) then
+ FillRect(Chunks[Y * XChunks + X], 0, 0, ChunkWidth, ChunkHeight, Fill);
+ CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, ChunkWidth, ChunkHeight,
+ Chunks[Y * XChunks + X], 0, 0);
+ end
+ else
+ begin
+ // Create smaller edge chunk
+ XTrunc := Image.Width - (Image.Width div ChunkWidth) * ChunkWidth;
+ YTrunc := Image.Height - (Image.Height div ChunkHeight) * ChunkHeight;
+ NewImage(XTrunc, YTrunc, Image.Format, Chunks[Y * XChunks + X]);
+ CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, XTrunc, YTrunc,
+ Chunks[Y * XChunks + X], 0, 0);
+ end;
+
+ // If source image is in indexed format we copy its palette to chunk
+ if Info.IsIndexed then
+ begin
+ Move(Image.Palette^, Chunks[Y * XChunks + X].Palette^,
+ Info.PaletteEntries * SizeOf(TColor32Rec));
+ end;
+ end;
+
+ if OldFmt <> Image.Format then
+ begin
+ ConvertImage(Image, OldFmt);
+ for X := 0 to Length(Chunks) - 1 do
+ ConvertImage(Chunks[X], OldFmt);
+ end;
+
+ Result := True;
+ except
+ RaiseImaging(SErrorSplitImage, [ImageToStr(Image), ChunkWidth, ChunkHeight]);
+ end;
+end;
+
+function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
+ MaxColors: LongInt; ConvertImages: Boolean): Boolean;
+var
+ I: Integer;
+ SrcInfo, DstInfo: PImageFormatInfo;
+ Target, TempImage: TImageData;
+ DstFormat: TImageFormat;
+begin
+ Assert((Pal <> nil) and (MaxColors > 0));
+ Result := False;
+ InitImage(TempImage);
+
+ if TestImagesInArray(Images) then
+ try
+ // Null the color histogram
+ ReduceColorsMedianCut(0, nil, nil, nil, nil, 0, 0, nil, [raCreateHistogram]);
+ for I := 0 to Length(Images) - 1 do
+ begin
+ SrcInfo := ImageFormatInfos[Images[I].Format];
+ if SrcInfo.IsIndexed or SrcInfo.IsSpecial then
+ begin
+ // create temp image in supported format for updating histogram
+ CloneImage(Images[I], TempImage);
+ ConvertImage(TempImage, ifA8R8G8B8);
+ SrcInfo := ImageFormatInfos[TempImage.Format];
+ end
+ else
+ TempImage := Images[I];
+
+ // Update histogram with colors of each input image
+ ReduceColorsMedianCut(TempImage.Width * TempImage.Height, TempImage.Bits,
+ nil, SrcInfo, nil, MaxColors, ColorReductionMask, nil, [raUpdateHistogram]);
+
+ if Images[I].Bits <> TempImage.Bits then
+ FreeImage(TempImage);
+ end;
+ // Construct reduced color map from the histogram
+ ReduceColorsMedianCut(0, nil, nil, nil, nil, MaxColors, ColorReductionMask,
+ Pal, [raMakeColorMap]);
+
+ if ConvertImages then
+ begin
+ DstFormat := ifIndex8;
+ DstInfo := ImageFormatInfos[DstFormat];
+ MaxColors := Min(DstInfo.PaletteEntries, MaxColors);
+
+ for I := 0 to Length(Images) - 1 do
+ begin
+ SrcInfo := ImageFormatInfos[Images[I].Format];
+ if SrcInfo.IsIndexed or SrcInfo.IsSpecial then
+ begin
+ // If source image is in format not supported by ReduceColorsMedianCut
+ // we convert it
+ ConvertImage(Images[I], ifA8R8G8B8);
+ SrcInfo := ImageFormatInfos[Images[I].Format];
+ end;
+
+ InitImage(Target);
+ NewImage(Images[I].Width, Images[I].Height, DstFormat, Target);
+ // We map each input image to reduced palette and replace
+ // image in array with mapped image
+ ReduceColorsMedianCut(Images[I].Width * Images[I].Height, Images[I].Bits,
+ Target.Bits, SrcInfo, DstInfo, MaxColors, 0, nil, [raMapImage]);
+ Move(Pal^, Target.Palette^, MaxColors * SizeOf(TColor32Rec));
+
+ FreeImage(Images[I]);
+ Images[I] := Target;
+ end;
+ end;
+ Result := True;
+ except
+ RaiseImaging(SErrorMakePaletteForImages, [MaxColors, Length(Images)]);
+ end;
+end;
+
+function RotateImage(var Image: TImageData; Angle: Single): Boolean;
+var
+ OldFmt: TImageFormat;
+
+ procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer);
+ var
+ I, J, XPos: Integer;
+ PixSrc, PixLeft, PixOldLeft: TColor32Rec;
+ LineDst: PByteArray;
+ SrcPtr: PColor32;
+ begin
+ SrcPtr := @PByteArray(Src.Bits)[Row * Src.Width * Bpp];
+ LineDst := @PByteArray(Dst.Bits)[Row * Dst.Width * Bpp];
+ PixOldLeft.Color := 0;
+
+ for I := 0 to Src.Width - 1 do
+ begin
+ CopyPixel(SrcPtr, @PixSrc, Bpp);
+ for J := 0 to Bpp - 1 do
+ PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
+
+ XPos := I + Offset;
+ if (XPos >= 0) and (XPos < Dst.Width) then
+ begin
+ for J := 0 to Bpp - 1 do
+ PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+ CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp);
+ end;
+ PixOldLeft := PixLeft;
+ Inc(PByte(SrcPtr), Bpp);
+ end;
+
+ XPos := Src.Width + Offset;
+ if XPos < Dst.Width then
+ CopyPixel(@PixOldLeft, @LineDst[XPos * Bpp], Bpp);
+ end;
+
+ procedure YShear(var Src, Dst: TImageData; Col, Offset, Weight, Bpp: Integer);
+ var
+ I, J, YPos: Integer;
+ PixSrc, PixLeft, PixOldLeft: TColor32Rec;
+ SrcPtr: PByte;
+ begin
+ SrcPtr := @PByteArray(Src.Bits)[Col * Bpp];
+ PixOldLeft.Color := 0;
+
+ for I := 0 to Src.Height - 1 do
+ begin
+ CopyPixel(SrcPtr, @PixSrc, Bpp);
+ for J := 0 to Bpp - 1 do
+ PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
+
+ YPos := I + Offset;
+ if (YPos >= 0) and (YPos < Dst.Height) then
+ begin
+ for J := 0 to Bpp - 1 do
+ PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+ CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
+ end;
+ PixOldLeft := PixLeft;
+ Inc(SrcPtr, Src.Width * Bpp);
+ end;
+
+ YPos := Src.Height + Offset;
+ if YPos < Dst.Height then
+ CopyPixel(@PixOldLeft, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
+ end;
+
+ procedure Rotate45(var Image: TImageData; Angle: Single);
+ var
+ TempImage1, TempImage2: TImageData;
+ AngleRad, AngleTan, AngleSin, AngleCos, Shear: Single;
+ I, DstWidth, DstHeight, SrcWidth, SrcHeight, Bpp: Integer;
+ SrcFmt, TempFormat: TImageFormat;
+ Info: TImageFormatInfo;
+ begin
+ AngleRad := Angle * Pi / 180;
+ AngleSin := Sin(AngleRad);
+ AngleCos := Cos(AngleRad);
+ AngleTan := Sin(AngleRad / 2) / Cos(AngleRad / 2);
+ SrcWidth := Image.Width;
+ SrcHeight := Image.Height;
+ SrcFmt := Image.Format;
+
+ if not (SrcFmt in [ifR8G8B8..ifX8R8G8B8, ifGray8..ifGray32, ifA16Gray16]) then
+ ConvertImage(Image, ifA8R8G8B8);
+
+ TempFormat := Image.Format;
+ GetImageFormatInfo(TempFormat, Info);
+ Bpp := Info.BytesPerPixel;
+
+ // 1st shear (horizontal)
+ DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5);
+ DstHeight := SrcHeight;
+ NewImage(DstWidth, DstHeight, TempFormat, TempImage1);
+
+ for I := 0 to DstHeight - 1 do
+ begin
+ if AngleTan >= 0 then
+ Shear := (I + 0.5) * AngleTan
+ else
+ Shear := (I - DstHeight + 0.5) * AngleTan;
+ XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+ end;
+
+ // 2nd shear (vertical)
+ FreeImage(Image);
+ DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1;
+ NewImage(DstWidth, DstHeight, TempFormat, TempImage2);
+
+ if AngleSin >= 0 then
+ Shear := (SrcWidth - 1) * AngleSin
+ else
+ Shear := (SrcWidth - DstWidth) * -AngleSin;
+
+ for I := 0 to DstWidth - 1 do
+ begin
+ YShear(TempImage1, TempImage2, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+ Shear := Shear - AngleSin;
+ end;
+
+ // 3rd shear (horizontal)
+ FreeImage(TempImage1);
+ DstWidth := Trunc(SrcHeight * Abs(AngleSin) + SrcWidth * AngleCos + 0.5) + 1;
+ NewImage(DstWidth, DstHeight, TempFormat, Image);
+
+ if AngleSin >= 0 then
+ Shear := (SrcWidth - 1) * AngleSin * -AngleTan
+ else
+ Shear := ((SrcWidth - 1) * -AngleSin + (1 - DstHeight)) * AngleTan;
+
+ for I := 0 to DstHeight - 1 do
+ begin
+ XShear(TempImage2, Image, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+ Shear := Shear + AngleTan;
+ end;
+
+ FreeImage(TempImage2);
+ if Image.Format <> SrcFmt then
+ ConvertImage(Image, SrcFmt);
+ end;
+
+ procedure RotateMul90(var Image: TImageData; Angle: Integer);
+ var
+ RotImage: TImageData;
+ X, Y, BytesPerPixel: Integer;
+ RotPix, Pix: PByte;
+ begin
+ InitImage(RotImage);
+ BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
+
+ if ((Angle = 90) or (Angle = 270)) and (Image.Width <> Image.Height) then
+ NewImage(Image.Height, Image.Width, Image.Format, RotImage)
+ else
+ NewImage(Image.Width, Image.Height, Image.Format, RotImage);
+
+ RotPix := RotImage.Bits;
+ case Angle of
+ 90:
+ begin
+ for Y := 0 to RotImage.Height - 1 do
+ begin
+ Pix := @PByteArray(Image.Bits)[(Image.Width - Y - 1) * BytesPerPixel];
+ for X := 0 to RotImage.Width - 1 do
+ begin
+ CopyPixel(Pix, RotPix, BytesPerPixel);
+ Inc(RotPix, BytesPerPixel);
+ Inc(Pix, Image.Width * BytesPerPixel);
+ end;
+ end;
+ end;
+ 180:
+ begin
+ Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width +
+ (Image.Width - 1)) * BytesPerPixel];
+ for Y := 0 to RotImage.Height - 1 do
+ for X := 0 to RotImage.Width - 1 do
+ begin
+ CopyPixel(Pix, RotPix, BytesPerPixel);
+ Inc(RotPix, BytesPerPixel);
+ Dec(Pix, BytesPerPixel);
+ end;
+ end;
+ 270:
+ begin
+ for Y := 0 to RotImage.Height - 1 do
+ begin
+ Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel];
+ for X := 0 to RotImage.Width - 1 do
+ begin
+ CopyPixel(Pix, RotPix, BytesPerPixel);
+ Inc(RotPix, BytesPerPixel);
+ Dec(Pix, Image.Width * BytesPerPixel);
+ end;
+ end;
+ end;
+ end;
+
+ FreeMemNil(Image.Bits);
+ RotImage.Palette := Image.Palette;
+ Image := RotImage;
+ end;
+
+begin
+ Result := False;
+
+ if TestImage(Image) then
+ try
+ while Angle >= 360 do
+ Angle := Angle - 360;
+ while Angle < 0 do
+ Angle := Angle + 360;
+
+ if (Angle = 0) or (Abs(Angle) = 360) then
+ begin
+ Result := True;
+ Exit;
+ end;
+
+ OldFmt := Image.Format;
+ if ImageFormatInfos[Image.Format].IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ if (Angle > 45) and (Angle <= 135) then
+ begin
+ RotateMul90(Image, 90);
+ Angle := Angle - 90;
+ end
+ else if (Angle > 135) and (Angle <= 225) then
+ begin
+ RotateMul90(Image, 180);
+ Angle := Angle - 180;
+ end
+ else if (Angle > 225) and (Angle <= 315) then
+ begin
+ RotateMul90(Image, 270);
+ Angle := Angle - 270;
+ end;
+
+ if Angle <> 0 then
+ Rotate45(Image, Angle);
+
+ if OldFmt <> Image.Format then
+ ConvertImage(Image, OldFmt);
+
+ Result := True;
+ except
+ RaiseImaging(SErrorRotateImage, [ImageToStr(Image), Angle]);
+ end;
+end;
+
+{ Drawing/Pixel functions }
+
+function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
+ var DstImage: TImageData; DstX, DstY: LongInt): Boolean;
+var
+ Info: PImageFormatInfo;
+ I, SrcWidthBytes, DstWidthBytes, MoveBytes: LongInt;
+ SrcPointer, DstPointer: PByte;
+ WorkImage: TImageData;
+ OldFormat: TImageFormat;
+begin
+ Result := False;
+ OldFormat := ifUnknown;
+ if TestImage(SrcImage) and TestImage(DstImage) then
+ try
+ // Make sure we are still copying image to image, not invalid pointer to protected memory
+ ClipCopyBounds(SrcX, SrcY, Width, Height, DstX, DstY, SrcImage.Width, SrcImage.Height,
+ Rect(0, 0, DstImage.Width, DstImage.Height));
+
+ if (Width > 0) and (Height > 0) then
+ begin
+ Info := ImageFormatInfos[DstImage.Format];
+ if Info.IsSpecial then
+ begin
+ // If dest image is in special format we convert it to default
+ OldFormat := Info.Format;
+ ConvertImage(DstImage, ifDefault);
+ Info := ImageFormatInfos[DstImage.Format];
+ end;
+ if SrcImage.Format <> DstImage.Format then
+ begin
+ // If images are in different format source is converted to dest's format
+ InitImage(WorkImage);
+ CloneImage(SrcImage, WorkImage);
+ ConvertImage(WorkImage, DstImage.Format);
+ end
+ else
+ WorkImage := SrcImage;
+
+ MoveBytes := Width * Info.BytesPerPixel;
+ DstWidthBytes := DstImage.Width * Info.BytesPerPixel;
+ DstPointer := @PByteArray(DstImage.Bits)[DstY * DstWidthBytes +
+ DstX * Info.BytesPerPixel];
+ SrcWidthBytes := WorkImage.Width * Info.BytesPerPixel;
+ SrcPointer := @PByteArray(WorkImage.Bits)[SrcY * SrcWidthBytes +
+ SrcX * Info.BytesPerPixel];
+
+ for I := 0 to Height - 1 do
+ begin
+ Move(SrcPointer^, DstPointer^, MoveBytes);
+ Inc(SrcPointer, SrcWidthBytes);
+ Inc(DstPointer, DstWidthBytes);
+ end;
+ // If dest image was in special format we convert it back
+ if OldFormat <> ifUnknown then
+ ConvertImage(DstImage, OldFormat);
+ // Working image must be freed if it is not the same as source image
+ if WorkImage.Bits <> SrcImage.Bits then
+ FreeImage(WorkImage);
+
+ Result := True;
+ end;
+ except
+ RaiseImaging(SErrorCopyRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]);
+ end;
+end;
+
+function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
+ FillColor: Pointer): Boolean;
+var
+ Info: PImageFormatInfo;
+ I, J, ImageWidthBytes, RectWidthBytes, Bpp: Longint;
+ LinePointer, PixPointer: PByte;
+ OldFmt: TImageFormat;
+begin
+ Result := False;
+ if TestImage(Image) then
+ try
+ ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height));
+
+ if (Width > 0) and (Height > 0) then
+ begin
+ OldFmt := Image.Format;
+ if ImageFormatInfos[OldFmt].IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ Info := ImageFormatInfos[Image.Format];
+ Bpp := Info.BytesPerPixel;
+ ImageWidthBytes := Image.Width * Bpp;
+ RectWidthBytes := Width * Bpp;
+ LinePointer := @PByteArray(Image.Bits)[Y * ImageWidthBytes + X * Bpp];
+
+ for I := 0 to Height - 1 do
+ begin
+ case Bpp of
+ 1: FillMemoryByte(LinePointer, RectWidthBytes, PByte(FillColor)^);
+ 2: FillMemoryWord(LinePointer, RectWidthBytes, PWord(FillColor)^);
+ 4: FillMemoryLongWord(LinePointer, RectWidthBytes, PLongWord(FillColor)^);
+ else
+ PixPointer := LinePointer;
+ for J := 0 to Width - 1 do
+ begin
+ CopyPixel(FillColor, PixPointer, Bpp);
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+ Inc(LinePointer, ImageWidthBytes);
+ end;
+
+ if OldFmt <> Image.Format then
+ ConvertImage(Image, OldFmt);
+ end;
+
+ Result := True;
+ except
+ RaiseImaging(SErrorFillRect, [X, Y, Width, Height, ImageToStr(Image)]);
+ end;
+end;
+
+function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
+ OldColor, NewColor: Pointer): Boolean;
+var
+ Info: PImageFormatInfo;
+ I, J, WidthBytes, Bpp: Longint;
+ LinePointer, PixPointer: PByte;
+ OldFmt: TImageFormat;
+begin
+ Assert((OldColor <> nil) and (NewColor <> nil));
+ Result := False;
+ if TestImage(Image) then
+ try
+ ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height));
+
+ if (Width > 0) and (Height > 0) then
+ begin
+ OldFmt := Image.Format;
+ if ImageFormatInfos[OldFmt].IsSpecial then
+ ConvertImage(Image, ifDefault);
+
+ Info := ImageFormatInfos[Image.Format];
+ Bpp := Info.BytesPerPixel;
+ WidthBytes := Image.Width * Bpp;
+ LinePointer := @PByteArray(Image.Bits)[Y * WidthBytes + X * Bpp];
+
+ for I := 0 to Height - 1 do
+ begin
+ PixPointer := LinePointer;
+ for J := 0 to Width - 1 do
+ begin
+ if ComparePixels(PixPointer, OldColor, Bpp) then
+ CopyPixel(NewColor, PixPointer, Bpp);
+ Inc(PixPointer, Bpp);
+ end;
+ Inc(LinePointer, WidthBytes);
+ end;
+
+ if OldFmt <> Image.Format then
+ ConvertImage(Image, OldFmt);
+ end;
+
+ Result := True;
+ except
+ RaiseImaging(SErrorReplaceColor, [X, Y, Width, Height, ImageToStr(Image)]);
+ end;
+end;
+
+function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TResizeFilter): Boolean;
+var
+ Info: PImageFormatInfo;
+ WorkImage: TImageData;
+ OldFormat: TImageFormat;
+begin
+ Result := False;
+ OldFormat := ifUnknown;
+ if TestImage(SrcImage) and TestImage(DstImage) then
+ try
+ // Make sure we are still copying image to image, not invalid pointer to protected memory
+ ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, DstWidth, DstHeight,
+ SrcImage.Width, SrcImage.Height, Rect(0, 0, DstImage.Width, DstImage.Height));
+
+ if (SrcWidth = DstWidth) and (SrcHeight = DstHeight) then
+ begin
+ // If source and dest rectangles have the same size call CopyRect
+ Result := CopyRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY);
+ end
+ else if (SrcWidth > 0) and (SrcHeight > 0) and (DstWidth > 0) and (DstHeight > 0) then
+ begin
+ // If source and dest rectangles don't have the same size we do stretch
+ Info := ImageFormatInfos[DstImage.Format];
+
+ if Info.IsSpecial then
+ begin
+ // If dest image is in special format we convert it to default
+ OldFormat := Info.Format;
+ ConvertImage(DstImage, ifDefault);
+ Info := ImageFormatInfos[DstImage.Format];
+ end;
+
+ if SrcImage.Format <> DstImage.Format then
+ begin
+ // If images are in different format source is converted to dest's format
+ InitImage(WorkImage);
+ CloneImage(SrcImage, WorkImage);
+ ConvertImage(WorkImage, DstImage.Format);
+ end
+ else
+ WorkImage := SrcImage;
+
+ // Only pixel resize is supported for indexed images
+ if Info.IsIndexed then
+ Filter := rfNearest;
+
+ case Filter of
+ rfNearest: StretchNearest(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage, DstX, DstY, DstWidth, DstHeight);
+ rfBilinear: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage, DstX, DstY, DstWidth, DstHeight, sfLinear);
+ rfBicubic: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage, DstX, DstY, DstWidth, DstHeight, sfCatmullRom);
+ end;
+
+ // If dest image was in special format we convert it back
+ if OldFormat <> ifUnknown then
+ ConvertImage(DstImage, OldFormat);
+ // Working image must be freed if it is not the same as source image
+ if WorkImage.Bits <> SrcImage.Bits then
+ FreeImage(WorkImage);
+
+ Result := True;
+ end;
+ except
+ RaiseImaging(SErrorStretchRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]);
+ end;
+end;
+
+procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+var
+ BytesPerPixel: LongInt;
+begin
+ Assert(Pixel <> nil);
+ BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
+ CopyPixel(@PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel],
+ Pixel, BytesPerPixel);
+end;
+
+procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+var
+ BytesPerPixel: LongInt;
+begin
+ Assert(Pixel <> nil);
+ BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
+ CopyPixel(Pixel, @PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel],
+ BytesPerPixel);
+end;
+
+function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec;
+var
+ Info: PImageFormatInfo;
+ Data: PByte;
+begin
+ Info := ImageFormatInfos[Image.Format];
+ Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel];
+ Result := GetPixel32Generic(Data, Info, Image.Palette);
+end;
+
+procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
+var
+ Info: PImageFormatInfo;
+ Data: PByte;
+begin
+ Info := ImageFormatInfos[Image.Format];
+ Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel];
+ SetPixel32Generic(Data, Info, Image.Palette, Color);
+end;
+
+function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec;
+var
+ Info: PImageFormatInfo;
+ Data: PByte;
+begin
+ Info := ImageFormatInfos[Image.Format];
+ Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel];
+ Result := GetPixelFPGeneric(Data, Info, Image.Palette);
+end;
+
+procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
+var
+ Info: PImageFormatInfo;
+ Data: PByte;
+begin
+ Info := ImageFormatInfos[Image.Format];
+ Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel];
+ SetPixelFPGeneric(Data, Info, Image.Palette, Color);
+end;
+
+{ Palette Functions }
+
+procedure NewPalette(Entries: LongInt; var Pal: PPalette32);
+begin
+ Assert((Entries > 2) and (Entries <= 65535));
+ try
+ GetMem(Pal, Entries * SizeOf(TColor32Rec));
+ FillChar(Pal^, Entries * SizeOf(TColor32Rec), $FF);
+ except
+ RaiseImaging(SErrorNewPalette, [Entries]);
+ end;
+end;
+
+procedure FreePalette(var Pal: PPalette32);
+begin
+ try
+ FreeMemNil(Pal);
+ except
+ RaiseImaging(SErrorFreePalette, [Pal]);
+ end;
+end;
+
+procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt);
+begin
+ Assert((SrcPal <> nil) and (DstPal <> nil));
+ Assert((SrcIdx >= 0) and (DstIdx >= 0) and (Count >= 0));
+ try
+ Move(SrcPal[SrcIdx], DstPal[DstIdx], Count * SizeOf(TColor32Rec));
+ except
+ RaiseImaging(SErrorCopyPalette, [Count, SrcPal, DstPal]);
+ end;
+end;
+
+function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32):
+ LongInt;
+var
+ Col: TColor32Rec;
+ I, MinDif, Dif: LongInt;
+begin
+ Assert(Pal <> nil);
+ Result := -1;
+ Col.Color := Color;
+ try
+ // First try to find exact match
+ for I := 0 to Entries - 1 do
+ with Pal[I] do
+ begin
+ if (A = Col.A) and (R = Col.R) and
+ (G = Col.G) and (B = Col.B) then
+ begin
+ Result := I;
+ Exit;
+ end;
+ end;
+
+ // If exact match was not found, find nearest color
+ MinDif := 1020;
+ for I := 0 to Entries - 1 do
+ with Pal[I] do
+ begin
+ Dif := Abs(R - Col.R);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(G - Col.G);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(B - Col.B);
+ if Dif > MinDif then Continue;
+ Dif := Dif + Abs(A - Col.A);
+ if Dif < MinDif then
+ begin
+ MinDif := Dif;
+ Result := I;
+ end;
+ end;
+ except
+ RaiseImaging(SErrorFindColor, [Pal, Entries]);
+ end;
+end;
+
+procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt);
+var
+ I: LongInt;
+begin
+ Assert(Pal <> nil);
+ try
+ for I := 0 to Entries - 1 do
+ with Pal[I] do
+ begin
+ A := $FF;
+ R := Byte(I);
+ G := Byte(I);
+ B := Byte(I);
+ end;
+ except
+ RaiseImaging(SErrorGrayscalePalette, [Pal, Entries]);
+ end;
+end;
+
+procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
+ BBits: Byte; Alpha: Byte = $FF);
+var
+ I, TotalBits, MaxEntries: LongInt;
+begin
+ Assert(Pal <> nil);
+ TotalBits := RBits + GBits + BBits;
+ MaxEntries := Min(Pow2Int(TotalBits), Entries);
+ FillChar(Pal^, Entries * SizeOf(TColor32Rec), 0);
+ try
+ for I := 0 to MaxEntries - 1 do
+ with Pal[I] do
+ begin
+ A := Alpha;
+ if RBits > 0 then
+ R := ((I shr Max(0, GBits + BBits - 1)) and (1 shl RBits - 1)) * 255 div (1 shl RBits - 1);
+ if GBits > 0 then
+ G := ((I shr Max(0, BBits - 1)) and (1 shl GBits - 1)) * 255 div (1 shl GBits - 1);
+ if BBits > 0 then
+ B := ((I shr 0) and (1 shl BBits - 1)) * 255 div (1 shl BBits - 1);
+ end;
+ except
+ RaiseImaging(SErrorCustomPalette, [Pal, Entries]);
+ end;
+end;
+
+procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
+ DstChannel: LongInt);
+var
+ I: LongInt;
+ Swap: Byte;
+begin
+ Assert(Pal <> nil);
+ Assert((SrcChannel in [0..3]) and (DstChannel in [0..3]));
+ try
+ for I := 0 to Entries - 1 do
+ with Pal[I] do
+ begin
+ Swap := Channels[SrcChannel];
+ Channels[SrcChannel] := Channels[DstChannel];
+ Channels[DstChannel] := Swap;
+ end;
+ except
+ RaiseImaging(SErrorSwapPalette, [Pal, Entries]);
+ end;
+end;
+
+{ Options Functions }
+
+function SetOption(OptionId, Value: LongInt): Boolean;
+begin
+ Result := False;
+ if (OptionId >= 0) and (OptionId < Length(Options)) and
+ (Options[OptionID] <> nil) then
+ begin
+ Options[OptionID]^ := CheckOptionValue(OptionId, Value);
+ Result := True;
+ end;
+end;
+
+function GetOption(OptionId: LongInt): LongInt;
+begin
+ Result := InvalidOption;
+ if (OptionId >= 0) and (OptionId < Length(Options)) and
+ (Options[OptionID] <> nil) then
+ begin
+ Result := Options[OptionID]^;
+ end;
+end;
+
+function PushOptions: Boolean;
+begin
+ Result := OptionStack.Push;
+end;
+
+function PopOptions: Boolean;
+begin
+ Result := OptionStack.Pop;
+end;
+
+{ Image Format Functions }
+
+function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
+begin
+ FillChar(Info, SizeOf(Info), 0);
+ if ImageFormatInfos[Format] <> nil then
+ begin
+ Info := ImageFormatInfos[Format]^;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ if ImageFormatInfos[Format] <> nil then
+ Result := ImageFormatInfos[Format].GetPixelsSize(Format, Width, Height)
+ else
+ Result := 0;
+end;
+
+{ IO Functions }
+
+procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
+ TOpenWriteProc;
+ CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; TellProc:
+ TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
+begin
+ FileIO.OpenRead := OpenReadProc;
+ FileIO.OpenWrite := OpenWriteProc;
+ FileIO.Close := CloseProc;
+ FileIO.Eof := EofProc;
+ FileIO.Seek := SeekProc;
+ FileIO.Tell := TellProc;
+ FileIO.Read := ReadProc;
+ FileIO.Write := WriteProc;
+end;
+
+procedure ResetFileIO;
+begin
+ FileIO := OriginalFileIO;
+end;
+
+
+{ ------------------------------------------------------------------------
+ Other Imaging Stuff
+ ------------------------------------------------------------------------}
+
+function GetFormatName(Format: TImageFormat): string;
+begin
+ if ImageFormatInfos[Format] <> nil then
+ Result := ImageFormatInfos[Format].Name
+ else
+ Result := SUnknownFormat;
+end;
+
+function ImageToStr(const Image: TImageData): string;
+var
+ ImgSize: Integer;
+begin
+ if TestImage(Image) then
+ with Image do
+ begin
+ ImgSize := Size;
+ if ImgSize > 8192 then
+ ImgSize := ImgSize div 1024;
+ Result := SysUtils.Format(SImageInfo, [@Image, Width, Height,
+ GetFormatName(Format), ImgSize + 0.0, Iff(ImgSize = Size, 'B', 'KiB'), Bits,
+ Palette]);
+ end
+ else
+ Result := SysUtils.Format(SImageInfoInvalid, [@Image]);
+end;
+
+function GetVersionStr: string;
+begin
+ Result := Format('%.1d.%.2d.%.1d', [ImagingVersionMajor,
+ ImagingVersionMinor, ImagingVersionPatch]);
+end;
+
+function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
+begin
+ Assert(AClass <> nil);
+ if ImageFileFormats = nil then
+ ImageFileFormats := TList.Create;
+ if ImageFileFormats <> nil then
+ ImageFileFormats.Add(AClass.Create);
+end;
+
+function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean;
+begin
+ Result := False;
+ if Options = nil then
+ InitOptions;
+
+ Assert(Variable <> nil);
+
+ if OptionId >= Length(Options) then
+ SetLength(Options, OptionId + InitialOptions);
+ if (OptionId >= 0) and (OptionId < Length(Options)) {and (Options[OptionId] = nil) - must be able to override existing } then
+ begin
+ Options[OptionId] := Variable;
+ Result := True;
+ end;
+end;
+
+function FindImageFileFormatByExt(const Ext: string): TImageFileFormat;
+var
+ I: LongInt;
+begin
+ Result := nil;
+ for I := ImageFileFormats.Count - 1 downto 0 do
+ if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then
+ begin
+ Result := TImageFileFormat(ImageFileFormats[I]);
+ Exit;
+ end;
+end;
+
+function FindImageFileFormatByName(const FileName: string): TImageFileFormat;
+var
+ I: LongInt;
+begin
+ Result := nil;
+ for I := ImageFileFormats.Count - 1 downto 0 do
+ if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then
+ begin
+ Result := TImageFileFormat(ImageFileFormats[I]);
+ Exit;
+ end;
+end;
+
+function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat;
+var
+ I: LongInt;
+begin
+ Result := nil;
+ for I := 0 to ImageFileFormats.Count - 1 do
+ if TImageFileFormat(ImageFileFormats[I]) is AClass then
+ begin
+ Result := TObject(ImageFileFormats[I]) as TImageFileFormat;
+ Break;
+ end;
+end;
+
+function GetFileFormatCount: LongInt;
+begin
+ Result := ImageFileFormats.Count;
+end;
+
+function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat;
+begin
+ if (Index >= 0) and (Index < ImageFileFormats.Count) then
+ Result := TImageFileFormat(ImageFileFormats[Index])
+ else
+ Result := nil;
+end;
+
+function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string;
+var
+ I, J, Count: LongInt;
+ Descriptions: string;
+ Filters, CurFilter: string;
+ FileFormat: TImageFileFormat;
+begin
+ Descriptions := '';
+ Filters := '';
+ Count := 0;
+
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat;
+
+ // If we are creating filter for save dialog and this format cannot save
+ // files the we skip it
+ if not OpenFileFilter and not FileFormat.CanSave then
+ Continue;
+
+ CurFilter := '';
+ for J := 0 to FileFormat.Masks.Count - 1 do
+ begin
+ CurFilter := CurFilter + FileFormat.Masks[J];
+ if J < FileFormat.Masks.Count - 1 then
+ CurFilter := CurFilter + ';';
+ end;
+
+ FmtStr(Descriptions, '%s%s (%s)|%2:s', [Descriptions, FileFormat.Name, CurFilter]);
+ if Filters <> '' then
+ FmtStr(Filters, '%s;%s', [Filters, CurFilter])
+ else
+ Filters := CurFilter;
+
+ if I < ImageFileFormats.Count - 1 then
+ Descriptions := Descriptions + '|';
+
+ Inc(Count);
+ end;
+
+ if (Count > 1) and OpenFileFilter then
+ FmtStr(Descriptions, '%s (%s)|%1:s|%s', [SAllFilter, Filters, Descriptions]);
+
+ Result := Descriptions;
+end;
+
+function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string;
+var
+ I, Count: LongInt;
+ FileFormat: TImageFileFormat;
+begin
+ // -1 because filter indices are in 1..n range
+ Index := Index - 1;
+ Result := '';
+ if OpenFileFilter then
+ begin
+ if Index > 0 then
+ Index := Index - 1;
+ end;
+
+ if (Index >= 0) and (Index < ImageFileFormats.Count) then
+ begin
+ Count := 0;
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat;
+ if not OpenFileFilter and not FileFormat.CanSave then
+ Continue;
+ if Index = Count then
+ begin
+ if FileFormat.Extensions.Count > 0 then
+ Result := FileFormat.Extensions[0];
+ Exit;
+ end;
+ Inc(Count);
+ end;
+ end;
+end;
+
+function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt;
+var
+ I: LongInt;
+ FileFormat: TImageFileFormat;
+begin
+ Result := 0;
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat;
+ if not OpenFileFilter and not FileFormat.CanSave then
+ Continue;
+ if FileFormat.TestFileName(FileName) then
+ begin
+ // +1 because filter indices are in 1..n range
+ Inc(Result);
+ if OpenFileFilter then
+ Inc(Result);
+ Exit;
+ end;
+ Inc(Result);
+ end;
+ Result := -1;
+end;
+
+function GetIO: TIOFunctions;
+begin
+ Result := IO;
+end;
+
+procedure RaiseImaging(const Msg: string; const Args: array of const);
+var
+ WholeMsg: string;
+begin
+ WholeMsg := Msg;
+ if GetExceptObject <> nil then
+ WholeMsg := WholeMsg + ' ' + SExceptMsg + ': ' +
+ GetExceptObject.Message;
+ raise EImagingError.CreateFmt(WholeMsg, Args);
+end;
+
+{ Internal unit functions }
+
+function CheckOptionValue(OptionId, Value: LongInt): LongInt;
+begin
+ case OptionId of
+ ImagingColorReductionMask:
+ Result := ClampInt(Value, 0, $FF);
+ ImagingLoadOverrideFormat, ImagingSaveOverrideFormat:
+ Result := Iff(ImagingFormats.IsImageFormatValid(TImageFormat(Value)),
+ Value, LongInt(ifUnknown));
+ ImagingMipMapFilter: Result := ClampInt(Value, Ord(Low(TSamplingFilter)),
+ Ord(High(TSamplingFilter)));
+ else
+ Result := Value;
+ end;
+end;
+
+procedure SetFileIO;
+begin
+ IO := FileIO;
+end;
+
+procedure SetStreamIO;
+begin
+ IO := StreamIO;
+end;
+
+procedure SetMemoryIO;
+begin
+ IO := MemoryIO;
+end;
+
+procedure InitImageFormats;
+begin
+ ImagingFormats.InitImageFormats(ImageFormatInfos);
+end;
+
+procedure FreeImageFileFormats;
+var
+ I: LongInt;
+begin
+ if ImageFileFormats <> nil then
+ for I := 0 to ImageFileFormats.Count - 1 do
+ TImageFileFormat(ImageFileFormats[I]).Free;
+ FreeAndNil(ImageFileFormats);
+end;
+
+procedure InitOptions;
+begin
+ SetLength(Options, InitialOptions);
+ OptionStack := TOptionStack.Create;
+end;
+
+procedure FreeOptions;
+begin
+ SetLength(Options, 0);
+ FreeAndNil(OptionStack);
+end;
+
+{
+ TImageFileFormat class implementation
+}
+
+constructor TImageFileFormat.Create;
+begin
+ inherited Create;
+ FName := SUnknownFormat;
+ FExtensions := TStringList.Create;
+ FMasks := TStringList.Create;
+end;
+
+destructor TImageFileFormat.Destroy;
+begin
+ FExtensions.Free;
+ FMasks.Free;
+ inherited Destroy;
+end;
+
+function TImageFileFormat.PrepareLoad(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean;
+begin
+ FreeImagesInArray(Images);
+ SetLength(Images, 0);
+ Result := Handle <> nil;
+end;
+
+function TImageFileFormat.PostLoadCheck(var Images: TDynImageDataArray;
+ LoadResult: Boolean): Boolean;
+var
+ I: LongInt;
+begin
+ if not LoadResult then
+ begin
+ FreeImagesInArray(Images);
+ SetLength(Images, 0);
+ Result := False;
+ end
+ else
+ begin
+ Result := (Length(Images) > 0) and TestImagesInArray(Images);
+
+ if Result then
+ begin
+ // Convert to overriden format if it is set
+ if LoadOverrideFormat <> ifUnknown then
+ for I := Low(Images) to High(Images) do
+ ConvertImage(Images[I], LoadOverrideFormat);
+ end;
+ end;
+end;
+
+function TImageFileFormat.PrepareSave(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; var Index: Integer): Boolean;
+var
+ Len, I: LongInt;
+begin
+ CheckOptionsValidity;
+ Result := False;
+ if FCanSave then
+ begin
+ Len := Length(Images);
+ Assert(Len > 0);
+
+ // If there are no images to be saved exit
+ if Len = 0 then Exit;
+
+ // Check index of image to be saved (-1 as index means save all images)
+ if FIsMultiImageFormat then
+ begin
+ if (Index >= Len) then
+ Index := 0;
+
+ if Index < 0 then
+ begin
+ Index := 0;
+ FFirstIdx := 0;
+ FLastIdx := Len - 1;
+ end
+ else
+ begin
+ FFirstIdx := Index;
+ FLastIdx := Index;
+ end;
+
+ for I := FFirstIdx to FLastIdx - 1 do
+ if not TestImage(Images[I]) then
+ Exit;
+ end
+ else
+ begin
+ if (Index >= Len) or (Index < 0) then
+ Index := 0;
+ if not TestImage(Images[Index]) then
+ Exit;
+ end;
+
+ Result := True;
+ end;
+end;
+
+procedure TImageFileFormat.AddMasks(const AMasks: string);
+var
+ I: LongInt;
+ Ext: string;
+begin
+ FExtensions.Clear;
+ FMasks.CommaText := AMasks;
+ FMasks.Delimiter := ';';
+
+ for I := 0 to FMasks.Count - 1 do
+ begin
+ FMasks[I] := Trim(FMasks[I]);
+ Ext := GetFileExt(FMasks[I]);
+ if (Ext <> '') and (Ext <> '*') then
+ FExtensions.Add(Ext);
+ end;
+end;
+
+function TImageFileFormat.GetFormatInfo(Format: TImageFormat): TImageFormatInfo;
+begin
+ Result := ImageFormatInfos[Format]^;
+end;
+
+function TImageFileFormat.GetSupportedFormats: TImageFormats;
+begin
+ Result := FSupportedFormats;
+end;
+
+function TImageFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean;
+begin
+ Result := False;
+ RaiseImaging(SFileFormatCanNotLoad, [FName]);
+end;
+
+function TImageFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+begin
+ Result := False;
+ RaiseImaging(SFileFormatCanNotSave, [FName]);
+end;
+
+procedure TImageFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+end;
+
+function TImageFileFormat.IsSupported(const Image: TImageData): Boolean;
+begin
+ Result := Image.Format in GetSupportedFormats;
+end;
+
+function TImageFileFormat.LoadFromFile(const FileName: string;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+begin
+ Result := False;
+ if FCanLoad then
+ try
+ // Set IO ops to file ops and open given file
+ SetFileIO;
+ Handle := IO.OpenRead(PChar(FileName));
+ try
+ // Test if file contains valid image and if so then load it
+ if TestFormat(Handle) then
+ begin
+ Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
+ LoadData(Handle, Images, OnlyFirstlevel);
+ Result := Result and PostLoadCheck(Images, Result);
+ end
+ else
+ RaiseImaging(SFileNotValid, [FileName, Name]);
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ RaiseImaging(SErrorLoadingFile, [FileName, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.LoadFromStream(Stream: TStream;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+ OldPosition: Int64;
+begin
+ Result := False;
+ OldPosition := Stream.Position;
+ if FCanLoad then
+ try
+ // Set IO ops to stream ops and "open" given memory
+ SetStreamIO;
+ Handle := IO.OpenRead(Pointer(Stream));
+ try
+ // Test if stream contains valid image and if so then load it
+ if TestFormat(Handle) then
+ begin
+ Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
+ LoadData(Handle, Images, OnlyFirstlevel);
+ Result := Result and PostLoadCheck(Images, Result);
+ end
+ else
+ RaiseImaging(SStreamNotValid, [@Stream, Name]);
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ Stream.Position := OldPosition;
+ RaiseImaging(SErrorLoadingStream, [@Stream, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.LoadFromMemory(Data: Pointer; Size: LongInt; var
+ Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+ IORec: TMemoryIORec;
+begin
+ Result := False;
+ if FCanLoad then
+ try
+ // Set IO ops to memory ops and "open" given memory
+ SetMemoryIO;
+ IORec := PrepareMemIO(Data, Size);
+ Handle := IO.OpenRead(@IORec);
+ try
+ // Test if memory contains valid image and if so then load it
+ if TestFormat(Handle) then
+ begin
+ Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
+ LoadData(Handle, Images, OnlyFirstlevel);
+ Result := Result and PostLoadCheck(Images, Result);
+ end
+ else
+ RaiseImaging(SMemoryNotValid, [Data, Size, Name]);
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ RaiseImaging(SErrorLoadingMemory, [Data, Size, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.SaveToFile(const FileName: string;
+ const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+ Len, Index, I: LongInt;
+ Ext, FName: string;
+begin
+ Result := False;
+ if FCanSave and TestImagesInArray(Images) then
+ try
+ SetFileIO;
+ Len := Length(Images);
+ if FIsMultiImageFormat or
+ (not FIsMultiImageFormat and (OnlyFirstLevel or (Len = 1))) then
+ begin
+ Handle := IO.OpenWrite(PChar(FileName));
+ try
+ if OnlyFirstLevel then
+ Index := 0
+ else
+ Index := -1;
+ // Write multi image to one file
+ Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index);
+ finally
+ IO.Close(Handle);
+ end;
+ end
+ else
+ begin
+ // Write multi image to file sequence
+ Ext := ExtractFileExt(FileName);
+ FName := ChangeFileExt(FileName, '');
+ Result := True;
+ for I := 0 to Len - 1 do
+ begin
+ Handle := IO.OpenWrite(PChar(Format(FName + '%.3d' + Ext, [I])));
+ try
+ Index := I;
+ Result := Result and PrepareSave(Handle, Images, Index) and
+ SaveData(Handle, Images, Index);
+ if not Result then
+ Break;
+ finally
+ IO.Close(Handle);
+ end;
+ end;
+ end;
+ except
+ RaiseImaging(SErrorSavingFile, [FileName, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.SaveToStream(Stream: TStream;
+ const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+ Len, Index, I: LongInt;
+ OldPosition: Int64;
+begin
+ Result := False;
+ OldPosition := Stream.Position;
+ if FCanSave and TestImagesInArray(Images) then
+ try
+ SetStreamIO;
+ Handle := IO.OpenWrite(PChar(Stream));
+ try
+ if FIsMultiImageFormat or OnlyFirstLevel then
+ begin
+ if OnlyFirstLevel then
+ Index := 0
+ else
+ Index := -1;
+ // Write multi image in one run
+ Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index);
+ end
+ else
+ begin
+ // Write multi image to sequence
+ Result := True;
+ Len := Length(Images);
+ for I := 0 to Len - 1 do
+ begin
+ Index := I;
+ Result := Result and PrepareSave(Handle, Images, Index) and
+ SaveData(Handle, Images, Index);
+ if not Result then
+ Break;
+ end;
+ end;
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ Stream.Position := OldPosition;
+ RaiseImaging(SErrorSavingStream, [@Stream, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.SaveToMemory(Data: Pointer; var Size: LongInt;
+ const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Handle: TImagingHandle;
+ Len, Index, I: LongInt;
+ IORec: TMemoryIORec;
+begin
+ Result := False;
+ if FCanSave and TestImagesInArray(Images) then
+ try
+ SetMemoryIO;
+ IORec := PrepareMemIO(Data, Size);
+ Handle := IO.OpenWrite(PChar(@IORec));
+ try
+ if FIsMultiImageFormat or OnlyFirstLevel then
+ begin
+ if OnlyFirstLevel then
+ Index := 0
+ else
+ Index := -1;
+ // Write multi image in one run
+ Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index);
+ end
+ else
+ begin
+ // Write multi image to sequence
+ Result := True;
+ Len := Length(Images);
+ for I := 0 to Len - 1 do
+ begin
+ Index := I;
+ Result := Result and PrepareSave(Handle, Images, Index) and
+ SaveData(Handle, Images, Index);
+ if not Result then
+ Break;
+ end;
+ end;
+ Size := IORec.Position;
+ finally
+ IO.Close(Handle);
+ end;
+ except
+ RaiseImaging(SErrorSavingMemory, [Data, Size, FExtensions[0]]);
+ end;
+end;
+
+function TImageFileFormat.MakeCompatible(const Image: TImageData;
+ var Compatible: TImageData; out MustBeFreed: Boolean): Boolean;
+begin
+ InitImage(Compatible);
+
+ if SaveOverrideFormat <> ifUnknown then
+ begin
+ // Save format override is active. Clone input and convert it to override format.
+ CloneImage(Image, Compatible);
+ ConvertImage(Compatible, SaveOverrideFormat);
+ // Now check if override format is supported by file format. If it is not
+ // then file format specific conversion (virtual method) is called.
+ Result := IsSupported(Compatible);
+ if not Result then
+ begin
+ ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format));
+ Result := IsSupported(Compatible);
+ end;
+ end // Add IsCompatible function! not only checking by Format
+ else if IsSupported(Image) then
+ begin
+ // No save format override and input is in format supported by this
+ // file format. Just copy Image's fields to Compatible
+ Compatible := Image;
+ Result := True;
+ end
+ else
+ begin
+ // No override and input's format is not compatible with file format.
+ // Clone it and the call file format specific conversion (virtual method).
+ CloneImage(Image, Compatible);
+ ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format));
+ Result := IsSupported(Compatible);
+ end;
+ // Tell the user that he must free Compatible after he's done with it
+ // (if necessary).
+ MustBeFreed := Image.Bits <> Compatible.Bits;
+end;
+
+function TImageFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+begin
+ Result := False;
+end;
+
+function TImageFileFormat.TestFileName(const FileName: string): Boolean;
+var
+ I: LongInt;
+ OnlyName: string;
+begin
+ OnlyName := ExtractFileName(FileName);
+ // For each mask test if filename matches it
+ for I := 0 to FMasks.Count - 1 do
+ if MatchFileNameMask(OnlyName, FMasks[I], False) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Result := False;
+end;
+
+procedure TImageFileFormat.CheckOptionsValidity;
+begin
+end;
+
+{ TOptionStack class implementation }
+
+constructor TOptionStack.Create;
+begin
+ inherited Create;
+ FPosition := -1;
+end;
+
+destructor TOptionStack.Destroy;
+var
+ I: LongInt;
+begin
+ for I := 0 to OptionStackDepth - 1 do
+ SetLength(FStack[I], 0);
+ inherited Destroy;
+end;
+
+function TOptionStack.Pop: Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ if FPosition >= 0 then
+ begin
+ SetLength(Options, Length(FStack[FPosition]));
+ for I := 0 to Length(FStack[FPosition]) - 1 do
+ if Options[I] <> nil then
+ Options[I]^ := FStack[FPosition, I];
+ Dec(FPosition);
+ Result := True;
+ end;
+end;
+
+function TOptionStack.Push: Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ if FPosition < OptionStackDepth - 1 then
+ begin
+ Inc(FPosition);
+ SetLength(FStack[FPosition], Length(Options));
+ for I := 0 to Length(Options) - 1 do
+ if Options[I] <> nil then
+ FStack[FPosition, I] := Options[I]^;
+ Result := True;
+ end;
+end;
+
+initialization
+{$IFDEF MEMCHECK}
+ {$IF CompilerVersion >= 18}
+ System.ReportMemoryLeaksOnShutdown := True;
+ {$IFEND}
+{$ENDIF}
+ if ImageFileFormats = nil then
+ ImageFileFormats := TList.Create;
+ InitImageFormats;
+ RegisterOption(ImagingColorReductionMask, @ColorReductionMask);
+ RegisterOption(ImagingLoadOverrideFormat, @LoadOverrideFormat);
+ RegisterOption(ImagingSaveOverrideFormat, @SaveOverrideFormat);
+ RegisterOption(ImagingMipMapFilter, @MipMapFilter);
+finalization
+ FreeOptions;
+ FreeImageFileFormats;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Extended RotateImage to allow arbitrary angle rotations.
+ - Reversed the order file formats list is searched so
+ if you register a new one it will be found sooner than
+ built in formats.
+ - Fixed memory leak in ResizeImage ocurring when resizing
+ indexed images.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Added position/size checks to LoadFromStream functions.
+ - Changed conditional compilation in impl. uses section to reflect changes
+ in LINK symbols.
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - GenerateMipMaps now generates all smaller levels from
+ original big image (better results when using more advanced filters).
+ Also conversion to compatible image format is now done here not
+ in FillMipMapLevel (that is called for every mipmap level).
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - MakePaletteForImages now works correctly for indexed and special format images
+ - Fixed bug in StretchRect: Image was not properly stretched if
+ src and dst dimensions differed only in height.
+ - ConvertImage now fills new image with zeroes to avoid random data in
+ some conversions (RGB->XRGB)
+ - Changed RegisterOption procedure to function
+ - Changed bunch of palette functions from low level interface to procedure
+ (there was no reason for them to be functions).
+ - Changed FreeImage and FreeImagesInArray functions to procedures.
+ - Added many assertions, come try-finally, other checks, and small code
+ and doc changes.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - GenerateMipMaps threw failed assertion when input was indexed or special,
+ fixed.
+ - Added CheckOptionsValidity to TImageFileFormat and its decendants.
+ - Unit ImagingExtras which registers file formats in Extras package
+ is now automatically added to uses clause if LINK_EXTRAS symbol is
+ defined in ImagingOptions.inc file.
+ - Added EnumFileFormats function to low level interface.
+ - Fixed bug in SwapChannels which could cause AV when swapping alpha
+ channel of A8R8G8B8 images.
+ - Converting loaded images to ImagingOverrideFormat is now done
+ in PostLoadCheck method to avoid code duplicity.
+ - Added GetFileFormatCount and GetFileFormatAtIndex functions
+ - Bug in ConvertImage: if some format was converted to similar format
+ only with swapped channels (R16G16B16<>B16G16R16) then channels were
+ swapped correctly but new data format (swapped one) was not set.
+ - Made TImageFileFormat.MakeCompatible public non-virtual method
+ (and modified its function). Created new virtual
+ ConvertToSupported which should be overriden by descendants.
+ Main reason for doint this is to avoid duplicate code that was in all
+ TImageFileFormat's descendants.
+ - Changed TImageFileFormat.GetFormatInfo's result type to TImageFormatInfo.
+ - Split overloaded FindImageFileFormat functions to
+ FindImageFileFormatByClass and FindImageFileFormatByExt and created new
+ FindImageFileFormatByName which operates on whole filenames.
+ - Function GetExtensionFilterIndex renamed to GetFileNameFilterIndex
+ (because it now works with filenames not extensions).
+ - DetermineFileFormat now first searches by filename and if not found
+ then by data.
+ - Added TestFileName method to TImageFileFormat.
+ - Updated GetImageFileFormatsFilter to uses Masks instead of Extensions
+ property of TImageFileFormat. Also you can now request
+ OpenDialog and SaveDialog type filters
+ - Added Masks property and AddMasks method to TImageFileFormat.
+ AddMasks replaces AddExtensions, it uses filename masks instead
+ of sime filename extensions to identify supported files.
+ - Changed TImageFileFormat.LoadData procedure to function and
+ moved varios duplicate code from its descandats (check index,...)
+ here to TImageFileFormat helper methods.
+ - Changed TImageFileFormat.SaveData procedure to function and
+ moved varios duplicate code from its descandats (check index,...)
+ here to TImageFileFormat helper methods.
+ - Removed RAISE_EXCEPTIONS define, exceptions are now raised everytime
+ - Added MustBeFreed parameter to TImageFileFormat.MakeComptible method
+ that indicates that compatible image returned by this method must be
+ freed after its usage.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - fixed bug in NewImage: if given format was ifDefault it wasn't
+ replaced with DefaultImageFormat constant which caused problems later
+ in other units
+ - fixed bug in RotateImage which caused that rotated special format
+ images were whole black
+ - LoadImageFromXXX and LoadMultiImageFromXXX now use DetermineXXXFormat
+ when choosing proper loader, this eliminated need for Ext parameter
+ in stream and memory loading functions
+ - added GetVersionStr function
+ - fixed bug in ResizeImage which caued indexed images to lose their
+ palette during process resulting in whole black image
+ - Clipping in ...Rect functions now uses clipping procs from ImagingUtility,
+ it also works better
+ - FillRect optimization for 8, 16, and 32 bit formats
+ - added pixel set/get functions to low level interface:
+ GetPixelDirect, SetPixelDirect, GetPixel32, SetPixel32,
+ GetPixelFP, SetPixelFP
+ - removed GetPixelBytes low level intf function - redundant
+ (same data can be obtained by GetImageFormatInfo)
+ - made small changes in many parts of library to compile
+ on AMD64 CPU (Linux with FPC)
+ - changed InitImage to procedure (function was pointless)
+ - Method TestFormat of TImageFileFormat class made public
+ (was protected)
+ - added function IsFileFormatSupported to low level interface
+ (contributed by Paul Michell)
+ - fixed some missing format arguments from error strings
+ which caused Format function to raise exception
+ - removed forgotten debug code that disabled filtered resizing of images with
+ channel bitcounts > 8
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - changed order of parameters of CopyRect function
+ - GenerateMipMaps now filters mipmap levels
+ - ResizeImage functions was extended to allow bilinear and bicubic filtering
+ - added StretchRect function to low level interface
+ - added functions GetImageFileFormatsFilter, GetFilterIndexExtension,
+ and GetExtensionFilterIndex
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - added function RotateImage to low level interface
+ - moved TImageFormatInfo record and types required by it to
+ ImagingTypes unit, changed GetImageFormatInfo low level
+ interface function to return TImageFormatInfo instead of short info
+ - added checking of options values validity before they are used
+ - fixed possible memory leak in CloneImage
+ - added ReplaceColor function to low level interface
+ - new function FindImageFileFormat by class added
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - added DetermineFileFormat, DetermineStreamFormat, DetermineMemoryFormat,
+ GetPixelsSize functions to low level interface
+ - added NewPalette, CopyPalette, FreePalette functions
+ to low level interface
+ - added MapImageToPalette, FillRect, SplitImage, MakePaletteForImages
+ functions to low level interface
+ - fixed buggy FillCustomPalette function (possible div by zero and others)
+ - added CopyRect function to low level interface
+ - Member functions of TImageFormatInfo record implemented for all formats
+ - before saving images TestImagesInArray is called now
+ - added TestImagesInArray function to low level interface
+ - added GenerateMipMaps function to low level interface
+ - stream position in load/save from/to stream is now set to position before
+ function was called if error occurs
+ - when error occured during load/save from/to file file handle
+ was not released
+ - CloneImage returned always False
+
+}
+end.
diff --git a/src/lib/vampimg/ImagingBitmap.pas b/src/lib/vampimg/ImagingBitmap.pas
--- /dev/null
@@ -0,0 +1,856 @@
+{
+ $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z 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 Info.PaletteEntries - 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.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed problem with indexed BMP loading - some pal entries
+ could end up with alpha=0.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingCanvases.pas b/src/lib/vampimg/ImagingCanvases.pas
--- /dev/null
@@ -0,0 +1,2176 @@
+{
+ $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z 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 canvas classes for drawing and applying effects.
+}
+unit ImagingCanvases;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses,
+ ImagingFormats, ImagingUtility;
+
+const
+ { Color constants in ifA8R8G8B8 format.}
+ pcClear = $00000000;
+ pcBlack = $FF000000;
+ pcWhite = $FFFFFFFF;
+ pcMaroon = $FF800000;
+ pcGreen = $FF008000;
+ pcOlive = $FF808000;
+ pcNavy = $FF000080;
+ pcPurple = $FF800080;
+ pcTeal = $FF008080;
+ pcGray = $FF808080;
+ pcSilver = $FFC0C0C0;
+ pcRed = $FFFF0000;
+ pcLime = $FF00FF00;
+ pcYellow = $FFFFFF00;
+ pcBlue = $FF0000FF;
+ pcFuchsia = $FFFF00FF;
+ pcAqua = $FF00FFFF;
+ pcLtGray = $FFC0C0C0;
+ pcDkGray = $FF808080;
+
+ MaxPenWidth = 256;
+
+type
+ EImagingCanvasError = class(EImagingError);
+ EImagingCanvasBlendingError = class(EImagingError);
+
+ { Fill mode used when drawing filled objects on canvas.}
+ TFillMode = (
+ fmSolid, // Solid fill using current fill color
+ fmClear // No filling done
+ );
+
+ { Pen mode used when drawing lines, object outlines, and similar on canvas.}
+ TPenMode = (
+ pmSolid, // Draws solid lines using current pen color.
+ pmClear // No drawing done
+ );
+
+ { Source and destination blending factors for drawing functions with blending.
+ Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
+ TBlendingFactor = (
+ bfIgnore, // Don't care
+ bfZero, // For Src and Dest, Factor = (0, 0, 0, 0)
+ bfOne, // For Src and Dest, Factor = (1, 1, 1, 1)
+ bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
+ bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
+ bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
+ bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
+ bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
+ bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
+ bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
+ bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
+ );
+
+ { Procedure for custom pixel write modes with blending.}
+ TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte;
+ DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
+
+ { Represents 3x3 convolution filter kernel.}
+ TConvolutionFilter3x3 = record
+ Kernel: array[0..2, 0..2] of LongInt;
+ Divisor: LongInt;
+ Bias: Single;
+ end;
+
+ { Represents 5x5 convolution filter kernel.}
+ TConvolutionFilter5x5 = record
+ Kernel: array[0..4, 0..4] of LongInt;
+ Divisor: LongInt;
+ Bias: Single;
+ end;
+
+ TPointTransformFunction = function(const Pixel: TColorFPRec;
+ Param1, Param2, Param3: Single): TColorFPRec;
+
+ TDynFPPixelArray = array of TColorFPRec;
+
+ THistogramArray = array[Byte] of Integer;
+
+ TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
+
+ { Base canvas class for drawing objects, applying effects, and other.
+ Constructor takes TBaseImage (or pointer to TImageData). Source image
+ bits are not copied but referenced so all canvas functions affect
+ source image and vice versa. When you change format or resolution of
+ source image you must call UpdateCanvasState method (so canvas could
+ recompute some data size related stuff).
+
+ TImagingCanvas works for all image data formats except special ones
+ (compressed). Because of this its methods are quite slow (they usually work
+ with colors in ifA32R32G32B32F format). If you want fast drawing you
+ can use one of fast canvas clases. These descendants of TImagingCanvas
+ work only for few select formats (or only one) but they are optimized thus
+ much faster.
+ }
+ TImagingCanvas = class(TObject)
+ private
+ FDataSizeOnUpdate: LongInt;
+ FLineRecursion: Boolean;
+ function GetPixel32(X, Y: LongInt): TColor32; virtual;
+ function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual;
+ function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual;
+ procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual;
+ procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPenWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetClipRect(const Value: TRect);
+ procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
+ protected
+ FPData: PImageData;
+ FClipRect: TRect;
+ FPenColorFP: TColorFPRec;
+ FPenColor32: TColor32;
+ FPenMode: TPenMode;
+ FPenWidth: LongInt;
+ FFillColorFP: TColorFPRec;
+ FFillColor32: TColor32;
+ FFillMode: TFillMode;
+ FNativeColor: TColorFPRec;
+ FFormatInfo: TImageFormatInfo;
+
+ { Returns pointer to pixel at given position.}
+ function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ { Translates given FP color to native format of canvas and stores it
+ in FNativeColor field (its bit copy) or user pointer (in overloaded method).}
+ procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ { Clipping function used by horizontal and vertical line drawing functions.}
+ function ClipAxisParallelLine(var A1, A2, B: LongInt;
+ AStart, AStop, BStart, BStop: LongInt): Boolean;
+ { Internal horizontal line drawer used mainly for filling inside of objects
+ like ellipses and circles.}
+ procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual;
+ procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
+ procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
+ Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
+ public
+ constructor CreateForData(ImageDataPointer: PImageData);
+ constructor CreateForImage(Image: TBaseImage);
+ destructor Destroy; override;
+
+ { Call this method when you change size or format of image this canvas
+ operates on (like calling ResizeImage, ConvertImage, or changing Format
+ property of TBaseImage descendants).}
+ procedure UpdateCanvasState; virtual;
+ { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).}
+ procedure ResetClipRect;
+
+ { Clears entire canvas with current fill color (ignores clipping rectangle
+ and always uses fmSolid fill mode).}
+ procedure Clear;
+
+ { Draws horizontal line with current pen settings.}
+ procedure HorzLine(X1, X2, Y: LongInt); virtual;
+ { Draws vertical line with current pen settings.}
+ procedure VertLine(X, Y1, Y2: LongInt); virtual;
+ { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.}
+ procedure Line(X1, Y1, X2, Y2: LongInt); virtual;
+ { Draws a rectangle using current pen settings.}
+ procedure FrameRect(const Rect: TRect);
+ { Fills given rectangle with current fill settings.}
+ procedure FillRect(const Rect: TRect); virtual;
+ { Fills given rectangle with current fill settings and pixel blending.}
+ procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor);
+ { Draws rectangle which is outlined by using the current pen settings and
+ filled by using the current fill settings.}
+ procedure Rectangle(const Rect: TRect);
+ { Draws ellipse which is outlined by using the current pen settings and
+ filled by using the current fill settings. Rect specifies bounding rectangle
+ of ellipse to be drawn.}
+ procedure Ellipse(const Rect: TRect);
+ { Fills area of canvas with current fill color starting at point [X, Y] and
+ coloring its neighbors. Default flood fill mode changes color of all
+ neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
+ set to True neighbors are recolored regardless of their old color,
+ but area which will be recolored has boundary (specified by current pen color).}
+ procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False);
+
+ { Draws contents of this canvas onto another canvas with pixel blending.
+ Blending factors are chosen using TBlendingFactor parameters.
+ Resulting destination pixel color is:
+ SrcColor * SrcFactor + DstColor * DstFactor}
+ procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
+ { Draws contents of this canvas onto another one with typical alpha
+ blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
+ procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual;
+ { Draws contents of this canvas onto another one using additive blending
+ (source and dest factors are bfOne).}
+ procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+ { Draws stretched and filtered contents of this canvas onto another canvas
+ with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
+ Resulting destination pixel color is:
+ SrcColor * SrcFactor + DstColor * DstFactor}
+ procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
+ Filter: TResizeFilter = rfBilinear);
+ { Draws contents of this canvas onto another one with typical alpha
+ blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
+ procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual;
+ { Draws contents of this canvas onto another one using additive blending
+ (source and dest factors are bfOne).}
+ procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
+
+ { Convolves canvas' image with given 3x3 filter kernel. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
+ { Convolves canvas' image with given 5x5 filter kernel. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
+ { Computes 2D convolution of canvas' image and given filter kernel.
+ Kernel is in row format and KernelSize must be odd number >= 3. Divisor
+ is normalizing value based on Kernel (usually sum of all kernel's cells).
+ The Bias number shifts each color value by a fixed amount (color values
+ are usually in range [0, 1] during processing). If ClampChannels
+ is True all output color values are clamped to [0, 1]. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt;
+ Bias: Single = 0.0; ClampChannels: Boolean = True); virtual;
+
+ { Applies custom non-linear filter. Filter size is diameter of pixel
+ neighborhood. Typical values are 3, 5, or 7. }
+ procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
+ { Applies median non-linear filter with user defined pixel neighborhood.
+ Selects median pixel from the neighborhood as new pixel
+ (current implementation is quite slow).}
+ procedure ApplyMedianFilter(FilterSize: Integer);
+ { Applies min non-linear filter with user defined pixel neighborhood.
+ Selects min pixel from the neighborhood as new pixel.}
+ procedure ApplyMinFilter(FilterSize: Integer);
+ { Applies max non-linear filter with user defined pixel neighborhood.
+ Selects max pixel from the neighborhood as new pixel.}
+ procedure ApplyMaxFilter(FilterSize: Integer);
+
+ { Transforms pixels one by one by given function. Pixel neighbors are
+ not taken into account. Param 1-3 are optional parameters
+ for transform function.}
+ procedure PointTransform(Transform: TPointTransformFunction;
+ Param1, Param2, Param3: Single);
+ { Modifies image contrast and brightness. Parameters should be
+ in range <-100; 100>.}
+ procedure ModifyContrastBrightness(Contrast, Brightness: Single);
+ { Gamma correction of individual color channels. Range is (0, +inf),
+ 1.0 means no change.}
+ procedure GammaCorection(Red, Green, Blue: Single);
+ { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
+ procedure InvertColors; virtual;
+ { Simple single level thresholding with threshold level (in range [0, 1])
+ for each color channel.}
+ procedure Threshold(Red, Green, Blue: Single);
+ { Adjusts the color levels of the image by scaling the
+ colors falling between specified white and black points to full [0, 1] range.
+ The black point specifies the darkest color in the image, white point
+ specifies the lightest color, and mid point is gamma aplied to image.
+ Black and white point must be in range [0, 1].}
+ procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0);
+ { Premultiplies color channel values by alpha. Needed for some platforms/APIs
+ to display images with alpha properly.}
+ procedure PremultiplyAlpha;
+ { Reverses PremultiplyAlpha operation.}
+ procedure UnPremultiplyAlpha;
+
+ { Calculates image histogram for each channel and also gray values. Each
+ channel has 256 values available. Channel values of data formats with higher
+ precision are scaled and rounded. Example: Red[126] specifies number of pixels
+ in image with red channel = 126.}
+ procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray);
+ { Fills image channel with given value leaving other channels intact.
+ Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+ channel identifier.}
+ procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload;
+ { Fills image channel with given value leaving other channels intact.
+ Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+ channel identifier.}
+ procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload;
+
+ { Color used when drawing lines, frames, and outlines of objects.}
+ property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
+ { Color used when drawing lines, frames, and outlines of objects.}
+ property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP;
+ { Pen mode used when drawing lines, object outlines, and similar on canvas.}
+ property PenMode: TPenMode read FPenMode write FPenMode;
+ { Width with which objects like lines, frames, etc. (everything which uses
+ PenColor) are drawn.}
+ property PenWidth: LongInt read FPenWidth write SetPenWidth;
+ { Color used for filling when drawing various objects.}
+ property FillColor32: TColor32 read FFillColor32 write SetFillColor32;
+ { Color used for filling when drawing various objects.}
+ property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP;
+ { Fill mode used when drawing filled objects on canvas.}
+ property FillMode: TFillMode read FFillMode write FFillMode;
+ { Specifies the current color of the pixels of canvas. Native pixel is
+ read from canvas and then translated to 32bit ARGB. Reverse operation
+ is made when setting pixel color.}
+ property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32;
+ { Specifies the current color of the pixels of canvas. Native pixel is
+ read from canvas and then translated to FP ARGB. Reverse operation
+ is made when setting pixel color.}
+ property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP;
+ { Clipping rectangle of this canvas. No pixels outside this rectangle are
+ altered by canvas methods if Clipping property is True. Clip rect gets
+ reseted when UpdateCanvasState is called.}
+ property ClipRect: TRect read FClipRect write SetClipRect;
+ { Extended format information.}
+ property FormatInfo: TImageFormatInfo read FFormatInfo;
+ { Indicates that this canvas is in valid state. If False canvas oprations
+ may crash.}
+ property Valid: Boolean read GetValid;
+
+ { Returns all formats supported by this canvas class.}
+ class function GetSupportedFormats: TImageFormats; virtual;
+ end;
+
+ TImagingCanvasClass = class of TImagingCanvas;
+
+ TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray;
+ PScanlineArray = ^TScanlineArray;
+
+ { Fast canvas class for ifA8R8G8B8 format images.}
+ TFastARGB32Canvas = class(TImagingCanvas)
+ protected
+ FScanlines: PScanlineArray;
+ procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPixel32(X, Y: LongInt): TColor32; override;
+ procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
+ public
+ destructor Destroy; override;
+
+ procedure UpdateCanvasState; override;
+
+ procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
+ procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
+ procedure InvertColors; override;
+
+ property Scanlines: PScanlineArray read FScanlines;
+
+ class function GetSupportedFormats: TImageFormats; override;
+ end;
+
+const
+ { Kernel for 3x3 average smoothing filter.}
+ FilterAverage3x3: TConvolutionFilter3x3 = (
+ Kernel: ((1, 1, 1),
+ (1, 1, 1),
+ (1, 1, 1));
+ Divisor: 9);
+
+ { Kernel for 5x5 average smoothing filter.}
+ FilterAverage5x5: TConvolutionFilter5x5 = (
+ Kernel: ((1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1));
+ Divisor: 25);
+
+ { Kernel for 3x3 Gaussian smoothing filter.}
+ FilterGaussian3x3: TConvolutionFilter3x3 = (
+ Kernel: ((1, 2, 1),
+ (2, 4, 2),
+ (1, 2, 1));
+ Divisor: 16);
+
+ { Kernel for 5x5 Gaussian smoothing filter.}
+ FilterGaussian5x5: TConvolutionFilter5x5 = (
+ Kernel: ((1, 4, 6, 4, 1),
+ (4, 16, 24, 16, 4),
+ (6, 24, 36, 24, 6),
+ (4, 16, 24, 16, 4),
+ (1, 4, 6, 4, 1));
+ Divisor: 256);
+
+ { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
+ FilterSobelHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 1, 2, 1),
+ ( 0, 0, 0),
+ (-1, -2, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
+ FilterSobelVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, 0, 1),
+ (-2, 0, 2),
+ (-1, 0, 1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Prewitt horizontal edge detection filter.}
+ FilterPrewittHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 1, 1, 1),
+ ( 0, 0, 0),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Prewitt vertical edge detection filter.}
+ FilterPrewittVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, 0, 1),
+ (-1, 0, 1),
+ (-1, 0, 1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Kirsh horizontal edge detection filter.}
+ FilterKirshHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 5, 5, 5),
+ (-3, 0, -3),
+ (-3, -3, -3));
+ Divisor: 1);
+
+ { Kernel for 3x3 Kirsh vertical edge detection filter.}
+ FilterKirshVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((5, -3, -3),
+ (5, 0, -3),
+ (5, -3, -3));
+ Divisor: 1);
+
+ { Kernel for 3x3 Laplace omni-directional edge detection filter
+ (2nd derivative approximation).}
+ FilterLaplace3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -1, -1),
+ (-1, 8, -1),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 Laplace omni-directional edge detection filter
+ (2nd derivative approximation).}
+ FilterLaplace5x5: TConvolutionFilter5x5 = (
+ Kernel: ((-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, 24, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 spharpening filter (Laplacian + original color).}
+ FilterSharpen3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -1, -1),
+ (-1, 9, -1),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 spharpening filter (Laplacian + original color).}
+ FilterSharpen5x5: TConvolutionFilter5x5 = (
+ Kernel: ((-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, 25, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 glow filter.}
+ FilterGlow5x5: TConvolutionFilter5x5 = (
+ Kernel: (( 1, 2, 2, 2, 1),
+ ( 2, 0, 0, 0, 2),
+ ( 2, 0, -20, 0, 2),
+ ( 2, 0, 0, 0, 2),
+ ( 1, 2, 2, 2, 1));
+ Divisor: 8);
+
+ { Kernel for 3x3 edge enhancement filter.}
+ FilterEdgeEnhance3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -2, -1),
+ (-2, 16, -2),
+ (-1, -2, -1));
+ Divisor: 4);
+
+ { Kernel for 3x3 contour enhancement filter.}
+ FilterTraceControur3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-6, -6, -2),
+ (-1, 32, -1),
+ (-6, -2, -6));
+ Divisor: 4;
+ Bias: 240/255);
+
+ { Kernel for filter that negates all images pixels.}
+ FilterNegative3x3: TConvolutionFilter3x3 = (
+ Kernel: ((0, 0, 0),
+ (0, -1, 0),
+ (0, 0, 0));
+ Divisor: 1;
+ Bias: 1);
+
+ { Kernel for 3x3 horz/vert embossing filter.}
+ FilterEmboss3x3: TConvolutionFilter3x3 = (
+ Kernel: ((2, 0, 0),
+ (0, -1, 0),
+ (0, 0, -1));
+ Divisor: 1;
+ Bias: 0.5);
+
+
+{ You can register your own canvas class. List of registered canvases is used
+ by FindBestCanvasForImage functions to find best canvas for given image.
+ If two different canvases which support the same image data format are
+ registered then the one that was registered later is returned (so you can
+ override builtin Imaging canvases).}
+procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
+{ Returns best canvas for given TImageFormat.}
+function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
+{ Returns best canvas for given TImageData.}
+function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload;
+{ Returns best canvas for given TBaseImage.}
+function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload;
+
+implementation
+
+resourcestring
+ SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.';
+ SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).';
+ SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)';
+
+var
+ // list with all registered TImagingCanvas classes
+ CanvasClasses: TList = nil;
+
+procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
+begin
+ Assert(CanvasClass <> nil);
+ if CanvasClasses = nil then
+ CanvasClasses := TList.Create;
+ if CanvasClasses.IndexOf(CanvasClass) < 0 then
+ CanvasClasses.Add(CanvasClass);
+end;
+
+function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
+var
+ I: LongInt;
+begin
+ for I := CanvasClasses.Count - 1 downto 0 do
+ begin
+ if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then
+ begin
+ Result := TImagingCanvasClass(CanvasClasses[I]);
+ Exit;
+ end;
+ end;
+ Result := TImagingCanvas;
+end;
+
+function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass;
+begin
+ Result := FindBestCanvasForImage(ImageData.Format);
+end;
+
+function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass;
+begin
+ Result := FindBestCanvasForImage(Image.Format);
+end;
+
+{ Canvas helper functions }
+
+procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte;
+ DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
+var
+ DestPix, FSrc, FDst: TColorFPRec;
+begin
+ // Get set pixel color
+ DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
+ // Determine current blending factors
+ case SrcFactor of
+ bfZero: FSrc := ColorFP(0, 0, 0, 0);
+ bfOne: FSrc := ColorFP(1, 1, 1, 1);
+ bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A);
+ bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A);
+ bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A);
+ bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
+ bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B);
+ bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B);
+ end;
+ case DestFactor of
+ bfZero: FDst := ColorFP(0, 0, 0, 0);
+ bfOne: FDst := ColorFP(1, 1, 1, 1);
+ bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A);
+ bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A);
+ bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A);
+ bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
+ bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B);
+ bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B);
+ end;
+ // Compute blending formula
+ DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R;
+ DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G;
+ DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B;
+ DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A;
+ // Write blended pixel
+ DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
+end;
+
+procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte;
+ DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
+var
+ DestPix: TColorFPRec;
+ SrcAlpha, DestAlpha: Single;
+begin
+ DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
+ // Blend the two pixels (Src 'over' Dest alpha composition operation)
+ DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
+ SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
+ DestAlpha := 1.0 - SrcAlpha;
+ DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
+ DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
+ DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha;
+ // Write blended pixel
+ DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
+end;
+
+procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte;
+ DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
+var
+ DestPix: TColorFPRec;
+begin
+ // Just add Src and Dest
+ DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
+ DestPix.R := SrcPix.R + DestPix.R;
+ DestPix.G := SrcPix.G + DestPix.G;
+ DestPix.B := SrcPix.B + DestPix.B;
+ DestPix.A := SrcPix.A + DestPix.A;
+ DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
+end;
+
+function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) -
+ (C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B);
+end;
+
+function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
+
+ procedure QuickSort(L, R: Integer);
+ var
+ I, J: Integer;
+ P, Temp: TColorFPRec;
+ begin
+ repeat
+ I := L;
+ J := R;
+ P := Pixels[(L + R) shr 1];
+ repeat
+ while CompareColors(Pixels[I], P) < 0 do Inc(I);
+ while CompareColors(Pixels[J], P) > 0 do Dec(J);
+ if I <= J then
+ begin
+ Temp := Pixels[I];
+ Pixels[I] := Pixels[J];
+ Pixels[J] := Temp;
+ Inc(I);
+ Dec(J);
+ end;
+ until I > J;
+ if L < J then
+ QuickSort(L, J);
+ L := I;
+ until I >= R;
+ end;
+
+begin
+ // First sort pixels
+ QuickSort(0, High(Pixels));
+ // Select middle pixel
+ Result := Pixels[Length(Pixels) div 2];
+end;
+
+function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
+var
+ I: Integer;
+begin
+ Result := Pixels[0];
+ for I := 1 to High(Pixels) do
+ begin
+ if CompareColors(Pixels[I], Result) < 0 then
+ Result := Pixels[I];
+ end;
+end;
+
+function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
+var
+ I: Integer;
+begin
+ Result := Pixels[0];
+ for I := 1 to High(Pixels) do
+ begin
+ if CompareColors(Pixels[I], Result) > 0 then
+ Result := Pixels[I];
+ end;
+end;
+
+function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := Pixel.R * C + B;
+ Result.G := Pixel.G * C + B;
+ Result.B := Pixel.B * C + B;
+end;
+
+function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := Power(Pixel.R, 1.0 / R);
+ Result.G := Power(Pixel.G, 1.0 / G);
+ Result.B := Power(Pixel.B, 1.0 / B);
+end;
+
+function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := 1.0 - Pixel.R;
+ Result.G := 1.0 - Pixel.G;
+ Result.B := 1.0 - Pixel.B;
+end;
+
+function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0);
+ Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0);
+ Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0);
+end;
+
+function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ if Pixel.R > BlackPoint then
+ Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.R := 0.0;
+ if Pixel.G > BlackPoint then
+ Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.G := 0.0;
+ if Pixel.B > BlackPoint then
+ Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.B := 0.0;
+end;
+
+function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := Result.R * Pixel.A;
+ Result.G := Result.G * Pixel.A;
+ Result.B := Result.B * Pixel.A;
+end;
+
+function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ if Pixel.A <> 0.0 then
+ begin
+ Result.R := Result.R / Pixel.A;
+ Result.G := Result.G / Pixel.A;
+ Result.B := Result.B / Pixel.A;
+ end
+ else
+ begin
+ Result.R := 0;
+ Result.G := 0;
+ Result.B := 0;
+ end;
+end;
+
+
+{ TImagingCanvas class implementation }
+
+constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
+begin
+ if ImageDataPointer = nil then
+ raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]);
+
+ if not TestImage(ImageDataPointer^) then
+ raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]);
+
+ if not (ImageDataPointer.Format in GetSupportedFormats) then
+ raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]);
+
+ FPData := ImageDataPointer;
+ FPenWidth := 1;
+ SetPenColor32(pcWhite);
+ SetFillColor32(pcBlack);
+ FFillMode := fmSolid;
+
+ UpdateCanvasState;
+end;
+
+constructor TImagingCanvas.CreateForImage(Image: TBaseImage);
+begin
+ CreateForData(Image.ImageDataPointer);
+end;
+
+destructor TImagingCanvas.Destroy;
+begin
+ inherited Destroy;
+end;
+
+function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32;
+begin
+ Result := Imaging.GetPixel32(FPData^, X, Y).Color;
+end;
+
+function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec;
+begin
+ Result := Imaging.GetPixelFP(FPData^, X, Y);
+end;
+
+function TImagingCanvas.GetValid: Boolean;
+begin
+ Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size);
+end;
+
+procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value));
+ end;
+end;
+
+procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value));
+ end;
+end;
+
+procedure TImagingCanvas.SetPenColor32(const Value: TColor32);
+begin
+ FPenColor32 := Value;
+ TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
+end;
+
+procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec);
+begin
+ FPenColorFP := Value;
+ TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
+end;
+
+procedure TImagingCanvas.SetPenWidth(const Value: LongInt);
+begin
+ FPenWidth := ClampInt(Value, 0, MaxPenWidth);
+end;
+
+procedure TImagingCanvas.SetFillColor32(const Value: TColor32);
+begin
+ FFillColor32 := Value;
+ TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
+end;
+
+procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec);
+begin
+ FFillColorFP := Value;
+ TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
+end;
+
+procedure TImagingCanvas.SetClipRect(const Value: TRect);
+begin
+ FClipRect := Value;
+ SwapMin(FClipRect.Left, FClipRect.Right);
+ SwapMin(FClipRect.Top, FClipRect.Bottom);
+ IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
+end;
+
+procedure TImagingCanvas.CheckBeforeBlending(SrcFactor,
+ DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
+begin
+ if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then
+ raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.');
+ if DestFactor in [bfDstColor, bfOneMinusDstColor] then
+ raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.');
+ if DestCanvas.FormatInfo.IsIndexed then
+ raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.');
+end;
+
+function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer;
+begin
+ Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel]
+end;
+
+procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec);
+begin
+ TranslateFPToNative(Color, @FNativeColor);
+end;
+
+procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec;
+ Native: Pointer);
+begin
+ ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F,
+ FPData.Format, nil, FPData.Palette);
+end;
+
+procedure TImagingCanvas.UpdateCanvasState;
+begin
+ FDataSizeOnUpdate := FPData.Size;
+ ResetClipRect;
+ Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo)
+end;
+
+procedure TImagingCanvas.ResetClipRect;
+begin
+ FClipRect := Rect(0, 0, FPData.Width, FPData.Height)
+end;
+
+procedure TImagingCanvas.Clear;
+begin
+ TranslateFPToNative(FFillColorFP);
+ Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor);
+end;
+
+function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt;
+ AStart, AStop, BStart, BStop: LongInt): Boolean;
+begin
+ if (B >= BStart) and (B < BStop) then
+ begin
+ SwapMin(A1, A2);
+ if A1 < AStart then A1 := AStart;
+ if A2 >= AStop then A2 := AStop - 1;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer;
+ Bpp: LongInt);
+var
+ I, WidthBytes: LongInt;
+ PixelPtr: PByte;
+begin
+ if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
+ begin
+ SwapMin(X1, X2);
+ X1 := Max(X1, FClipRect.Left);
+ X2 := Min(X2, FClipRect.Right);
+ PixelPtr := GetPixelPointer(X1, Y);
+ WidthBytes := (X2 - X1) * Bpp;
+ case Bpp of
+ 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^);
+ 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^);
+ 4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^);
+ else
+ for I := X1 to X2 do
+ begin
+ ImagingFormats.CopyPixel(Color, PixelPtr, Bpp);
+ Inc(PixelPtr, Bpp);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer;
+ Bpp: LongInt);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp);
+ end;
+end;
+
+procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt);
+var
+ DstRect: TRect;
+begin
+ if FPenMode = pmClear then Exit;
+ SwapMin(X1, X2);
+ if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2,
+ Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt);
+var
+ DstRect: TRect;
+begin
+ if FPenMode = pmClear then Exit;
+ SwapMin(Y1, Y2);
+ if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1,
+ X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt);
+var
+ Steep: Boolean;
+ Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt;
+begin
+ if FPenMode = pmClear then Exit;
+
+ // If line is vertical or horizontal just call appropriate method
+ if X2 - X1 = 0 then
+ begin
+ HorzLine(X1, X2, Y1);
+ Exit;
+ end;
+ if Y2 - Y1 = 0 then
+ begin
+ VertLine(X1, Y1, Y2);
+ Exit;
+ end;
+
+ // Determine if line is steep (angle with X-axis > 45 degrees)
+ Steep := Abs(Y2 - Y1) > Abs(X2 - X1);
+
+ // If we need to draw thick line we just draw more 1 pixel lines around
+ // the one we already drawn. Setting FLineRecursion assures that we
+ // won't be doing recursions till the end of the world.
+ if (FPenWidth > 1) and not FLineRecursion then
+ begin
+ FLineRecursion := True;
+ W1 := FPenWidth div 2;
+ W2 := W1;
+ if FPenWidth mod 2 = 0 then
+ Dec(W1);
+ if Steep then
+ begin
+ // Add lines left/right
+ for I := 1 to W1 do
+ Line(X1, Y1 - I, X2, Y2 - I);
+ for I := 1 to W2 do
+ Line(X1, Y1 + I, X2, Y2 + I);
+ end
+ else
+ begin
+ // Add lines above/under
+ for I := 1 to W1 do
+ Line(X1 - I, Y1, X2 - I, Y2);
+ for I := 1 to W2 do
+ Line(X1 + I, Y1, X2 + I, Y2);
+ end;
+ FLineRecursion := False;
+ end;
+
+ with FClipRect do
+ begin
+ // Use part of Cohen-Sutherland line clipping to determine if any part of line
+ // is in ClipRect
+ Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3;
+ Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3;
+ end;
+
+ if (Code1 and Code2) = 0 then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ // If line is steep swap X and Y coordinates so later we just have one loop
+ // of two (where only one is used according to steepness).
+ if Steep then
+ begin
+ SwapValues(X1, Y1);
+ SwapValues(X2, Y2);
+ end;
+ if X1 > X2 then
+ begin
+ SwapValues(X1, X2);
+ SwapValues(Y1, Y2);
+ end;
+
+ DeltaX := X2 - X1;
+ DeltaY := Abs(Y2 - Y1);
+ YStep := Iff(Y2 > Y1, 1, -1);
+ Error := 0;
+ Y := Y1;
+
+ // Draw line using Bresenham algorithm. No real line clipping here,
+ // just don't draw pixels outsize clip rect.
+ for X := X1 to X2 do
+ begin
+ if Steep then
+ CopyPixelInternal(Y, X, @FNativeColor, Bpp)
+ else
+ CopyPixelInternal(X, Y, @FNativeColor, Bpp);
+ Error := Error + DeltaY;
+ if Error * 2 >= DeltaX then
+ begin
+ Inc(Y, YStep);
+ Dec(Error, DeltaX);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FrameRect(const Rect: TRect);
+var
+ HalfPen, PenMod: LongInt;
+begin
+ if FPenMode = pmClear then Exit;
+ HalfPen := FPenWidth div 2;
+ PenMod := FPenWidth mod 2;
+ HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top);
+ HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1);
+ VertLine(Rect.Left, Rect.Top, Rect.Bottom);
+ VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom);
+end;
+
+procedure TImagingCanvas.FillRect(const Rect: TRect);
+var
+ DstRect: TRect;
+begin
+ if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
+ begin
+ TranslateFPToNative(FFillColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor,
+ DestFactor: TBlendingFactor);
+var
+ DstRect: TRect;
+ X, Y: Integer;
+ Line: PByte;
+begin
+ if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
+ begin
+ CheckBeforeBlending(SrcFactor, DestFactor, Self);
+ for Y := DstRect.Top to DstRect.Bottom - 1 do
+ begin
+ Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel];
+ for X := DstRect.Left to DstRect.Right - 1 do
+ begin
+ PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor);
+ Inc(Line, FFormatInfo.BytesPerPixel);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.Rectangle(const Rect: TRect);
+begin
+ FillRect(Rect);
+ FrameRect(Rect);
+end;
+
+procedure TImagingCanvas.Ellipse(const Rect: TRect);
+var
+ RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt;
+ X1, X2, Y1, Y2, Bpp, OldY: LongInt;
+ Fill, Pen: TColorFPRec;
+begin
+ // TODO: Use PenWidth
+ X1 := Rect.Left;
+ X2 := Rect.Right;
+ Y1 := Rect.Top;
+ Y2 := Rect.Bottom;
+
+ TranslateFPToNative(FPenColorFP, @Pen);
+ TranslateFPToNative(FFillColorFP, @Fill);
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ SwapMin(X1, X2);
+ SwapMin(Y1, Y2);
+
+ RadX := (X2 - X1) div 2;
+ RadY := (Y2 - Y1) div 2;
+
+ Y1 := Y1 + RadY;
+ Y2 := Y1;
+ OldY := Y1;
+
+ DeltaX := (RadX * RadX);
+ DeltaY := (RadY * RadY);
+ R := RadX * RadY * RadY;
+ RX := R;
+ RY := 0;
+
+ if (FFillMode <> fmClear) then
+ HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
+ CopyPixelInternal(X1, Y1, @Pen, Bpp);
+ CopyPixelInternal(X2, Y1, @Pen, Bpp);
+
+ while RadX > 0 do
+ begin
+ if R > 0 then
+ begin
+ Inc(Y1);
+ Dec(Y2);
+ Inc(RY, DeltaX);
+ Dec(R, RY);
+ end;
+ if R <= 0 then
+ begin
+ Dec(RadX);
+ Inc(X1);
+ Dec(X2);
+ Dec(RX, DeltaY);
+ Inc(R, RX);
+ end;
+
+ if (OldY <> Y1) and (FFillMode <> fmClear) then
+ begin
+ HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
+ HorzLineInternal(X1, X2, Y2, @Fill, Bpp);
+ end;
+ OldY := Y1;
+
+ CopyPixelInternal(X1, Y1, @Pen, Bpp);
+ CopyPixelInternal(X2, Y1, @Pen, Bpp);
+ CopyPixelInternal(X1, Y2, @Pen, Bpp);
+ CopyPixelInternal(X2, Y2, @Pen, Bpp);
+ end;
+end;
+
+procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean);
+var
+ Stack: array of TPoint;
+ StackPos, Y1: Integer;
+ OldColor: TColor32;
+ SpanLeft, SpanRight: Boolean;
+
+ procedure Push(AX, AY: Integer);
+ begin
+ if StackPos < High(Stack) then
+ begin
+ Inc(StackPos);
+ Stack[StackPos].X := AX;
+ Stack[StackPos].Y := AY;
+ end
+ else
+ begin
+ SetLength(Stack, Length(Stack) + FPData.Width);
+ Push(AX, AY);
+ end;
+ end;
+
+ function Pop(out AX, AY: Integer): Boolean;
+ begin
+ if StackPos > 0 then
+ begin
+ AX := Stack[StackPos].X;
+ AY := Stack[StackPos].Y;
+ Dec(StackPos);
+ Result := True;
+ end
+ else
+ Result := False;
+ end;
+
+ function Compare(AX, AY: Integer): Boolean;
+ var
+ Color: TColor32;
+ begin
+ Color := GetPixel32(AX, AY);
+ if BoundaryFillMode then
+ Result := (Color <> FFillColor32) and (Color <> FPenColor32)
+ else
+ Result := Color = OldColor;
+ end;
+
+begin
+ // Scanline Floodfill Algorithm With Stack
+ // http://student.kuleuven.be/~m0216922/CG/floodfill.html
+
+ if not PtInRect(FClipRect, Point(X, Y)) then Exit;
+
+ SetLength(Stack, FPData.Width * 4);
+ StackPos := 0;
+
+ OldColor := GetPixel32(X, Y);
+
+ Push(X, Y);
+
+ while Pop(X, Y) do
+ begin
+ Y1 := Y;
+ while (Y1 >= FClipRect.Top) and Compare(X, Y1) do
+ Dec(Y1);
+
+ Inc(Y1);
+ SpanLeft := False;
+ SpanRight := False;
+
+ while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do
+ begin
+ SetPixel32(X, Y1, FFillColor32);
+ if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then
+ begin
+ Push(X - 1, Y1);
+ SpanLeft := True;
+ end
+ else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then
+ SpanLeft := False
+ else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then
+ begin
+ Push(X + 1, Y1);
+ SpanRight := True;
+ end
+ else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then
+ SpanRight := False;
+
+ Inc(Y1);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
+ DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
+var
+ X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer;
+ PSrc: TColorFPRec;
+ SrcPointer, DestPointer: PByte;
+begin
+ CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas);
+ SrcX := SrcRect.Left;
+ SrcY := SrcRect.Top;
+ Width := SrcRect.Right - SrcRect.Left;
+ Height := SrcRect.Bottom - SrcRect.Top;
+ SrcBpp := FFormatInfo.BytesPerPixel;
+ DestBpp := DestCanvas.FFormatInfo.BytesPerPixel;
+ // Clip src and dst rects
+ ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+
+ for Y := 0 to Height - 1 do
+ begin
+ // Get src and dst scanlines
+ SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp];
+ DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp];
+
+ for X := 0 to Width - 1 do
+ begin
+ PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette);
+ // Call pixel writer procedure - combine source and dest pixels
+ PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor);
+ // Increment pixel pointers
+ Inc(SrcPointer, SrcBpp);
+ Inc(DestPointer, DestBpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
+begin
+ DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc);
+end;
+
+procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ DestX, DestY: Integer);
+begin
+ DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc);
+end;
+
+procedure TImagingCanvas.DrawAdd(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+begin
+ DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc);
+end;
+
+procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect;
+ SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter;
+ PixelWriteProc: TPixelWriteProc);
+const
+ FilterMapping: array[TResizeFilter] of TSamplingFilter =
+ (sfNearest, sfLinear, DefaultCubicFilter);
+var
+ X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer;
+ DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer;
+ SrcPix, PDest: TColorFPRec;
+ MapX, MapY: TMappingTable;
+ XMinimum, XMaximum: Integer;
+ LineBuffer: array of TColorFPRec;
+ ClusterX, ClusterY: TCluster;
+ Weight, AccumA, AccumR, AccumG, AccumB: Single;
+ DestLine: PByte;
+ FilterFunction: TFilterFunction;
+ Radius: Single;
+begin
+ CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas);
+ SrcX := SrcRect.Left;
+ SrcY := SrcRect.Top;
+ SrcWidth := SrcRect.Right - SrcRect.Left;
+ SrcHeight := SrcRect.Bottom - SrcRect.Top;
+ DestX := DestRect.Left;
+ DestY := DestRect.Top;
+ DestWidth := DestRect.Right - DestRect.Left;
+ DestHeight := DestRect.Bottom - DestRect.Top;
+ SrcBpp := FFormatInfo.BytesPerPixel;
+ DestBpp := DestCanvas.FFormatInfo.BytesPerPixel;
+ // Get actual resampling filter and radius
+ FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]];
+ Radius := SamplingFilterRadii[FilterMapping[Filter]];
+ // Clip src and dst rects
+ ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+ // Generate mapping tables
+ MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
+ FPData.Width, FilterFunction, Radius, False);
+ MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
+ FPData.Height, FilterFunction, Radius, False);
+ FindExtremes(MapX, XMinimum, XMaximum);
+ SetLength(LineBuffer, XMaximum - XMinimum + 1);
+
+ for J := 0 to DestHeight - 1 do
+ begin
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ AccumA := 0.0;
+ AccumR := 0.0;
+ AccumG := 0.0;
+ AccumB := 0.0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ Weight := ClusterY[Y].Weight;
+ SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp],
+ @FFormatInfo, FPData.Palette);
+ AccumB := AccumB + SrcPix.B * Weight;
+ AccumG := AccumG + SrcPix.G * Weight;
+ AccumR := AccumR + SrcPix.R * Weight;
+ AccumA := AccumA + SrcPix.A * Weight;
+ end;
+ with LineBuffer[X - XMinimum] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+
+ DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp];
+
+ for I := 0 to DestWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ AccumA := 0.0;
+ AccumR := 0.0;
+ AccumG := 0.0;
+ AccumB := 0.0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := ClusterX[X].Weight;
+ with LineBuffer[ClusterX[X].Pos - XMinimum] do
+ begin
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
+ end;
+ end;
+
+ SrcPix.A := AccumA;
+ SrcPix.R := AccumR;
+ SrcPix.G := AccumG;
+ SrcPix.B := AccumB;
+
+ // Write resulting blended pixel
+ PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor);
+ Inc(DestLine, DestBpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect;
+ SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter);
+begin
+ StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc);
+end;
+
+procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
+begin
+ StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc);
+end;
+
+procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
+begin
+ StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc);
+end;
+
+procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize,
+ Divisor: LongInt; Bias: Single; ClampChannels: Boolean);
+var
+ X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt;
+ R, G, B, DivFloat: Single;
+ Pixel: TColorFPRec;
+ TempImage: TImageData;
+ DstPointer, SrcPointer: PByte;
+begin
+ SizeDiv2 := KernelSize div 2;
+ DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0);
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+
+ InitImage(TempImage);
+ CloneImage(FPData^, TempImage);
+
+ try
+ // For every pixel in clip rect
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
+
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ // Reset accumulators
+ R := 0.0;
+ G := 0.0;
+ B := 0.0;
+
+ for J := 0 to KernelSize - 1 do
+ begin
+ PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
+
+ for I := 0 to KernelSize - 1 do
+ begin
+ PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
+ SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
+
+ // Get pixels from neighbourhood of current pixel and add their
+ // colors to accumulators weighted by filter kernel values
+ Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
+ KernelValue := PLongIntArray(Kernel)[J * KernelSize + I];
+
+ R := R + Pixel.R * KernelValue;
+ G := G + Pixel.G * KernelValue;
+ B := B + Pixel.B * KernelValue;
+ end;
+ end;
+
+ Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette);
+
+ Pixel.R := R * DivFloat + Bias;
+ Pixel.G := G * DivFloat + Bias;
+ Pixel.B := B * DivFloat + Bias;
+
+ if ClampChannels then
+ ClampFloatPixel(Pixel);
+
+ // Set resulting pixel color
+ FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
+
+ Inc(DstPointer, Bpp);
+ end;
+ end;
+
+ finally
+ FreeImage(TempImage);
+ end;
+end;
+
+procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
+begin
+ ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True);
+end;
+
+procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
+begin
+ ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True);
+end;
+
+procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
+var
+ X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt;
+ Pixel: TColorFPRec;
+ TempImage: TImageData;
+ DstPointer, SrcPointer: PByte;
+ NeighPixels: TDynFPPixelArray;
+begin
+ SizeDiv2 := FilterSize div 2;
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+ SetLength(NeighPixels, FilterSize * FilterSize);
+
+ InitImage(TempImage);
+ CloneImage(FPData^, TempImage);
+
+ try
+ // For every pixel in clip rect
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
+
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ for J := 0 to FilterSize - 1 do
+ begin
+ PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
+
+ for I := 0 to FilterSize - 1 do
+ begin
+ PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
+ SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
+
+ // Get pixels from neighbourhood of current pixel and store them
+ Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
+ NeighPixels[J * FilterSize + I] := Pixel;
+ end;
+ end;
+
+ // Choose pixel using custom function
+ Pixel := SelectFunc(NeighPixels);
+ // Set resulting pixel color
+ FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
+
+ Inc(DstPointer, Bpp);
+ end;
+ end;
+
+ finally
+ FreeImage(TempImage);
+ end;
+end;
+
+procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MedianSelect);
+end;
+
+procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MinSelect);
+end;
+
+procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MaxSelect);
+end;
+
+procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction;
+ Param1, Param2, Param3: Single);
+var
+ X, Y, Bpp, WidthBytes: Integer;
+ PixPointer: PByte;
+ Pixel: TColorFPRec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+
+ // For every pixel in clip rect
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
+
+ FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette,
+ Transform(Pixel, Param1, Param2, Param3));
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
+begin
+ PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
+ Brightness / 100, 0);
+end;
+
+procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
+begin
+ PointTransform(TransformGamma, Red, Green, Blue);
+end;
+
+procedure TImagingCanvas.InvertColors;
+begin
+ PointTransform(TransformInvert, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.Threshold(Red, Green, Blue: Single);
+begin
+ PointTransform(TransformThreshold, Red, Green, Blue);
+end;
+
+procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single);
+begin
+ PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint);
+end;
+
+procedure TImagingCanvas.PremultiplyAlpha;
+begin
+ PointTransform(TransformPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.UnPremultiplyAlpha;
+begin
+ PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha,
+ Gray: THistogramArray);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ Color32: TColor32Rec;
+begin
+ FillChar(Red, SizeOf(Red), 0);
+ FillChar(Green, SizeOf(Green), 0);
+ FillChar(Blue, SizeOf(Blue), 0);
+ FillChar(Alpha, SizeOf(Alpha), 0);
+ FillChar(Gray, SizeOf(Gray), 0);
+
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+
+ Inc(Red[Color32.R]);
+ Inc(Green[Color32.G]);
+ Inc(Blue[Color32.B]);
+ Inc(Alpha[Color32.A]);
+ Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ Color32: TColor32Rec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+ Color32.Channels[ChannelId] := NewChannelValue;
+ FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ ColorFP: TColorFPRec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
+ ColorFP.Channels[ChannelId] := NewChannelValue;
+ FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+class function TImagingCanvas.GetSupportedFormats: TImageFormats;
+begin
+ Result := [ifIndex8..Pred(ifDXT1)];
+end;
+
+{ TFastARGB32Canvas }
+
+destructor TFastARGB32Canvas.Destroy;
+begin
+ FreeMem(FScanlines);
+ inherited Destroy;
+end;
+
+procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec);
+var
+ SrcAlpha, DestAlpha, FinalAlpha: Integer;
+begin
+ FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8;
+ if FinalAlpha = 0 then
+ SrcAlpha := 0
+ else
+ SrcAlpha := (SrcPix.A shl 8) div FinalAlpha;
+ DestAlpha := 256 - SrcAlpha;
+
+ DestPix.A := ClampToByte(FinalAlpha);
+ DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8;
+ DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8;
+ DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8;
+end;
+
+procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+var
+ X, Y, SrcX, SrcY, Width, Height: Integer;
+ SrcPix, DestPix: PColor32Rec;
+begin
+ if DestCanvas.ClassType <> Self.ClassType then
+ begin
+ inherited;
+ Exit;
+ end;
+
+ SrcX := SrcRect.Left;
+ SrcY := SrcRect.Top;
+ Width := SrcRect.Right - SrcRect.Left;
+ Height := SrcRect.Bottom - SrcRect.Top;
+ ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+
+ for Y := 0 to Height - 1 do
+ begin
+ SrcPix := @FScanlines[SrcY + Y, SrcX];
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX];
+ for X := 0 to Width - 1 do
+ begin
+ AlphaBlendPixels(SrcPix, DestPix);
+ Inc(SrcPix);
+ Inc(DestPix);
+ end;
+ end;
+end;
+
+function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
+begin
+ Result := FScanlines[Y, X].Color;
+end;
+
+procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ FScanlines[Y, X].Color := Value;
+ end;
+end;
+
+procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
+var
+ X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
+ FracX, FracY, InvFracY, T1, T2: Integer;
+ SrcX, SrcY, SrcWidth, SrcHeight: Integer;
+ DestX, DestY, DestWidth, DestHeight: Integer;
+ SrcLine, SrcLine2: PColor32RecArray;
+ DestPix: PColor32Rec;
+ Accum: TColor32Rec;
+begin
+ if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then
+ begin
+ inherited;
+ Exit;
+ end;
+
+ SrcX := SrcRect.Left;
+ SrcY := SrcRect.Top;
+ SrcWidth := SrcRect.Right - SrcRect.Left;
+ SrcHeight := SrcRect.Bottom - SrcRect.Top;
+ DestX := DestRect.Left;
+ DestY := DestRect.Top;
+ DestWidth := DestRect.Right - DestRect.Left;
+ DestHeight := DestRect.Bottom - DestRect.Top;
+ // Clip src and dst rects
+ ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+ ScaleX := (SrcWidth shl 16) div DestWidth;
+ ScaleY := (SrcHeight shl 16) div DestHeight;
+
+ // Nearest and linear filtering using fixed point math
+
+ if Filter = rfNearest then
+ begin
+ Yp := 0;
+ for Y := DestY to DestY + DestHeight - 1 do
+ begin
+ Xp := 0;
+ SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX];
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+ for X := 0 to DestWidth - 1 do
+ begin
+ AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix);
+ Inc(DestPix);
+ Inc(Xp, ScaleX);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+ end
+ else
+ begin
+ Yp := (ScaleY shr 1) - $8000;
+ for Y := DestY to DestY + DestHeight - 1 do
+ begin
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+ if Yp < 0 then
+ begin
+ T1 := 0;
+ FracY := 0;
+ InvFracY := $10000;
+ end
+ else
+ begin
+ T1 := Yp shr 16;
+ FracY := Yp and $FFFF;
+ InvFracY := (not Yp and $FFFF) + 1;
+ end;
+
+ T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1);
+ SrcLine := @Scanlines[T1 + SrcY, SrcX];
+ SrcLine2 := @Scanlines[T2 + SrcY, SrcX];
+ Xp := (ScaleX shr 1) - $8000;
+
+ for X := 0 to DestWidth - 1 do
+ begin
+ if Xp < 0 then
+ begin
+ T1 := 0;
+ FracX := 0;
+ end
+ else
+ begin
+ T1 := Xp shr 16;
+ FracX := Xp and $FFFF;
+ end;
+
+ T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
+ Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
+ Weight1:= InvFracY - Weight2;
+ Weight4:= (Cardinal(FracY) * FracX) shr 16;
+ Weight3:= FracY - Weight4;
+
+ Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
+ SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16;
+ Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 +
+ SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16;
+ Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 +
+ SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16;
+ Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 +
+ SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16;
+
+ AlphaBlendPixels(@Accum, DestPix);
+
+ Inc(Xp, ScaleX);
+ Inc(DestPix);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+ end;
+ {
+
+ // Generate mapping tables
+ MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
+ FPData.Width, FilterFunction, Radius, False);
+ MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
+ FPData.Height, FilterFunction, Radius, False);
+ FindExtremes(MapX, XMinimum, XMaximum);
+ SetLength(LineBuffer, XMaximum - XMinimum + 1);
+
+ for J := 0 to DestHeight - 1 do
+ begin
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ Weight := Round(ClusterY[Y].Weight * 256);
+ SrcColor := FScanlines[ClusterY[Y].Pos, X];
+
+ AccumB := AccumB + SrcColor.B * Weight;
+ AccumG := AccumG + SrcColor.G * Weight;
+ AccumR := AccumR + SrcColor.R * Weight;
+ AccumA := AccumA + SrcColor.A * Weight;
+ end;
+ with LineBuffer[X - XMinimum] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+
+ DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
+
+ for I := 0 to DestWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := Round(ClusterX[X].Weight * 256);
+ with LineBuffer[ClusterX[X].Pos - XMinimum] do
+ begin
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
+ end;
+ end;
+
+ AccumA := ClampInt(AccumA, 0, $00FF0000);
+ AccumR := ClampInt(AccumR, 0, $00FF0000);
+ AccumG := ClampInt(AccumG, 0, $00FF0000);
+ AccumB := ClampInt(AccumB, 0, $00FF0000);
+ SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
+ (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
+
+ AlphaBlendPixels(@SrcColor, DestPtr);
+
+ Inc(DestPtr);
+ end;
+ end; }
+end;
+
+procedure TFastARGB32Canvas.UpdateCanvasState;
+var
+ I: LongInt;
+ ScanPos: PLongWord;
+begin
+ inherited UpdateCanvasState;
+
+ // Realloc and update scanline array
+ ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray));
+ ScanPos := FPData.Bits;
+
+ for I := 0 to FPData.Height - 1 do
+ begin
+ FScanlines[I] := PColor32RecArray(ScanPos);
+ Inc(ScanPos, FPData.Width);
+ end;
+end;
+
+class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats;
+begin
+ Result := [ifA8R8G8B8];
+end;
+
+procedure TFastARGB32Canvas.InvertColors;
+var
+ X, Y: Integer;
+ PixPtr: PColor32Rec;
+begin
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPtr := @FScanlines[Y, FClipRect.Left];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ PixPtr.R := not PixPtr.R;
+ PixPtr.G := not PixPtr.G;
+ PixPtr.B := not PixPtr.B;
+ Inc(PixPtr);
+ end;
+ end;
+end;
+
+initialization
+ RegisterCanvas(TFastARGB32Canvas);
+
+finalization
+ FreeAndNil(CanvasClasses);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - more more more ...
+ - implement pen width everywhere
+ - add blending (*image and object drawing)
+ - more objects (arc, polygon)
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
+ - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
+ - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Added FillChannel methods.
+ - Added FloodFill method.
+ - Added GetHistogram method.
+ - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
+ (thanks to Carlos González).
+ - Added TImagingCanvas.AdjustColorLevels method.
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed error that could cause AV in linear and nonlinear filters.
+ - Added blended rect filling function FillRectBlend.
+ - Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
+ StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
+ - Added non-linear filters (min, max, median).
+ - Added point transforms (invert, contrast, gamma, brightness).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Added some new filter kernels for convolution.
+ - Added FillMode and PenMode properties.
+ - Added FrameRect, Rectangle, Ellipse, and Line methods.
+ - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions
+ in general canvas is now as fast as those in TFastARGB32Canvas
+ (only in case of A8R8G8B8 images of course).
+ - Added PenWidth property, updated HorzLine and VertLine to use it.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added TFastARGB32Canvas
+ - added convolutions, hline, vline
+ - unit created, intial stuff added
+
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingClasses.pas b/src/lib/vampimg/ImagingClasses.pas
--- /dev/null
@@ -0,0 +1,996 @@
+{
+ $Id: ImagingClasses.pas 173 2009-09-04 17:05: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 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; {$IF Defined(DCC) and (CompilerVersion >= 20.0)}override;{$IFEND}
+
+ { 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 Angle degrees counterclockwise.}
+ procedure Rotate(Angle: Single);
+ { 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);
+ { Rearranges images so that the first image will become last and vice versa.}
+ procedure ReverseImages;
+
+ { 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: Single);
+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.ReverseImages;
+var
+ I: Integer;
+begin
+ for I := 0 to GetImageCount div 2 do
+ ExchangeImages(I, GetImageCount - 1 - I);
+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.24.3 Changes/Bug Fixes ---------------------------------
+ - Added TMultiImage.ReverseImages method.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingColors.pas b/src/lib/vampimg/ImagingColors.pas
--- /dev/null
@@ -0,0 +1,245 @@
+{
+ $Id: ImagingColors.pas 173 2009-09-04 17:05: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 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);
+
+{ Converts RGB color to YCoCg.}
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+{ Converts YCoCg to RGB color.}
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+
+
+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 = 255 then
+ begin
+ C := 0;
+ M := 0;
+ Y := 0;
+ end
+ else
+ begin
+ C := ClampToByte(Round((C - K) / (255 - K) * 255));
+ M := ClampToByte(Round((M - K) / (255 - K) * 255));
+ Y := ClampToByte(Round((Y - K) / (255 - K) * 255));
+ 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 = 65535 then
+ begin
+ C := 0;
+ M := 0;
+ Y := 0;
+ end
+ else
+ begin
+ C := ClampToWord(Round((C - K) / (65535 - K) * 65535));
+ M := ClampToWord(Round((M - K) / (65535 - K) * 65535));
+ Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535));
+ 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;
+
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+begin
+ // C and Delphi's SHR behaviour differs for negative numbers, use div instead.
+ Y := ClampToByte(( R + G shl 1 + B + 2) div 4);
+ Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128);
+ Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128);
+end;
+
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+var
+ CoInt, CgInt: Integer;
+begin
+ CoInt := Co - 128;
+ CgInt := Cg - 128;
+ R := ClampToByte(Y + CoInt - CgInt);
+ G := ClampToByte(Y + CgInt);
+ B := ClampToByte(Y - CoInt - CgInt);
+end;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added RGB<>YCoCg conversion functions.
+ - Fixed RGB>>CMYK conversions.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingComponents.pas b/src/lib/vampimg/ImagingComponents.pas
--- /dev/null
@@ -0,0 +1,1271 @@
+{
+ $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z 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 VCL/LCL TGraphic descendant which uses Imaging library
+ for saving and loading.}
+unit ImagingComponents;
+
+{$I ImagingOptions.inc}
+
+interface
+
+{$IFDEF LCL}
+ {$DEFINE COMPONENT_SET_LCL}
+{$ENDIF}
+
+{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
+// If no component sets should be used just include empty unit.
+//DOC-IGNORE-BEGIN
+implementation
+//DOC-IGNORE-END
+{$ELSE}
+
+uses
+ SysUtils, Types, Classes,
+{$IFDEF MSWINDOWS}
+ Windows,
+{$ENDIF}
+{$IFDEF COMPONENT_SET_VCL}
+ Graphics,
+{$ENDIF}
+{$IFDEF COMPONENT_SET_LCL}
+ InterfaceBase,
+ GraphType,
+ Graphics,
+ LCLType,
+ LCLIntf,
+{$ENDIF}
+ ImagingTypes, Imaging, ImagingClasses;
+
+type
+ { Graphic class which uses Imaging to load images.
+ It has standard TBitmap class as ancestor and it can
+ Assign also to/from TImageData structres and TBaseImage
+ classes. For saving is uses inherited TBitmap methods.
+ This class is automatically registered to TPicture for all
+ file extensions supported by Imaging (useful only for loading).
+ If you just want to load images in various formats you can use this
+ class or simply use TPicture.LoadFromXXX which will create this class
+ automatically. For TGraphic class that saves with Imaging look
+ at TImagingGraphicForSave class.}
+ TImagingGraphic = class(TBitmap)
+ protected
+ procedure ReadDataFromStream(Stream: TStream); virtual;
+ procedure AssignTo(Dest: TPersistent); override;
+ public
+ constructor Create; override;
+
+ { Loads new image from the stream. It can load all image
+ file formats supported by Imaging (and enabled of course)
+ even though it is called by descendant class capable of
+ saving only one file format.}
+ procedure LoadFromStream(Stream: TStream); override;
+ { Copies the image contained in Source to this graphic object.
+ Supports also TBaseImage descendants from ImagingClasses unit. }
+ procedure Assign(Source: TPersistent); override;
+ { Copies the image contained in TBaseImage to this graphic object.}
+ procedure AssignFromImage(Image: TBaseImage);
+ { Copies the current image to TBaseImage object.}
+ procedure AssignToImage(Image: TBaseImage);
+ { Copies the image contained in TImageData structure to this graphic object.}
+ procedure AssignFromImageData(const ImageData: TImageData);
+ { Copies the current image to TImageData structure.}
+ procedure AssignToImageData(var ImageData: TImageData);
+ end;
+
+ TImagingGraphicClass = class of TImagingGraphic;
+
+ { Base class for file format specific TGraphic classes that use
+ Imaging for saving. Each descendant class can load all file formats
+ supported by Imaging but save only one format (TImagingBitmap
+ for *.bmp, TImagingJpeg for *.jpg). Format specific classes also
+ allow easy access to Imaging options that affect saving of files
+ (they are properties here).}
+ TImagingGraphicForSave = class(TImagingGraphic)
+ protected
+ FDefaultFileExt: string;
+ FSavingFormat: TImageFormat;
+ procedure WriteDataToStream(Stream: TStream); virtual;
+ public
+ constructor Create; override;
+ { Saves the current image to the stream. It is saved in the
+ file format according to the DefaultFileExt property.
+ So each descendant class can save some other file format.}
+ procedure SaveToStream(Stream: TStream); override;
+ { Returns TImageFileFormat descendant for this graphic class.}
+ class function GetFileFormat: TImageFileFormat; virtual; abstract;
+ {$IFDEF COMPONENT_SET_LCL}
+ { Returns file extensions of this graphic class.}
+ class function GetFileExtensions: string; override;
+ { Returns default MIME type of this graphic class.}
+ function GetMimeType: string; override;
+ {$ENDIF}
+ { Default (the most common) file extension of this graphic class.}
+ property DefaultFileExt: string read FDefaultFileExt;
+ end;
+
+ TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
+
+{$IFNDEF DONT_LINK_BITMAP}
+ { TImagingGraphic descendant for loading/saving Windows bitmaps.
+ VCL/CLX/LCL all have native support for bitmaps so you might
+ want to disable this class (although you can save bitmaps with
+ RLE compression with this class).}
+ TImagingBitmap = class(TImagingGraphicForSave)
+ protected
+ FUseRLE: Boolean;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ { See ImagingBitmapRLE option for details.}
+ property UseRLE: Boolean read FUseRLE write FUseRLE;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JPEG}
+ { TImagingGraphic descendant for loading/saving JPEG images.}
+ TImagingJpeg = class(TImagingGraphicForSave)
+ protected
+ FQuality: LongInt;
+ FProgressive: Boolean;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ {$IFDEF COMPONENT_SET_LCL}
+ function GetMimeType: string; override;
+ {$ENDIF}
+ { See ImagingJpegQuality option for details.}
+ property Quality: LongInt read FQuality write FQuality;
+ { See ImagingJpegProgressive option for details.}
+ property Progressive: Boolean read FProgressive write FProgressive;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_PNG}
+ { TImagingGraphic descendant for loading/saving PNG images.}
+ TImagingPNG = class(TImagingGraphicForSave)
+ protected
+ FPreFilter: LongInt;
+ FCompressLevel: LongInt;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ { See ImagingPNGPreFilter option for details.}
+ property PreFilter: LongInt read FPreFilter write FPreFilter;
+ { See ImagingPNGCompressLevel option for details.}
+ property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_GIF}
+ { TImagingGraphic descendant for loading/saving GIF images.}
+ TImagingGIF = class(TImagingGraphicForSave)
+ public
+ class function GetFileFormat: TImageFileFormat; override;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_TARGA}
+ { TImagingGraphic descendant for loading/saving Targa images.}
+ TImagingTarga = class(TImagingGraphicForSave)
+ protected
+ FUseRLE: Boolean;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ { See ImagingTargaRLE option for details.}
+ property UseRLE: Boolean read FUseRLE write FUseRLE;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_DDS}
+ { Compresssion type used when saving DDS files by TImagingDds.}
+ TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
+
+ { TImagingGraphic descendant for loading/saving DDS images.}
+ TImagingDDS = class(TImagingGraphicForSave)
+ protected
+ FCompression: TDDSCompresion;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ { You can choose compression type used when saving DDS file.
+ dcNone means that file will be saved in the current bitmaps pixel format.}
+ property Compression: TDDSCompresion read FCompression write FCompression;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_MNG}
+ { TImagingGraphic descendant for loading/saving MNG images.}
+ TImagingMNG = class(TImagingGraphicForSave)
+ protected
+ FLossyCompression: Boolean;
+ FLossyAlpha: Boolean;
+ FPreFilter: LongInt;
+ FCompressLevel: LongInt;
+ FQuality: LongInt;
+ FProgressive: Boolean;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ {$IFDEF COMPONENT_SET_LCL}
+ function GetMimeType: string; override;
+ {$ENDIF}
+ { See ImagingMNGLossyCompression option for details.}
+ property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
+ { See ImagingMNGLossyAlpha option for details.}
+ property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
+ { See ImagingMNGPreFilter option for details.}
+ property PreFilter: LongInt read FPreFilter write FPreFilter;
+ { See ImagingMNGCompressLevel option for details.}
+ property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
+ { See ImagingMNGQuality option for details.}
+ property Quality: LongInt read FQuality write FQuality;
+ { See ImagingMNGProgressive option for details.}
+ property Progressive: Boolean read FProgressive write FProgressive;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+ { TImagingGraphic descendant for loading/saving JNG images.}
+ TImagingJNG = class(TImagingGraphicForSave)
+ protected
+ FLossyAlpha: Boolean;
+ FAlphaPreFilter: LongInt;
+ FAlphaCompressLevel: LongInt;
+ FQuality: LongInt;
+ FProgressive: Boolean;
+ public
+ constructor Create; override;
+ procedure SaveToStream(Stream: TStream); override;
+ class function GetFileFormat: TImageFileFormat; override;
+ { See ImagingJNGLossyAlpha option for details.}
+ property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha;
+ { See ImagingJNGPreFilter option for details.}
+ property AlphaPreFilter: LongInt read FAlphaPreFilter write FAlphaPreFilter;
+ { See ImagingJNGCompressLevel option for details.}
+ property AlphaCompressLevel: LongInt read FAlphaCompressLevel write FAlphaCompressLevel;
+ { See ImagingJNGQuality option for details.}
+ property Quality: LongInt read FQuality write FQuality;
+ { See ImagingJNGProgressive option for details.}
+ property Progressive: Boolean read FProgressive write FProgressive;
+ end;
+{$ENDIF}
+
+{ Returns bitmap pixel format with the closest match with given data format.}
+function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
+{ Returns data format with closest match with given bitmap pixel format.}
+function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
+
+{ Converts TImageData structure to VCL/CLX/LCL bitmap.}
+procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
+{ Converts VCL/CLX/LCL bitmap to TImageData structure.}
+procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
+{ Converts TBaseImage instance to VCL/CLX/LCL bitmap.}
+procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
+{ Converts VCL/CLX/LCL bitmap to TBaseImage. Image must exist before
+ procedure is called. It overwrites its current image data.
+ When Image is TMultiImage only the current image level is overwritten.}
+procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
+
+{ Displays image stored in TImageData structure onto TCanvas. This procedure
+ draws image without converting from Imaging format to TBitmap.
+ Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
+ when you want displaying images that change frequently (because converting to
+ TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src
+ rectangles represent coordinates in the form (X1, Y1, X2, Y2).}
+procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
+{ Displays image onto TCanvas at position [DstX, DstY]. This procedure
+ draws image without converting from Imaging format to TBitmap.
+ Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
+ when you want displaying images that change frequently (because converting to
+ TBitmap by ConvertImageDataToBitmap is generally slow).}
+procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); overload;
+{ Displays image onto TCanvas to rectangle DstRect. This procedure
+ draws image without converting from Imaging format to TBitmap.
+ Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
+ when you want displaying images that change frequently (because converting to
+ TBitmap by ConvertImageDataToBitmap is generally slow).}
+procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); overload;
+{ Displays part of the image specified by SrcRect onto TCanvas to rectangle DstRect.
+ This procedure draws image without converting from Imaging format to TBitmap.
+ Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
+ when you want displaying images that change frequently (because converting to
+ TBitmap by ConvertImageDataToBitmap is generally slow).}
+procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); overload;
+
+{$IFDEF MSWINDOWS}
+{ Displays image stored in TImageData structure onto Windows device context.
+ Behaviour is the same as of DisplayImageData.}
+procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
+{$ENDIF}
+
+implementation
+
+uses
+{$IF Defined(LCL)}
+ {$IF Defined(LCLGTK2)}
+ GLib2, GDK2, GTK2, GTKDef, GTKProc,
+ {$ELSEIF Defined(LCLGTK)}
+ GDK, GTK, GTKDef, GTKProc,
+ {$IFEND}
+{$IFEND}
+{$IFNDEF DONT_LINK_BITMAP}
+ ImagingBitmap,
+{$ENDIF}
+{$IFNDEF DONT_LINK_JPEG}
+ ImagingJpeg,
+{$ENDIF}
+{$IFNDEF DONT_LINK_GIF}
+ ImagingGif,
+{$ENDIF}
+{$IFNDEF DONT_LINK_TARGA}
+ ImagingTarga,
+{$ENDIF}
+{$IFNDEF DONT_LINK_DDS}
+ ImagingDds,
+{$ENDIF}
+{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
+ ImagingNetworkGraphics,
+{$IFEND}
+ ImagingUtility;
+
+resourcestring
+ SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
+ SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
+ SBadFormatDisplay = 'Unsupported image format passed';
+ SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
+ SImagingGraphicName = 'Imaging Graphic AllInOne';
+
+{ Registers types to VCL/LCL.}
+procedure RegisterTypes;
+var
+ I: LongInt;
+
+ procedure RegisterFileFormatAllInOne(Format: TImageFileFormat);
+ var
+ I: LongInt;
+ begin
+ for I := 0 to Format.Extensions.Count - 1 do
+ TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName,
+ TImagingGraphic);
+ end;
+
+ procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass);
+ var
+ I: LongInt;
+ begin
+ for I := 0 to AClass.GetFileFormat.Extensions.Count - 1 do
+ TPicture.RegisterFileFormat(AClass.GetFileFormat.Extensions[I],
+ AClass.GetFileFormat.Name, AClass);
+ end;
+
+begin
+ for I := Imaging.GetFileFormatCount - 1 downto 0 do
+ RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
+ Classes.RegisterClass(TImagingGraphic);
+
+{$IFNDEF DONT_LINK_TARGA}
+ RegisterFileFormat(TImagingTarga);
+ Classes.RegisterClass(TImagingTarga);
+{$ENDIF}
+{$IFNDEF DONT_LINK_DDS}
+ RegisterFileFormat(TImagingDDS);
+ Classes.RegisterClass(TImagingDDS);
+{$ENDIF}
+{$IFNDEF DONT_LINK_JNG}
+ RegisterFileFormat(TImagingJNG);
+ Classes.RegisterClass(TImagingJNG);
+{$ENDIF}
+{$IFNDEF DONT_LINK_MNG}
+ RegisterFileFormat(TImagingMNG);
+ Classes.RegisterClass(TImagingMNG);
+{$ENDIF}
+{$IFNDEF DONT_LINK_GIF}
+ RegisterFileFormat(TImagingGIF);
+ Classes.RegisterClass(TImagingGIF);
+{$ENDIF}
+{$IFNDEF DONT_LINK_PNG}
+ {$IFDEF COMPONENT_SET_LCL}
+ // Unregister Lazarus´ default PNG loader which crashes on some PNG files
+ TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
+ {$ENDIF}
+ RegisterFileFormat(TImagingPNG);
+ Classes.RegisterClass(TImagingPNG);
+{$ENDIF}
+{$IFNDEF DONT_LINK_JPEG}
+ RegisterFileFormat(TImagingJpeg);
+ Classes.RegisterClass(TImagingJpeg);
+{$ENDIF}
+{$IFNDEF DONT_LINK_BITMAP}
+ RegisterFileFormat(TImagingBitmap);
+ Classes.RegisterClass(TImagingBitmap);
+{$ENDIF}
+end;
+
+{ Unregisters types from VCL/LCL.}
+procedure UnRegisterTypes;
+begin
+{$IFNDEF DONT_LINK_BITMAP}
+ TPicture.UnregisterGraphicClass(TImagingBitmap);
+ Classes.UnRegisterClass(TImagingBitmap);
+{$ENDIF}
+{$IFNDEF DONT_LINK_JPEG}
+ TPicture.UnregisterGraphicClass(TImagingJpeg);
+ Classes.UnRegisterClass(TImagingJpeg);
+{$ENDIF}
+{$IFNDEF DONT_LINK_PNG}
+ TPicture.UnregisterGraphicClass(TImagingPNG);
+ Classes.UnRegisterClass(TImagingPNG);
+{$ENDIF}
+{$IFNDEF DONT_LINK_GIF}
+ TPicture.UnregisterGraphicClass(TImagingGIF);
+ Classes.UnRegisterClass(TImagingGIF);
+{$ENDIF}
+{$IFNDEF DONT_LINK_TARGA}
+ TPicture.UnregisterGraphicClass(TImagingTarga);
+ Classes.UnRegisterClass(TImagingTarga);
+{$ENDIF}
+{$IFNDEF DONT_LINK_DDS}
+ TPicture.UnregisterGraphicClass(TImagingDDS);
+ Classes.UnRegisterClass(TImagingDDS);
+{$ENDIF}
+ TPicture.UnregisterGraphicClass(TImagingGraphic);
+ Classes.UnRegisterClass(TImagingGraphic);
+end;
+
+function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
+begin
+ case Format of
+{$IFDEF COMPONENT_SET_VCL}
+ ifIndex8: Result := pf8bit;
+ ifR5G6B5: Result := pf16bit;
+ ifR8G8B8: Result := pf24bit;
+{$ENDIF}
+ ifA8R8G8B8,
+ ifX8R8G8B8: Result := pf32bit;
+ else
+ Result := pfCustom;
+ end;
+end;
+
+function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
+begin
+ case Format of
+ pf8bit: Result := ifIndex8;
+ pf15bit: Result := ifA1R5G5B5;
+ pf16bit: Result := ifR5G6B5;
+ pf24bit: Result := ifR8G8B8;
+ pf32bit: Result := ifA8R8G8B8;
+ else
+ Result := ifUnknown;
+ end;
+end;
+
+procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
+var
+ I, LineBytes: LongInt;
+ PF: TPixelFormat;
+ Info: TImageFormatInfo;
+ WorkData: TImageData;
+{$IFDEF COMPONENT_SET_VCL}
+ LogPalette: TMaxLogPalette;
+{$ENDIF}
+{$IFDEF COMPONENT_SET_LCL}
+ RawImage: TRawImage;
+ ImgHandle, ImgMaskHandle: HBitmap;
+{$ENDIF}
+begin
+ PF := DataFormatToPixelFormat(Data.Format);
+ GetImageFormatInfo(Data.Format, Info);
+ if PF = pfCustom then
+ begin
+ // Convert from formats not supported by Graphics unit
+ Imaging.InitImage(WorkData);
+ Imaging.CloneImage(Data, WorkData);
+ if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
+ Imaging.ConvertImage(WorkData, ifA8R8G8B8)
+ else
+{$IFDEF COMPONENT_SET_VCL}
+ if Info.IsIndexed or Info.HasGrayChannel then
+ Imaging.ConvertImage(WorkData, ifIndex8)
+ else if Info.UsePixelFormat then
+ Imaging.ConvertImage(WorkData, ifR5G6B5)
+ else
+ Imaging.ConvertImage(WorkData, ifR8G8B8);
+{$ELSE}
+ Imaging.ConvertImage(WorkData, ifA8R8G8B8);
+{$ENDIF}
+
+ PF := DataFormatToPixelFormat(WorkData.Format);
+ GetImageFormatInfo(WorkData.Format, Info);
+ end
+ else
+ WorkData := Data;
+
+ if PF = pfCustom then
+ RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]);
+
+ LineBytes := WorkData.Width * Info.BytesPerPixel;
+
+{$IFDEF COMPONENT_SET_VCL}
+ Bitmap.Width := WorkData.Width;
+ Bitmap.Height := WorkData.Height;
+ Bitmap.PixelFormat := PF;
+
+ if (PF = pf8bit) and (WorkData.Palette <> nil) then
+ begin
+ // Copy palette, this must be done before copying bits
+ FillChar(LogPalette, SizeOf(LogPalette), 0);
+ LogPalette.palVersion := $300;
+ LogPalette.palNumEntries := Info.PaletteEntries;
+ for I := 0 to Info.PaletteEntries - 1 do
+ with LogPalette do
+ begin
+ palPalEntry[I].peRed := WorkData.Palette[I].R;
+ palPalEntry[I].peGreen := WorkData.Palette[I].G;
+ palPalEntry[I].peBlue := WorkData.Palette[I].B;
+ end;
+ Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);
+ end;
+ // Copy scanlines
+ for I := 0 to WorkData.Height - 1 do
+ Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
+
+ // Delphi 2009 and newer support alpha transparency fro TBitmap
+{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
+ if Bitmap.PixelFormat = pf32bit then
+ Bitmap.AlphaFormat := afDefined;
+{$IFEND}
+
+{$ENDIF}
+{$IFDEF COMPONENT_SET_LCL}
+ // Create 32bit raw image from image data
+ FillChar(RawImage, SizeOf(RawImage), 0);
+ with RawImage.Description do
+ begin
+ Width := WorkData.Width;
+ Height := WorkData.Height;
+ BitsPerPixel := 32;
+ Format := ricfRGBA;
+ LineEnd := rileDWordBoundary;
+ BitOrder := riboBitsInOrder;
+ ByteOrder := riboLSBFirst;
+ LineOrder := riloTopToBottom;
+ AlphaPrec := 8;
+ RedPrec := 8;
+ GreenPrec := 8;
+ BluePrec := 8;
+ AlphaShift := 24;
+ RedShift := 16;
+ GreenShift := 8;
+ BlueShift := 0;
+ Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
+ end;
+ RawImage.Data := WorkData.Bits;
+ RawImage.DataSize := WorkData.Size;
+
+ // Create bitmap from raw image
+ if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
+ begin
+ Bitmap.Handle := ImgHandle;
+ Bitmap.MaskHandle := ImgMaskHandle;
+ end;
+{$ENDIF}
+ if WorkData.Bits <> Data.Bits then
+ Imaging.FreeImage(WorkData);
+end;
+
+procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData);
+var
+ I, LineBytes: LongInt;
+ Format: TImageFormat;
+ Info: TImageFormatInfo;
+{$IFDEF COMPONENT_SET_VCL}
+ Colors: Word;
+ LogPalette: TMaxLogPalette;
+{$ENDIF}
+{$IFDEF COMPONENT_SET_LCL}
+ RawImage: TRawImage;
+ LineLazBytes: LongInt;
+{$ENDIF}
+begin
+{$IFDEF COMPONENT_SET_LCL}
+ // In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless.
+ // We cannot change bitmap's format by changing it (it will just release
+ // old image but not convert it to new format) nor we can determine bitmaps's
+ // current format (it is usually set to pfDevice). So bitmap's format is obtained
+ // trough RawImage api and cannot be changed to mirror some Imaging format
+ // (so formats with no coresponding Imaging format cannot be saved now).
+
+ if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
+ case RawImage.Description.BitsPerPixel of
+ 8: Format := ifIndex8;
+ 16:
+ if RawImage.Description.Depth = 15 then
+ Format := ifA1R5G5B5
+ else
+ Format := ifR5G6B5;
+ 24: Format := ifR8G8B8;
+ 32: Format := ifA8R8G8B8;
+ 48: Format := ifR16G16B16;
+ 64: Format := ifA16R16G16B16;
+ else
+ Format := ifUnknown;
+ end;
+{$ELSE}
+ Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
+ if Format = ifUnknown then
+ begin
+ // Convert from formats not supported by Imaging (1/4 bit)
+ if Bitmap.PixelFormat < pf8bit then
+ Bitmap.PixelFormat := pf8bit
+ else
+ Bitmap.PixelFormat := pf32bit;
+ Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
+ end;
+{$ENDIF}
+
+ if Format = ifUnknown then
+ RaiseImaging(SBadFormatBitmapToData, []);
+
+ Imaging.NewImage(Bitmap.Width, Bitmap.Height, Format, Data);
+ GetImageFormatInfo(Data.Format, Info);
+ LineBytes := Data.Width * Info.BytesPerPixel;
+
+{$IFDEF COMPONENT_SET_VCL}
+ if (Format = ifIndex8) and (GetObject(Bitmap.Palette, SizeOf(Colors),
+ @Colors) <> 0) then
+ begin
+ // Copy palette
+ GetPaletteEntries(Bitmap.Palette, 0, Colors, LogPalette.palPalEntry);
+ if Colors > Info.PaletteEntries then
+ Colors := Info.PaletteEntries;
+ for I := 0 to Colors - 1 do
+ with LogPalette do
+ begin
+ Data.Palette[I].A := $FF;
+ Data.Palette[I].R := palPalEntry[I].peRed;
+ Data.Palette[I].G := palPalEntry[I].peGreen;
+ Data.Palette[I].B := palPalEntry[I].peBlue;
+ end;
+ end;
+ // Copy scanlines
+ for I := 0 to Data.Height - 1 do
+ Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
+{$ENDIF}
+{$IFDEF COMPONENT_SET_LCL}
+ // Get raw image from bitmap (mask handle must be 0 or expect violations)
+ if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then
+ begin
+ LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
+ RawImage.Description.LineEnd);
+ // Copy scanlines
+ for I := 0 to Data.Height - 1 do
+ Move(PByteArray(RawImage.Data)[I * LineLazBytes],
+ PByteArray(Data.Bits)[I * LineBytes], LineBytes);
+ { If you get complitation error here upgrade to Lazarus 0.9.24+ }
+ RawImage.FreeData;
+ end;
+{$ENDIF}
+end;
+
+procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
+begin
+ ConvertDataToBitmap(Image.ImageDataPointer^, Bitmap);
+end;
+
+procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
+begin
+ ConvertBitmapToData(Bitmap, Image.ImageDataPointer^);
+end;
+
+{$IFDEF MSWINDOWS}
+procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
+var
+ OldMode: Integer;
+ BitmapInfo: Windows.TBitmapInfo;
+ Bmp: TBitmap;
+begin
+ if TestImage(ImageData) then
+ begin
+ Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
+ OldMode := Windows.SetStretchBltMode(DC, COLORONCOLOR);
+
+ FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
+ with BitmapInfo.bmiHeader do
+ begin
+ biSize := SizeOf(TBitmapInfoHeader);
+ biPlanes := 1;
+ biBitCount := 32;
+ biCompression := BI_RGB;
+ biWidth := ImageData.Width;
+ biHeight := -ImageData.Height;
+ biSizeImage := ImageData.Size;
+ biXPelsPerMeter := 0;
+ biYPelsPerMeter := 0;
+ biClrUsed := 0;
+ biClrImportant := 0;
+ end;
+
+ try
+ with SrcRect, ImageData do
+ if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
+ DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
+ Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
+ begin
+ // StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
+ // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
+ Bmp := TBitmap.Create;
+ try
+ ConvertDataToBitmap(ImageData, Bmp);
+ StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
+ Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY);
+ finally
+ Bmp.Free;
+ end;
+ end;
+ finally
+ Windows.SetStretchBltMode(DC, OldMode);
+ end;
+ end;
+end;
+{$ENDIF}
+
+procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
+{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
+begin
+ DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
+end;
+{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
+
+ procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
+ SrcWidth, SrcHeight: Integer; ImageData: TImageData);
+ var
+ P: TPoint;
+ begin
+ P := TGtkDeviceContext(Dest).Offset;
+ Inc(DstX, P.X);
+ Inc(DstY, P.Y);
+ gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
+ DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
+ @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
+ end;
+
+var
+ DisplayImage: TImageData;
+ NewWidth, NewHeight: Integer;
+ SrcBounds, DstBounds, DstClip: TRect;
+begin
+ if TestImage(ImageData) then
+ begin
+ Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
+ InitImage(DisplayImage);
+
+ SrcBounds := RectToBounds(SrcRect);
+ DstBounds := RectToBounds(DstRect);
+ WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip);
+
+ ClipStretchBounds(SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, SrcBounds.Bottom,
+ DstBounds.Left, DstBounds.Top, DstBounds.Right, DstBounds.Bottom, ImageData.Width,
+ ImageData.Height, DstClip);
+
+ NewWidth := DstBounds.Right;
+ NewHeight := DstBounds.Bottom;
+
+ if (NewWidth > 0) and (NewHeight > 0) then
+ begin
+ if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then
+ try
+ CloneImage(ImageData, DisplayImage);
+ // Swap R-B channels for GTK display compatability!
+ SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
+ GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top,
+ SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage);
+ finally
+ FreeImage(DisplayImage);
+ end
+ else
+ try
+ // Create new image with desired dimensions
+ NewImage(NewWidth, NewHeight, ImageData.Format, DisplayImage);
+ // Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic);
+ StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right,
+ SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest);
+ // Swap R-B channels for GTK display compatability!
+ SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
+ GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0,
+ NewWidth, NewHeight, DisplayImage);
+ finally
+ FreeImage(DisplayImage);
+ end
+ end;
+ end;
+end;
+{$ELSE}
+begin
+ raise Exception.Create(SUnsupportedLCLWidgetSet);
+end;
+{$IFEND}
+
+procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
+begin
+ DisplayImageData(DstCanvas, BoundsToRect(DstX, DstY, Image.Width, Image.Height),
+ Image.ImageDataPointer^, Image.BoundsRect);
+end;
+
+procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage);
+begin
+ DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, Image.BoundsRect);
+end;
+
+procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect);
+begin
+ DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, SrcRect);
+end;
+
+
+{ TImagingGraphic class implementation }
+
+constructor TImagingGraphic.Create;
+begin
+ inherited Create;
+ PixelFormat := pf24Bit;
+end;
+
+procedure TImagingGraphic.LoadFromStream(Stream: TStream);
+begin
+ ReadDataFromStream(Stream);
+end;
+
+procedure TImagingGraphic.ReadDataFromStream(Stream: TStream);
+var
+ Image: TSingleImage;
+begin
+ Image := TSingleImage.Create;
+ try
+ Image.LoadFromStream(Stream);
+ Assign(Image);
+ finally
+ Image.Free;
+ end;
+end;
+
+procedure TImagingGraphic.AssignTo(Dest: TPersistent);
+var
+ Arr: TDynImageDataArray;
+begin
+ if Dest is TSingleImage then
+ begin
+ AssignToImage(TSingleImage(Dest))
+ end
+ else if Dest is TMultiImage then
+ begin
+ SetLength(Arr, 1);
+ AssignToImageData(Arr[0]);
+ TMultiImage(Dest).CreateFromArray(Arr);
+ Imaging.FreeImagesInArray(Arr);
+ end
+ else
+ inherited AssignTo(Dest);
+end;
+
+procedure TImagingGraphic.Assign(Source: TPersistent);
+begin
+ if Source is TBaseImage then
+ AssignFromImage(TBaseImage(Source))
+ else
+ inherited Assign(Source);
+end;
+
+procedure TImagingGraphic.AssignFromImage(Image: TBaseImage);
+begin
+ if (Image <> nil) and Image.Valid then
+ AssignFromImageData(Image.ImageDataPointer^);
+end;
+
+procedure TImagingGraphic.AssignToImage(Image: TBaseImage);
+begin
+ if (Image <> nil) and (Image.ImageDataPointer <> nil) then
+ AssignToImageData(Image.ImageDataPointer^);
+end;
+
+procedure TImagingGraphic.AssignFromImageData(const ImageData: TImageData);
+begin
+ if Imaging.TestImage(ImageData) then
+ ConvertDataToBitmap(ImageData, Self);
+end;
+
+procedure TImagingGraphic.AssignToImageData(var ImageData: TImageData);
+begin
+ Imaging.FreeImage(ImageData);
+ ConvertBitmapToData(Self, ImageData);
+end;
+
+
+{ TImagingGraphicForSave class implementation }
+
+constructor TImagingGraphicForSave.Create;
+begin
+ inherited Create;
+ FDefaultFileExt := GetFileFormat.Extensions[0];
+ FSavingFormat := ifUnknown;
+ GetFileFormat.CheckOptionsValidity;
+end;
+
+procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream);
+var
+ Image: TSingleImage;
+begin
+ if FDefaultFileExt <> '' then
+ begin
+ Image := TSingleImage.Create;
+ try
+ Image.Assign(Self);
+ if FSavingFormat <> ifUnknown then
+ Image.Format := FSavingFormat;
+ Image.SaveToStream(FDefaultFileExt, Stream);
+ finally
+ Image.Free;
+ end;
+ end;
+end;
+
+procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
+begin
+ WriteDataToStream(Stream);
+end;
+
+{$IFDEF COMPONENT_SET_LCL}
+class function TImagingGraphicForSave.GetFileExtensions: string;
+begin
+ Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
+end;
+
+function TImagingGraphicForSave.GetMimeType: string;
+begin
+ Result := 'image/' + FDefaultFileExt;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_BITMAP}
+
+{ TImagingBitmap class implementation }
+
+constructor TImagingBitmap.Create;
+begin
+ inherited Create;
+ FUseRLE := (GetFileFormat as TBitmapFileFormat).UseRLE;
+end;
+
+class function TImagingBitmap.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TBitmapFileFormat);
+end;
+
+procedure TImagingBitmap.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingBitmapRLE, Ord(FUseRLE));
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JPEG}
+
+{ TImagingJpeg class implementation }
+
+constructor TImagingJpeg.Create;
+begin
+ inherited Create;
+ FQuality := (GetFileFormat as TJpegFileFormat).Quality;
+ FProgressive := (GetFileFormat as TJpegFileFormat).Progressive;
+end;
+
+class function TImagingJpeg.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TJpegFileFormat);
+end;
+
+{$IFDEF COMPONENT_SET_LCL}
+function TImagingJpeg.GetMimeType: string;
+begin
+ Result := 'image/jpeg';
+end;
+{$ENDIF}
+
+procedure TImagingJpeg.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingJpegQuality, FQuality);
+ Imaging.SetOption(ImagingJpegProgressive, Ord(FProgressive));
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_PNG}
+
+{ TImagingPNG class implementation }
+
+constructor TImagingPNG.Create;
+begin
+ inherited Create;
+ FPreFilter := (GetFileFormat as TPNGFileFormat).PreFilter;
+ FCompressLevel := (GetFileFormat as TPNGFileFormat).CompressLevel;
+end;
+
+class function TImagingPNG.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TPNGFileFormat);
+end;
+
+procedure TImagingPNG.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingPNGPreFilter, FPreFilter);
+ Imaging.SetOption(ImagingPNGCompressLevel, FCompressLevel);
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_GIF}
+
+{ TImagingGIF class implementation}
+
+class function TImagingGIF.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TGIFFileFormat);
+end;
+
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_TARGA}
+
+{ TImagingTarga class implementation }
+
+constructor TImagingTarga.Create;
+begin
+ inherited Create;
+ FUseRLE := (GetFileFormat as TTargaFileFormat).UseRLE;
+end;
+
+class function TImagingTarga.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TTargaFileFormat);
+end;
+
+procedure TImagingTarga.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingTargaRLE, Ord(FUseRLE));
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_DDS}
+
+{ TImagingDDS class implementation }
+
+constructor TImagingDDS.Create;
+begin
+ inherited Create;
+ FCompression := dcNone;
+end;
+
+class function TImagingDDS.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TDDSFileFormat);
+end;
+
+procedure TImagingDDS.SaveToStream(Stream: TStream);
+begin
+ case FCompression of
+ dcNone: FSavingFormat := ifUnknown;
+ dcDXT1: FSavingFormat := ifDXT1;
+ dcDXT3: FSavingFormat := ifDXT3;
+ dcDXT5: FSavingFormat := ifDXT5;
+ end;
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingDDSSaveCubeMap, Ord(False));
+ Imaging.SetOption(ImagingDDSSaveVolume, Ord(False));
+ Imaging.SetOption(ImagingDDSSaveMipMapCount, 1);
+ Imaging.SetOption(ImagingDDSSaveDepth, 1);
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_MNG}
+
+{ TImagingMNG class implementation }
+
+constructor TImagingMNG.Create;
+begin
+ inherited Create;
+ FLossyCompression := (GetFileFormat as TMNGFileFormat).LossyCompression;
+ FLossyAlpha := (GetFileFormat as TMNGFileFormat).LossyAlpha;
+ FPreFilter := (GetFileFormat as TMNGFileFormat).PreFilter;
+ FCompressLevel := (GetFileFormat as TMNGFileFormat).CompressLevel;
+ FQuality := (GetFileFormat as TMNGFileFormat).Quality;
+ FProgressive := (GetFileFormat as TMNGFileFormat).Progressive;
+end;
+
+class function TImagingMNG.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TMNGFileFormat);
+end;
+
+{$IFDEF COMPONENT_SET_LCL}
+function TImagingMNG.GetMimeType: string;
+begin
+ Result := 'video/mng';
+end;
+{$ENDIF}
+
+procedure TImagingMNG.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingMNGLossyCompression, Ord(FLossyCompression));
+ Imaging.SetOption(ImagingMNGLossyAlpha, Ord(FLossyAlpha));
+ Imaging.SetOption(ImagingMNGPreFilter, FPreFilter);
+ Imaging.SetOption(ImagingMNGCompressLevel, FCompressLevel);
+ Imaging.SetOption(ImagingMNGQuality, FQuality);
+ Imaging.SetOption(ImagingMNGProgressive, Ord(FProgressive));
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+
+{ TImagingJNG class implementation }
+
+constructor TImagingJNG.Create;
+begin
+ inherited Create;
+ FLossyAlpha := (GetFileFormat as TJNGFileFormat).LossyAlpha;
+ FAlphaPreFilter := (GetFileFormat as TJNGFileFormat).PreFilter;
+ FAlphaCompressLevel := (GetFileFormat as TJNGFileFormat).CompressLevel;
+ FQuality := (GetFileFormat as TJNGFileFormat).Quality;
+ FProgressive := (GetFileFormat as TJNGFileFormat).Progressive;
+end;
+
+class function TImagingJNG.GetFileFormat: TImageFileFormat;
+begin
+ Result := FindImageFileFormatByClass(TJNGFileFormat);
+end;
+
+procedure TImagingJNG.SaveToStream(Stream: TStream);
+begin
+ Imaging.PushOptions;
+ Imaging.SetOption(ImagingJNGLossyALpha, Ord(FLossyAlpha));
+ Imaging.SetOption(ImagingJNGAlphaPreFilter, FAlphaPreFilter);
+ Imaging.SetOption(ImagingJNGAlphaCompressLevel, FAlphaCompressLevel);
+ Imaging.SetOption(ImagingJNGQuality, FQuality);
+ Imaging.SetOption(ImagingJNGProgressive, Ord(FProgressive));
+ inherited SaveToStream(Stream);
+ Imaging.PopOptions;
+end;
+{$ENDIF}
+
+initialization
+ RegisterTypes;
+finalization
+ UnRegisterTypes;
+
+{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
+ when using Delphi 2009+.
+ - Fixed garbled LCL TBitmaps created by ConvertDataToBitmap
+ in Mac OS X (Carbon).
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Added some more IFDEFs for Lazarus widget sets.
+ - Removed CLX code.
+ - GTK version of Unix DisplayImageData only used with LCL GTK so the
+ the rest of the unit can be used with Qt or other LCL interfaces.
+ - Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions.
+ - Changed file format conditional compilation to reflect changes
+ in LINK symbols.
+ - Lazarus 0.9.26 compatibility changes.
+
+ -- 0.24.1 Changes/Bug Fixes ---------------------------------
+ - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
+ with GTK2 target.
+ - Added commnets with code for Lazarus rev. 11861+ regarding
+ RawImage interface. Replace current code with that in comments
+ if you use Lazarus from SVN. New RawImage interface will be used by
+ default after next Lazarus release.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added TImagingGIF.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Uses only high level interface now (except for saving options).
+ - Slightly changed class hierarchy. TImagingGraphic is now only for loading
+ and base class for savers is new TImagingGraphicForSave. Also
+ TImagingGraphic is now registered with all supported file formats
+ by TPicture's format support.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added DisplayImage procedures (thanks to Paul Michell, modified)
+ - removed RegisterTypes and UnRegisterTypes from interface section,
+ they are called automatically
+ - added procedures: ConvertImageToBitmap and ConvertBitmapToImage
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - LCL data to bitmap conversion didn´t work in Linux, fixed
+ - added MNG file format
+ - added JNG file format
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - made it LCL compatible
+ - made it CLX compatible
+ - added all initial stuff
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingDds.pas b/src/lib/vampimg/ImagingDds.pas
--- /dev/null
@@ -0,0 +1,863 @@
+{
+ $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z 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, ifATI1N, ifATI2N];
+
+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));
+ FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
+ (Byte('1') shl 24));
+ FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
+ (Byte('2') 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;
+ FOURCC_ATI1: SrcFormat := ifATI1N;
+ FOURCC_ATI2: SrcFormat := ifATI2N;
+ 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;
+ ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1;
+ ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2;
+ 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.25.0 Changes/Bug Fixes ---------------------------------
+ - Added support for 3Dc ATI1/2 formats.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingExport.pas b/src/lib/vampimg/ImagingExport.pas
--- /dev/null
@@ -0,0 +1,890 @@
+{
+ $Id: ImagingExport.pas 173 2009-09-04 17:05: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 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: PAnsiChar): Boolean; cdecl;
+{ Look at DetermineMemoryFormat for details. Ext should have enough space for
+ result file extension.}
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
+{ Look at IsFileFormatSupported for details.}
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
+{ Look at EnumFileFormats for details.}
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
+ 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: PAnsiChar; 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: PAnsiChar; 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: PAnsiChar; const Image: TImageData): Boolean; cdecl;
+{ Look at SaveImageToMemory for details.}
+function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
+ const Image: TImageData): Boolean; cdecl;
+{ Look at SaveMultiImageToFile for details.}
+function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
+{ Look at SaveMultiImageToMemory for details.}
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; 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: Single): 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: PAnsiChar): Boolean;
+var
+ S: string;
+begin
+ try
+ S := Imaging.DetermineFileFormat(FileName);
+ Result := S <> '';
+ StrCopy(Ext, PAnsiChar(AnsiString(S)));
+ except
+ Result := False;
+ end;
+end;
+
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
+var
+ S: string;
+begin
+ try
+ S := Imaging.DetermineMemoryFormat(Data, Size);
+ Result := S <> '';
+ StrCopy(Ext, PAnsiChar(AnsiString(S)));
+ except
+ Result := False;
+ end;
+end;
+
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
+begin
+ try
+ Result := Imaging.IsFileFormatSupported(FileName);
+ except
+ Result := False;
+ end;
+end;
+
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
+ var CanSave, IsMultiImageFormat: Boolean): Boolean;
+var
+ StrName, StrDefaultExt, StrMasks: string;
+begin
+ try
+ Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
+ IsMultiImageFormat);
+ StrCopy(Name, PAnsiChar(AnsiString(StrName)));
+ StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
+ StrCopy(Masks, PAnsiChar(AnsiString(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: PAnsiChar; 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: PAnsiChar; 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: PAnsiChar; const Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.SaveImageToFile(FileName, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveImageToMemory(Ext: PAnsiChar; 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: PAnsiChar;
+ ImageList: TImageDataList): Boolean;
+begin
+ try
+ Result := Imaging.SaveMultiImageToFile(FileName,
+ PInternalList(ImageList).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; 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: Single): 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.26.3 ---------------------------------------------------
+ - changed PChars to PAnsiChars and some more D2009 friendly
+ casts.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingExtras.pas b/src/lib/vampimg/ImagingExtras.pas
--- /dev/null
@@ -0,0 +1,137 @@
+{
+ $Id: ImagingExtras.pas 171 2009-09-02 01:34:19Z 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 is helper unit that registers all image file formats in Extras package
+ to Imaging core loading and saving functions. Just put this unit in your uses
+ clause instead of adding every unit that provides new file format support.
+ Also new constants for SetOption/GetOption functions for new file formats
+ are located here.}
+unit ImagingExtras;
+
+{$I ImagingOptions.inc}
+
+{$DEFINE DONT_LINK_JPEG2000} // link support for JPEG2000 images
+{$DEFINE DONT_LINK_TIFF} // link support for TIFF images
+//{$DEFINE DONT_LINK_PSD} // link support for PSD images
+//{$DEFINE DONT_LINK_PCX} // link support for PCX images
+//{$DEFINE DONT_LINK_XPM} // link support for XPM images
+{ $IFNDEF FULL_FEATURE_SET}
+ {$DEFINE DONT_LINK_ELDER} // link support for Elder Imagery images
+{ $ENDIF}
+
+{$IF not (Defined(DELPHI) or
+ (Defined(FPC) and not Defined(MSDOS) and
+ ((Defined(CPU86) and (Defined(LINUX) or Defined(WIN32) or Defined(DARWIN)) or
+ (Defined(CPUX86_64) and Defined(LINUX)))))
+ )}
+ // JPEG2000 only for 32bit Windows/Linux/OSX and for 64bit Unix with FPC
+ {$DEFINE DONT_LINK_JPEG2000}
+{$IFEND}
+
+{$IF not Defined(DELPHI)}
+ {$DEFINE DONT_LINK_TIFF} // Only for Delphi now
+{$IFEND}
+
+interface
+
+const
+ { Those are new options for GetOption/SetOption interface. }
+
+ { Controls JPEG 2000 lossy compression quality. It is number in range 1..100.
+ 1 means small/ugly file, 100 means large/nice file. Default is 80.}
+ ImagingJpeg2000Quality = 55;
+ { Controls whether JPEG 2000 image is saved with full file headers or just
+ as code stream. Default value is False (0).}
+ ImagingJpeg2000CodeStreamOnly = 56;
+ { Specifies JPEG 2000 image compression type. If True (1), saved JPEG 2000 files
+ will be losslessly compressed. Otherwise lossy compression is used.
+ Default value is False (0).}
+ ImagingJpeg2000LosslessCompression = 57;
+ { Specifies compression scheme used when saving TIFF images. Supported values
+ are 0 (Uncompressed), 1 (LZW), 2 (PackBits RLE), 3 (Deflate - ZLib), 4 (JPEG).
+ Default is 1 (LZW). Note that not all images can be stored with
+ JPEG compression - these images will be saved with default compression if
+ JPEG is set.}
+ ImagingTiffCompression = 65;
+ { If enabled image data is saved as layer of PSD file. This is required
+ to get proper transparency when opened in Photoshop for images with
+ alpha data (will be opened with one layer, RGB color channels, and transparency).
+ If you don't need this Photoshop compatibility turn this option off as you'll get
+ smaller file (will be opened in PS as background raster with RGBA channels).
+ Default value is True (1). }
+ ImagingPSDSaveAsLayer = 70;
+
+implementation
+
+uses
+{$IFNDEF DONT_LINK_JPEG2000}
+ ImagingJpeg2000,
+{$ENDIF}
+{$IFNDEF DONT_LINK_TIFF}
+ ImagingTiff,
+{$ENDIF}
+{$IFNDEF DONT_LINK_PSD}
+ ImagingPsd,
+{$ENDIF}
+{$IFNDEF DONT_LINK_PCX}
+ ImagingPcx,
+{$ENDIF}
+{$IFNDEF DONT_LINK_XPM}
+ ImagingXpm,
+{$ENDIF}
+{$IFNDEF DONT_LINK_ELDER}
+ ElderImagery,
+{$ENDIF}
+ Imaging;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Allowed JPEG2000 for Mac OS X x86
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - ElderImagery formats are disabled by default, TIFF enabled.
+ - Changed _LINK_ symbols according to changes in ImagingOptions.inc.
+
+ -- 0.24.1 Changes/Bug Fixes ---------------------------------
+ - Allowed JPEG2000 for x86_64 CPUS in Linux
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Better IF conditional to disable JPEG2000 on unsupported platforms.
+ - Added PSD and TIFF related stuff.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Created with initial stuff.
+
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingFormats.pas b/src/lib/vampimg/ImagingFormats.pas
--- /dev/null
@@ -0,0 +1,4306 @@
+{
+ $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z 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 manages information about all image data formats and contains
+ low level format conversion, manipulation, and other related functions.}
+unit ImagingFormats;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingUtility;
+
+type
+ TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo;
+ PImageFormatInfoArray = ^TImageFormatInfoArray;
+
+
+{ Additional image manipulation functions (usually used internally by Imaging unit) }
+
+type
+ { Color reduction operations.}
+ TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap,
+ raMapImage);
+ TReduceColorsActions = set of TReduceColorsAction;
+const
+ AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram,
+ raMakeColorMap, raMapImage];
+{ Reduces the number of colors of source. Src is bits of source image
+ (ARGB or floating point) and Dst is in some indexed format. MaxColors
+ is the number of colors to which reduce and DstPal is palette to which
+ the resulting colors are written and it must be allocated to at least
+ MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
+ when creating color histogram. If $FF is used all 8bits of color channels
+ are used which can be slow for large images with many colors so you can
+ use lower masks to speed it up.}
+procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
+ DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions);
+{ Stretches rectangle in source image to rectangle in destination image
+ using nearest neighbor filtering. It is fast but results look blocky
+ because there is no interpolation used. SrcImage and DstImage must be
+ in the same data format. Works for all data formats except special formats.}
+procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt);
+type
+ { Built-in sampling filters.}
+ TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
+ sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
+ { Type of custom sampling function}
+ TFilterFunction = function(Value: Single): Single;
+const
+ { Default resampling filter used for bicubic resizing.}
+ DefaultCubicFilter = sfCatmullRom;
+var
+ { Built-in filter functions.}
+ SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction;
+ { Default radii of built-in filter functions.}
+ SamplingFilterRadii: array[TSamplingFilter] of Single;
+
+{ Stretches rectangle in source image to rectangle in destination image
+ with resampling. One of built-in resampling filters defined by
+ Filter is used. Set WrapEdges to True for seamlessly tileable images.
+ SrcImage and DstImage must be in the same data format.
+ Works for all data formats except special and indexed formats.}
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload;
+{ Stretches rectangle in source image to rectangle in destination image
+ with resampling. You can use custom sampling function and filter radius.
+ Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
+ must be in the same data format.
+ Works for all data formats except special and indexed formats.}
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TFilterFunction; Radius: Single;
+ WrapEdges: Boolean = False); overload;
+{ Helper for functions that create mipmap levels. BiggerLevel is
+ valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
+ with Width and Height dimensions and it is filled with pixels of BiggerLevel
+ using resampling filter specified by ImagingMipMapFilter option.
+ Uses StretchNearest and StretchResample internally so the same image data format
+ limitations apply.}
+procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
+ var SmallerLevel: TImageData);
+
+
+{ Various helper & support functions }
+
+{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
+procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
+function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Translates pixel color in SrcFormat to DstFormat.}
+procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
+ DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
+{ Clamps floating point pixel channel values to [0.0, 1.0] range.}
+procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
+ pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
+procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+{ Removes padding from image with scanlines that have aligned sizes. Bpp is
+ the number of bytes per pixel of dest and WidthBytes is the number of bytes
+ per scanlines of source.}
+procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+
+{ Converts 1bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 1bit images.}
+procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+{ Converts 2bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 2bit images.}
+procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+{ Converts 4bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 4bit images.}
+procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+
+{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
+ may contain 1 bit alpha but there is no indication of it. This function checks
+ all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
+ alpha bit set it returns True, otherwise False.}
+function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
+{ Helper function for image file loaders. This function checks is similar
+ to Has16BitImageAlpha but works with A8R8G8B8 format.}
+function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
+{ Provides indexed access to each line of pixels. Does not work with special
+ format images.}
+function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
+ LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns True if Format is valid image data format identifier.}
+function IsImageFormatValid(Format: TImageFormat): Boolean;
+
+{ Converts 16bit half floating point value to 32bit Single.}
+function HalfToFloat(Half: THalfFloat): Single;
+{ Converts 32bit Single to 16bit half floating point.}
+function FloatToHalf(Float: Single): THalfFloat;
+
+{ Converts half float color value to single-precision floating point color.}
+function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Converts single-precision floating point color to half float color.}
+function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
+procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
+
+type
+ TPointRec = record
+ Pos: LongInt;
+ Weight: Single;
+ end;
+ TCluster = array of TPointRec;
+ TMappingTable = array of TCluster;
+
+{ Helper function for resampling.}
+function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
+{ Helper function for resampling.}
+procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
+
+
+{ Pixel readers/writers for different image formats }
+
+{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
+procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColor64Rec);
+{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
+procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColor64Rec);
+
+{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
+ and alpha to 16 bits.}
+procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Gray: TColor64Rec; var Alpha: Word);
+{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
+ and alpha to 16 bits.}
+procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Gray: TColor64Rec; Alpha: Word);
+
+{ Returns pixel of image in any floating point format. Channel values are
+ in range <0.0, 1.0>.}
+procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColorFPRec);
+{ Sets pixel of image in any floating point format. Channel values must be
+ in range <0.0, 1.0>.}
+procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColorFPRec);
+
+{ Returns pixel of image in any indexed format. Returned value is index to
+ the palette.}
+procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Index: LongWord);
+{ Sets pixel of image in any indexed format. Index is index to the palette.}
+procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ Index: LongWord);
+
+
+{ Pixel readers/writers for 32bit and FP colors}
+
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to 32 bit ARGB.}
+function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColor32Rec;
+{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
+ native format and then written to Image.}
+procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32; const Color: TColor32Rec);
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to FP ARGB.}
+function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColorFPRec;
+{ Procedure for setting pixel colors. Input FP ARGB color is translated to
+ native format and then written to Image.}
+procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32; const Color: TColorFPRec);
+
+
+{ Image format conversion functions }
+
+{ Converts any ARGB format to any ARGB format.}
+procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any grayscale format.}
+procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any floating point format.}
+procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any indexed format.}
+procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any grayscale format to any grayscale format.}
+procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any ARGB format.}
+procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any floating point format.}
+procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any indexed format.}
+procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any floating point format to any floating point format.}
+procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any ARGB format.}
+procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any grayscale format.}
+procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any indexed format.}
+procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any indexed format to any indexed format.}
+procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
+{ Converts any indexed format to any ARGB format.}
+procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+{ Converts any indexed format to any grayscale format.}
+procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+{ Converts any indexed format to any floating point format.}
+procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+
+
+{ Color constructor functions }
+
+{ Constructs TColor24Rec color.}
+function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor32Rec color.}
+function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor48Rec color.}
+function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor64Rec color.}
+function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColorFPRec color.}
+function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColorHFRec color.}
+function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+
+{ Special formats conversion functions }
+
+{ Converts image to/from/between special image formats (dxtc, ...).}
+procedure ConvertSpecial(var Image: TImageData; SrcInfo,
+ DstInfo: PImageFormatInfo);
+
+
+{ Inits all image format information. Called internally on startup.}
+procedure InitImageFormats(var Infos: TImageFormatInfoArray);
+
+const
+ // Grayscale conversion channel weights
+ GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
+
+ // Contants for converting integer colors to floating point
+ OneDiv8Bit: Single = 1.0 / 255.0;
+ OneDiv16Bit: Single = 1.0 / 65535.0;
+
+implementation
+
+{ TImageFormatInfo member functions }
+
+{ Returns size in bytes of image in given standard format where
+ Size = Width * Height * Bpp.}
+function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+{ Checks if Width and Height are valid for given standard format.}
+procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
+{ Returns size in bytes of image in given DXT format.}
+function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+{ Checks if Width and Height are valid for given DXT format. If they are
+ not valid, they are changed to pass the check.}
+procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
+{ Returns size in bytes of image in BTC format.}
+function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+
+{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
+
+function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
+procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
+function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
+procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
+function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+var
+ PFR3G3B2: TPixelFormatInfo;
+ PFX5R1G1B1: TPixelFormatInfo;
+ PFR5G6B5: TPixelFormatInfo;
+ PFA1R5G5B5: TPixelFormatInfo;
+ PFA4R4G4B4: TPixelFormatInfo;
+ PFX1R5G5B5: TPixelFormatInfo;
+ PFX4R4G4B4: TPixelFormatInfo;
+ FInfos: PImageFormatInfoArray;
+
+var
+ // Free Pascal generates hundreds of warnings here
+{$WARNINGS OFF}
+
+ // indexed formats
+ Index8Info: TImageFormatInfo = (
+ Format: ifIndex8;
+ Name: 'Index8';
+ BytesPerPixel: 1;
+ ChannelCount: 1;
+ PaletteEntries: 256;
+ HasAlphaChannel: True;
+ IsIndexed: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // grayscale formats
+ Gray8Info: TImageFormatInfo = (
+ Format: ifGray8;
+ Name: 'Gray8';
+ BytesPerPixel: 1;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ A8Gray8Info: TImageFormatInfo = (
+ Format: ifA8Gray8;
+ Name: 'A8Gray8';
+ BytesPerPixel: 2;
+ ChannelCount: 2;
+ HasGrayChannel: True;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ Gray16Info: TImageFormatInfo = (
+ Format: ifGray16;
+ Name: 'Gray16';
+ BytesPerPixel: 2;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ Gray32Info: TImageFormatInfo = (
+ Format: ifGray32;
+ Name: 'Gray32';
+ BytesPerPixel: 4;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ Gray64Info: TImageFormatInfo = (
+ Format: ifGray64;
+ Name: 'Gray64';
+ BytesPerPixel: 8;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16Gray16Info: TImageFormatInfo = (
+ Format: ifA16Gray16;
+ Name: 'A16Gray16';
+ BytesPerPixel: 4;
+ ChannelCount: 2;
+ HasGrayChannel: True;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // ARGB formats
+ X5R1G1B1Info: TImageFormatInfo = (
+ Format: ifX5R1G1B1;
+ Name: 'X5R1G1B1';
+ BytesPerPixel: 1;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX5R1G1B1;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R3G3B2Info: TImageFormatInfo = (
+ Format: ifR3G3B2;
+ Name: 'R3G3B2';
+ BytesPerPixel: 1;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFR3G3B2;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R5G6B5Info: TImageFormatInfo = (
+ Format: ifR5G6B5;
+ Name: 'R5G6B5';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFR5G6B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A1R5G5B5Info: TImageFormatInfo = (
+ Format: ifA1R5G5B5;
+ Name: 'A1R5G5B5';
+ BytesPerPixel: 2;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ UsePixelFormat: True;
+ PixelFormat: @PFA1R5G5B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A4R4G4B4Info: TImageFormatInfo = (
+ Format: ifA4R4G4B4;
+ Name: 'A4R4G4B4';
+ BytesPerPixel: 2;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ UsePixelFormat: True;
+ PixelFormat: @PFA4R4G4B4;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ X1R5G5B5Info: TImageFormatInfo = (
+ Format: ifX1R5G5B5;
+ Name: 'X1R5G5B5';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX1R5G5B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ X4R4G4B4Info: TImageFormatInfo = (
+ Format: ifX4R4G4B4;
+ Name: 'X4R4G4B4';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX4R4G4B4;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R8G8B8Info: TImageFormatInfo = (
+ Format: ifR8G8B8;
+ Name: 'R8G8B8';
+ BytesPerPixel: 3;
+ ChannelCount: 3;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ A8R8G8B8Info: TImageFormatInfo = (
+ Format: ifA8R8G8B8;
+ Name: 'A8R8G8B8';
+ BytesPerPixel: 4;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32ifA8R8G8B8;
+ GetPixelFP: GetPixelFPifA8R8G8B8;
+ SetPixel32: SetPixel32ifA8R8G8B8;
+ SetPixelFP: SetPixelFPifA8R8G8B8);
+
+ X8R8G8B8Info: TImageFormatInfo = (
+ Format: ifX8R8G8B8;
+ Name: 'X8R8G8B8';
+ BytesPerPixel: 4;
+ ChannelCount: 3;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ R16G16B16Info: TImageFormatInfo = (
+ Format: ifR16G16B16;
+ Name: 'R16G16B16';
+ BytesPerPixel: 6;
+ ChannelCount: 3;
+ RBSwapFormat: ifB16G16R16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16R16G16B16Info: TImageFormatInfo = (
+ Format: ifA16R16G16B16;
+ Name: 'A16R16G16B16';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ RBSwapFormat: ifA16B16G16R16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ B16G16R16Info: TImageFormatInfo = (
+ Format: ifB16G16R16;
+ Name: 'B16G16R16';
+ BytesPerPixel: 6;
+ ChannelCount: 3;
+ IsRBSwapped: True;
+ RBSwapFormat: ifR16G16B16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16B16G16R16Info: TImageFormatInfo = (
+ Format: ifA16B16G16R16;
+ Name: 'A16B16G16R16';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA16R16G16B16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // floating point formats
+ R32FInfo: TImageFormatInfo = (
+ Format: ifR32F;
+ Name: 'R32F';
+ BytesPerPixel: 4;
+ ChannelCount: 1;
+ IsFloatingPoint: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ A32R32G32B32FInfo: TImageFormatInfo = (
+ Format: ifA32R32G32B32F;
+ Name: 'A32R32G32B32F';
+ BytesPerPixel: 16;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ RBSwapFormat: ifA32B32G32R32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ A32B32G32R32FInfo: TImageFormatInfo = (
+ Format: ifA32B32G32R32F;
+ Name: 'A32B32G32R32F';
+ BytesPerPixel: 16;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA32R32G32B32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ R16FInfo: TImageFormatInfo = (
+ Format: ifR16F;
+ Name: 'R16F';
+ BytesPerPixel: 2;
+ ChannelCount: 1;
+ IsFloatingPoint: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16R16G16B16FInfo: TImageFormatInfo = (
+ Format: ifA16R16G16B16F;
+ Name: 'A16R16G16B16F';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ RBSwapFormat: ifA16B16G16R16F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16B16G16R16FInfo: TImageFormatInfo = (
+ Format: ifA16B16G16R16F;
+ Name: 'A16B16G16R16F';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA16R16G16B16F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // special formats
+ DXT1Info: TImageFormatInfo = (
+ Format: ifDXT1;
+ Name: 'DXT1';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXT3Info: TImageFormatInfo = (
+ Format: ifDXT3;
+ Name: 'DXT3';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXT5Info: TImageFormatInfo = (
+ Format: ifDXT5;
+ Name: 'DXT5';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ BTCInfo: TImageFormatInfo = (
+ Format: ifBTC;
+ Name: 'BTC';
+ ChannelCount: 1;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetBTCPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifGray8);
+
+ ATI1NInfo: TImageFormatInfo = (
+ Format: ifATI1N;
+ Name: 'ATI1N';
+ ChannelCount: 1;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifGray8);
+
+ ATI2NInfo: TImageFormatInfo = (
+ Format: ifATI2N;
+ Name: 'ATI2N';
+ ChannelCount: 2;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+{$WARNINGS ON}
+
+function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
+
+procedure InitImageFormats(var Infos: TImageFormatInfoArray);
+begin
+ FInfos := @Infos;
+
+ Infos[ifDefault] := @A8R8G8B8Info;
+ // indexed formats
+ Infos[ifIndex8] := @Index8Info;
+ // grayscale formats
+ Infos[ifGray8] := @Gray8Info;
+ Infos[ifA8Gray8] := @A8Gray8Info;
+ Infos[ifGray16] := @Gray16Info;
+ Infos[ifGray32] := @Gray32Info;
+ Infos[ifGray64] := @Gray64Info;
+ Infos[ifA16Gray16] := @A16Gray16Info;
+ // ARGB formats
+ Infos[ifX5R1G1B1] := @X5R1G1B1Info;
+ Infos[ifR3G3B2] := @R3G3B2Info;
+ Infos[ifR5G6B5] := @R5G6B5Info;
+ Infos[ifA1R5G5B5] := @A1R5G5B5Info;
+ Infos[ifA4R4G4B4] := @A4R4G4B4Info;
+ Infos[ifX1R5G5B5] := @X1R5G5B5Info;
+ Infos[ifX4R4G4B4] := @X4R4G4B4Info;
+ Infos[ifR8G8B8] := @R8G8B8Info;
+ Infos[ifA8R8G8B8] := @A8R8G8B8Info;
+ Infos[ifX8R8G8B8] := @X8R8G8B8Info;
+ Infos[ifR16G16B16] := @R16G16B16Info;
+ Infos[ifA16R16G16B16] := @A16R16G16B16Info;
+ Infos[ifB16G16R16] := @B16G16R16Info;
+ Infos[ifA16B16G16R16] := @A16B16G16R16Info;
+ // floating point formats
+ Infos[ifR32F] := @R32FInfo;
+ Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo;
+ Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo;
+ Infos[ifR16F] := @R16FInfo;
+ Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
+ Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
+ // special formats
+ Infos[ifDXT1] := @DXT1Info;
+ Infos[ifDXT3] := @DXT3Info;
+ Infos[ifDXT5] := @DXT5Info;
+ Infos[ifBTC] := @BTCInfo;
+ Infos[ifATI1N] := @ATI1NInfo;
+ Infos[ifATI2N] := @ATI2NInfo;
+
+ PFR3G3B2 := PixelFormat(0, 3, 3, 2);
+ PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
+ PFR5G6B5 := PixelFormat(0, 5, 6, 5);
+ PFA1R5G5B5 := PixelFormat(1, 5, 5, 5);
+ PFA4R4G4B4 := PixelFormat(4, 4, 4, 4);
+ PFX1R5G5B5 := PixelFormat(0, 5, 5, 5);
+ PFX4R4G4B4 := PixelFormat(0, 4, 4, 4);
+end;
+
+
+{ Internal unit helper functions }
+
+function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo;
+begin
+ Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount +
+ BBitCount);
+ Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
+ Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
+ Result.BBitMask := (1 shl BBitCount) - 1;
+ Result.ABitCount := ABitCount;
+ Result.RBitCount := RBitCount;
+ Result.GBitCount := GBitCount;
+ Result.BBitCount := BBitCount;
+ Result.AShift := RBitCount + GBitCount + BBitCount;
+ Result.RShift := GBitCount + BBitCount;
+ Result.GShift := BBitCount;
+ Result.BShift := 0;
+ Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1);
+ Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1);
+ Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1);
+ Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1);
+end;
+
+function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo;
+
+ function GetBitCount(B: LongWord): LongWord;
+ var
+ I: LongWord;
+ begin
+ I := 0;
+ while (I < 31) and (((1 shl I) and B) = 0) do
+ Inc(I);
+ Result := 0;
+ while ((1 shl I) and B) <> 0 do
+ begin
+ Inc(I);
+ Inc(Result);
+ end;
+ end;
+
+begin
+ Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask),
+ GetBitCount(GBitMask), GetBitCount(BBitMask));
+end;
+
+function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ Result :=
+ (A shl ABitCount shr 8 shl AShift) or
+ (R shl RBitCount shr 8 shl RShift) or
+ (G shl GBitCount shr 8 shl GShift) or
+ (B shl BBitCount shr 8 shl BShift);
+end;
+
+procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord;
+ var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ begin
+ A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
+ R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
+ G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
+ B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
+ end;
+end;
+
+function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ Result :=
+ (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or
+ (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or
+ (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or
+ (Byte(ARGB) shl BBitCount shr 8 shl BShift);
+end;
+
+function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ Result := 0;
+ with PF, TColor32Rec(Result) do
+ begin
+ A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
+ R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
+ G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
+ B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
+ end;
+end;
+
+
+{ Color constructor functions }
+
+
+function Color24(R, G, B: Byte): TColor24Rec;
+begin
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color32(A, R, G, B: Byte): TColor32Rec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color48(R, G, B: Word): TColor48Rec;
+begin
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color64(A, R, G, B: Word): TColor64Rec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function ColorFP(A, R, G, B: Single): TColorFPRec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function ColorHF(A, R, G, B: THalfFloat): TColorHFRec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+
+{ Additional image manipulation functions (usually used internally by Imaging unit) }
+
+const
+ MaxPossibleColors = 4096;
+ HashSize = 32768;
+ AlphaWeight = 1024;
+ RedWeight = 612;
+ GreenWeight = 1202;
+ BlueWeight = 234;
+
+type
+ PColorBin = ^TColorBin;
+ TColorBin = record
+ Color: TColor32Rec;
+ Number: LongInt;
+ Next: PColorBin;
+ end;
+
+ THashTable = array[0..HashSize - 1] of PColorBin;
+
+ TColorBox = record
+ AMin, AMax,
+ RMin, RMax,
+ GMin, GMax,
+ BMin, BMax: LongInt;
+ Total: LongInt;
+ Represented: TColor32Rec;
+ List: PColorBin;
+ end;
+
+var
+ Table: THashTable;
+ Box: array[0..MaxPossibleColors - 1] of TColorBox;
+ Boxes: LongInt;
+ BoxesCreated: Boolean = False;
+
+procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
+ DstPal: PPalette32; Actions: TReduceColorsActions);
+
+ procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo;
+ ChannelMask: Byte);
+ var
+ A, R, G, B: Byte;
+ I, Addr: LongInt;
+ PC: PColorBin;
+ Col: TColor32Rec;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Col := GetPixel32Generic(Src, SrcInfo, nil);
+ A := Col.A and ChannelMask;
+ R := Col.R and ChannelMask;
+ G := Col.G and ChannelMask;
+ B := Col.B and ChannelMask;
+
+ Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize;
+ PC := Table[Addr];
+
+ while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or
+ (PC.Color.B <> B) or (PC.Color.A <> A)) do
+ PC := PC.Next;
+
+ if PC = nil then
+ begin
+ New(PC);
+ PC.Color.R := R;
+ PC.Color.G := G;
+ PC.Color.B := B;
+ PC.Color.A := A;
+ PC.Number := 1;
+ PC.Next := Table[Addr];
+ Table[Addr] := PC;
+ end
+ else
+ Inc(PC^.Number);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ end;
+ end;
+
+ procedure InitBox (var Box : TColorBox);
+ begin
+ Box.AMin := 256;
+ Box.RMin := 256;
+ Box.GMin := 256;
+ Box.BMin := 256;
+ Box.AMax := -1;
+ Box.RMax := -1;
+ Box.GMax := -1;
+ Box.BMax := -1;
+ Box.Total := 0;
+ Box.List := nil;
+ end;
+
+ procedure ChangeBox (var Box: TColorBox; const C: TColorBin);
+ begin
+ with C.Color do
+ begin
+ if A < Box.AMin then Box.AMin := A;
+ if A > Box.AMax then Box.AMax := A;
+ if B < Box.BMin then Box.BMin := B;
+ if B > Box.BMax then Box.BMax := B;
+ if G < Box.GMin then Box.GMin := G;
+ if G > Box.GMax then Box.GMax := G;
+ if R < Box.RMin then Box.RMin := R;
+ if R > Box.RMax then Box.RMax := R;
+ end;
+ Inc(Box.Total, C.Number);
+ end;
+
+ procedure MakeColormap;
+ var
+ I, J: LongInt;
+ CP, Pom: PColorBin;
+ Cut, LargestIdx, Largest, Size, S: LongInt;
+ CutA, CutR, CutG, CutB: Boolean;
+ SumA, SumR, SumG, SumB: LongInt;
+ Temp: TColorBox;
+ begin
+ I := 0;
+ Boxes := 1;
+ LargestIdx := 0;
+ while (I < HashSize) and (Table[I] = nil) do
+ Inc(i);
+ if I < HashSize then
+ begin
+ // put all colors into Box[0]
+ InitBox(Box[0]);
+ repeat
+ CP := Table[I];
+ while CP.Next <> nil do
+ begin
+ ChangeBox(Box[0], CP^);
+ CP := CP.Next;
+ end;
+ ChangeBox(Box[0], CP^);
+ CP.Next := Box[0].List;
+ Box[0].List := Table[I];
+ Table[I] := nil;
+ repeat
+ Inc(I)
+ until (I = HashSize) or (Table[I] <> nil);
+ until I = HashSize;
+ // now all colors are in Box[0]
+ repeat
+ // cut one color box
+ Largest := 0;
+ for I := 0 to Boxes - 1 do
+ with Box[I] do
+ begin
+ Size := (AMax - AMin) * AlphaWeight;
+ S := (RMax - RMin) * RedWeight;
+ if S > Size then
+ Size := S;
+ S := (GMax - GMin) * GreenWeight;
+ if S > Size then
+ Size := S;
+ S := (BMax - BMin) * BlueWeight;
+ if S > Size then
+ Size := S;
+ if Size > Largest then
+ begin
+ Largest := Size;
+ LargestIdx := I;
+ end;
+ end;
+ if Largest > 0 then
+ begin
+ // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
+ CutR := False;
+ CutG := False;
+ CutB := False;
+ CutA := False;
+ with Box[LargestIdx] do
+ begin
+ if (AMax - AMin) * AlphaWeight = Largest then
+ begin
+ Cut := (AMax + AMin) shr 1;
+ CutA := True;
+ end
+ else
+ if (RMax - RMin) * RedWeight = Largest then
+ begin
+ Cut := (RMax + RMin) shr 1;
+ CutR := True;
+ end
+ else
+ if (GMax - GMin) * GreenWeight = Largest then
+ begin
+ Cut := (GMax + GMin) shr 1;
+ CutG := True;
+ end
+ else
+ begin
+ Cut := (BMax + BMin) shr 1;
+ CutB := True;
+ end;
+ CP := List;
+ end;
+ InitBox(Box[LargestIdx]);
+ InitBox(Box[Boxes]);
+ repeat
+ // distribute one color
+ Pom := CP.Next;
+ with CP.Color do
+ begin
+ if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or
+ (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then
+ I := LargestIdx
+ else
+ I := Boxes;
+ end;
+ CP.Next := Box[i].List;
+ Box[i].List := CP;
+ ChangeBox(Box[i], CP^);
+ CP := Pom;
+ until CP = nil;
+ Inc(Boxes);
+ end;
+ until (Boxes = MaxColors) or (Largest = 0);
+ // compute box representation
+ for I := 0 to Boxes - 1 do
+ begin
+ SumR := 0;
+ SumG := 0;
+ SumB := 0;
+ SumA := 0;
+ repeat
+ CP := Box[I].List;
+ Inc(SumR, CP.Color.R * CP.Number);
+ Inc(SumG, CP.Color.G * CP.Number);
+ Inc(SumB, CP.Color.B * CP.Number);
+ Inc(SumA, CP.Color.A * CP.Number);
+ Box[I].List := CP.Next;
+ Dispose(CP);
+ until Box[I].List = nil;
+ with Box[I] do
+ begin
+ Represented.A := SumA div Total;
+ Represented.R := SumR div Total;
+ Represented.G := SumG div Total;
+ Represented.B := SumB div Total;
+ AMin := AMin and ChannelMask;
+ RMin := RMin and ChannelMask;
+ GMin := GMin and ChannelMask;
+ BMin := BMin and ChannelMask;
+ AMax := (AMax and ChannelMask) + (not ChannelMask);
+ RMax := (RMax and ChannelMask) + (not ChannelMask);
+ GMax := (GMax and ChannelMask) + (not ChannelMask);
+ BMax := (BMax and ChannelMask) + (not ChannelMask);
+ end;
+ end;
+ // sort color boxes
+ for I := 0 to Boxes - 2 do
+ begin
+ Largest := 0;
+ for J := I to Boxes - 1 do
+ if Box[J].Total > Largest then
+ begin
+ Largest := Box[J].Total;
+ LargestIdx := J;
+ end;
+ if LargestIdx <> I then
+ begin
+ Temp := Box[I];
+ Box[I] := Box[LargestIdx];
+ Box[LargestIdx] := Temp;
+ end;
+ end;
+ end;
+ end;
+
+ procedure FillOutputPalette;
+ var
+ I: LongInt;
+ begin
+ FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
+ for I := 0 to MaxColors - 1 do
+ begin
+ if I < Boxes then
+ with Box[I].Represented do
+ begin
+ DstPal[I].A := A;
+ DstPal[I].R := R;
+ DstPal[I].G := G;
+ DstPal[I].B := B;
+ end
+ else
+ DstPal[I].Color := $FF000000;
+ end;
+ end;
+
+ function MapColor(const Col: TColor32Rec) : LongInt;
+ var
+ I: LongInt;
+ begin
+ I := 0;
+ with Col do
+ while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or
+ (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or
+ (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do
+ Inc(I);
+ if I = Boxes then
+ MapColor := 0
+ else
+ MapColor := I;
+ end;
+
+ procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo);
+ var
+ I: LongInt;
+ Col: TColor32Rec;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Col := GetPixel32Generic(Src, SrcInfo, nil);
+ IndexSetDstPixel(Dst, DstInfo, MapColor(Col));
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+ end;
+
+begin
+ MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors);
+
+ if (raUpdateHistogram in Actions) or (raMapImage in Actions) then
+ begin
+ Assert(not SrcInfo.IsSpecial);
+ Assert(not SrcInfo.IsIndexed);
+ end;
+
+ if raCreateHistogram in Actions then
+ FillChar(Table, SizeOf(Table), 0);
+
+ if raUpdateHistogram in Actions then
+ CreateHistogram(Src, SrcInfo, ChannelMask);
+
+ if raMakeColorMap in Actions then
+ begin
+ MakeColorMap;
+ FillOutputPalette;
+ end;
+
+ if raMapImage in Actions then
+ MapImage(Src, Dst, SrcInfo, DstInfo);
+end;
+
+procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt);
+var
+ Info: TImageFormatInfo;
+ ScaleX, ScaleY, X, Y, Xp, Yp: LongInt;
+ DstPixel, SrcLine: PByte;
+begin
+ GetImageFormatInfo(SrcImage.Format, Info);
+ Assert(SrcImage.Format = DstImage.Format);
+ Assert(not Info.IsSpecial);
+ // Use integers instead of floats for source image pixel coords
+ // Xp and Yp coords must be shifted right to get read source image coords
+ ScaleX := (SrcWidth shl 16) div DstWidth;
+ ScaleY := (SrcHeight shl 16) div DstHeight;
+ Yp := 0;
+ for Y := 0 to DstHeight - 1 do
+ begin
+ Xp := 0;
+ SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel];
+ DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel];
+ for X := 0 to DstWidth - 1 do
+ begin
+ case Info.BytesPerPixel of
+ 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16];
+ 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16];
+ 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16];
+ 4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16];
+ 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16];
+ 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16];
+ 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16];
+ end;
+ Inc(DstPixel, Info.BytesPerPixel);
+ Inc(Xp, ScaleX);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+end;
+
+{ Filter function for nearest filtering. Also known as box filter.}
+function FilterNearest(Value: Single): Single;
+begin
+ if (Value > -0.5) and (Value <= 0.5) then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+{ Filter function for linear filtering. Also known as triangle or Bartlett filter.}
+function FilterLinear(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 1.0 - Value
+ else
+ Result := 0.0;
+end;
+
+{ Cosine filter.}
+function FilterCosine(Value: Single): Single;
+begin
+ Result := 0;
+ if Abs(Value) < 1 then
+ Result := (Cos(Value * Pi) + 1) / 2;
+end;
+
+{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
+function FilterHermite(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1 then
+ Result := (2 * Value - 3) * Sqr(Value) + 1
+ else
+ Result := 0;
+end;
+
+{ Quadratic filter. Also known as Bell.}
+function FilterQuadratic(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 0.5 then
+ Result := 0.75 - Sqr(Value)
+ else
+ if Value < 1.5 then
+ begin
+ Value := Value - 1.5;
+ Result := 0.5 * Sqr(Value);
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Gaussian filter.}
+function FilterGaussian(Value: Single): Single;
+begin
+ Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
+end;
+
+{ 4th order (cubic) b-spline filter.}
+function FilterSpline(Value: Single): Single;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ begin
+ Temp := Sqr(Value);
+ Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := 2.0 - Value;
+ Result := Sqr(Value) * Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Lanczos-windowed sinc filter.}
+function FilterLanczos(Value: Single): Single;
+
+ function SinC(Value: Single): Single;
+ begin
+ if Value <> 0.0 then
+ begin
+ Value := Value * Pi;
+ Result := Sin(Value) / Value;
+ end
+ else
+ Result := 1.0;
+ end;
+
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 3.0 then
+ Result := SinC(Value) * SinC(Value / 3.0)
+ else
+ Result := 0.0;
+end;
+
+{ Micthell cubic filter.}
+function FilterMitchell(Value: Single): Single;
+const
+ B = 1.0 / 3.0;
+ C = 1.0 / 3.0;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ Temp := Sqr(Value);
+ if Value < 1.0 then
+ begin
+ Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
+ ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
+ (6.0 - 2.0 * B));
+ Result := Value / 6.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := (((-B - 6.0 * C) * (Value * Temp)) +
+ ((6.0 * B + 30.0 * C) * Temp) +
+ ((-12.0 * B - 48.0 * C) * Value) +
+ (8.0 * B + 24.0 * C));
+ Result := Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ CatmullRom spline filter.}
+function FilterCatmullRom(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
+ else
+ if Value < 2.0 then
+ Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
+ else
+ Result := 0.0;
+end;
+
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
+begin
+ // Calls the other function with filter function and radius defined by Filter
+ StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
+ DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
+ WrapEdges);
+end;
+
+var
+ FullEdge: Boolean = True;
+
+{ The following resampling code is modified and extended code from Graphics32
+ library by Alex A. Denisov.}
+function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
+var
+ I, J, K, N: LongInt;
+ Left, Right, SrcWidth, DstWidth: LongInt;
+ Weight, Scale, Center, Count: Single;
+begin
+ Result := nil;
+ K := 0;
+ SrcWidth := SrcHigh - SrcLow;
+ DstWidth := DstHigh - DstLow;
+
+ // Check some special cases
+ if SrcWidth = 1 then
+ begin
+ SetLength(Result, DstWidth);
+ for I := 0 to DstWidth - 1 do
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := 0;
+ Result[I][0].Weight := 1.0;
+ end;
+ Exit;
+ end
+ else
+ if (SrcWidth = 0) or (DstWidth = 0) then
+ Exit;
+
+ if FullEdge then
+ Scale := DstWidth / SrcWidth
+ else
+ Scale := (DstWidth - 1) / (SrcWidth - 1);
+
+ SetLength(Result, DstWidth);
+
+ // Pre-calculate filter contributions for a row or column
+ if Scale = 0.0 then
+ begin
+ Assert(Length(Result) = 1);
+ SetLength(Result[0], 1);
+ Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
+ Result[0][0].Weight := 1.0;
+ end
+ else if Scale < 1.0 then
+ begin
+ // Sub-sampling - scales from bigger to smaller
+ Radius := Radius / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) / Scale
+ else
+ Center := SrcLow + I / Scale;
+ Left := Floor(Center - Radius);
+ Right := Ceil(Center + Radius);
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter((Center - J) * Scale) * Scale;
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+ Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Length(Result[I]) = 0 then
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := Floor(Center);
+ Result[I][0].Weight := 1.0;
+ end
+ else if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ end;
+ end
+ else // if Scale > 1.0 then
+ begin
+ // Super-sampling - scales from smaller to bigger
+ Scale := 1.0 / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) * Scale
+ else
+ Center := SrcLow + I * Scale;
+ Left := Floor(Center - Radius);
+ Right := Ceil(Center + Radius);
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter(Center - J);
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+
+ if WrapEdges then
+ begin
+ if J < 0 then
+ N := SrcImageWidth + J
+ else if J >= SrcImageWidth then
+ N := J - SrcImageWidth
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+ end
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+
+ Result[I][K].Pos := N;
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ end;
+ end;
+end;
+
+procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
+var
+ I, J: LongInt;
+begin
+ if Length(Map) > 0 then
+ begin
+ MinPos := Map[0][0].Pos;
+ MaxPos := MinPos;
+ for I := 0 to Length(Map) - 1 do
+ for J := 0 to Length(Map[I]) - 1 do
+ begin
+ if MinPos > Map[I][J].Pos then
+ MinPos := Map[I][J].Pos;
+ if MaxPos < Map[I][J].Pos then
+ MaxPos := Map[I][J].Pos;
+ end;
+ end;
+end;
+
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
+const
+ Channel8BitMax: Single = 255.0;
+type
+ TBufferItem = record
+ A, R, G, B: Integer;
+ end;
+var
+ MapX, MapY: TMappingTable;
+ I, J, X, Y: LongInt;
+ XMinimum, XMaximum: LongInt;
+ LineBufferFP: array of TColorFPRec;
+ LineBufferInt: array of TBufferItem;
+ ClusterX, ClusterY: TCluster;
+ Weight, AccumA, AccumR, AccumG, AccumB: Single;
+ IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
+ DstLine: PByte;
+ SrcColor: TColor32Rec;
+ SrcFloat: TColorFPRec;
+ Info: TImageFormatInfo;
+ BytesPerChannel: LongInt;
+ ChannelValueMax, InvChannelValueMax: Single;
+ UseOptimizedVersion: Boolean;
+begin
+ GetImageFormatInfo(SrcImage.Format, Info);
+ Assert(SrcImage.Format = DstImage.Format);
+ Assert(not Info.IsSpecial and not Info.IsIndexed);
+ BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount;
+ UseOptimizedVersion := (BytesPerChannel = 1) and not Info.UsePixelFormat;
+
+ // Create horizontal and vertical mapping tables
+ MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth,
+ SrcImage.Width, Filter, Radius, WrapEdges);
+ MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight,
+ SrcImage.Height, Filter, Radius, WrapEdges);
+
+ if (MapX = nil) or (MapY = nil) then
+ Exit;
+
+ ClusterX := nil;
+ ClusterY := nil;
+
+ try
+ // Find min and max X coords of pixels that will contribute to target image
+ FindExtremes(MapX, XMinimum, XMaximum);
+
+ if not UseOptimizedVersion then
+ begin
+ SetLength(LineBufferFP, XMaximum - XMinimum + 1);
+ // Following code works for the rest of data formats
+ for J := 0 to DstHeight - 1 do
+ begin
+ // First for each pixel in the current line sample vertically
+ // and store results in LineBuffer. Then sample horizontally
+ // using values in LineBuffer.
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ // Clear accumulators
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ // For each pixel in line compute weighted sum of pixels
+ // in source column that will contribute to this pixel
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ // Accumulate this pixel's weighted value
+ Weight := ClusterY[Y].Weight;
+ SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil);
+ AccumB := AccumB + SrcFloat.B * Weight;
+ AccumG := AccumG + SrcFloat.G * Weight;
+ AccumR := AccumR + SrcFloat.R * Weight;
+ AccumA := AccumA + SrcFloat.A * Weight;
+ end;
+ // Store accumulated value for this pixel in buffer
+ with LineBufferFP[X - XMinimum] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+
+ DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel];
+ // Now compute final colors for targte pixels in the current row
+ // by sampling horizontally
+ for I := 0 to DstWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ // Clear accumulator
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ // Compute weighted sum of values (which are already
+ // computed weighted sums of pixels in source columns stored in LineBuffer)
+ // that will contribute to the current target pixel
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := ClusterX[X].Weight;
+ with LineBufferFP[ClusterX[X].Pos - XMinimum] do
+ begin
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
+ end;
+ end;
+
+ // Now compute final color to be written to dest image
+ SrcFloat.A := AccumA;
+ SrcFloat.R := AccumR;
+ SrcFloat.G := AccumG;
+ SrcFloat.B := AccumB;
+
+ Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
+ Inc(DstLine, Info.BytesPerPixel);
+ end;
+ end;
+ end
+ else
+ begin
+ SetLength(LineBufferInt, XMaximum - XMinimum + 1);
+ // Following code is optimized for images with 8 bit channels
+ for J := 0 to DstHeight - 1 do
+ begin
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ IAccumA := 0;
+ IAccumR := 0;
+ IAccumG := 0;
+ IAccumB := 0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ IWeight := Round(256 * ClusterY[Y].Weight);
+ CopyPixel(
+ @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
+ @SrcColor, Info.BytesPerPixel);
+
+ IAccumB := IAccumB + SrcColor.B * IWeight;
+ IAccumG := IAccumG + SrcColor.G * IWeight;
+ IAccumR := IAccumR + SrcColor.R * IWeight;
+ IAccumA := IAccumA + SrcColor.A * IWeight;
+ end;
+ with LineBufferInt[X - XMinimum] do
+ begin
+ A := IAccumA;
+ R := IAccumR;
+ G := IAccumG;
+ B := IAccumB;
+ end;
+ end;
+
+ DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel];
+
+ for I := 0 to DstWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ IAccumA := 0;
+ IAccumR := 0;
+ IAccumG := 0;
+ IAccumB := 0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ IWeight := Round(256 * ClusterX[X].Weight);
+ with LineBufferInt[ClusterX[X].Pos - XMinimum] do
+ begin
+ IAccumB := IAccumB + B * IWeight;
+ IAccumG := IAccumG + G * IWeight;
+ IAccumR := IAccumR + R * IWeight;
+ IAccumA := IAccumA + A * IWeight;
+ end;
+ end;
+
+ SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
+ SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
+ SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
+ SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
+
+ CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
+ Inc(DstLine, Info.BytesPerPixel);
+ end;
+ end;
+ end;
+
+ finally
+ MapX := nil;
+ MapY := nil;
+ end;
+end;
+
+procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
+ var SmallerLevel: TImageData);
+var
+ Filter: TSamplingFilter;
+ Info: TImageFormatInfo;
+ CompatibleCopy: TImageData;
+begin
+ Assert(TestImage(BiggerLevel));
+ Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
+
+ // If we have special format image we must create copy to allow pixel access
+ GetImageFormatInfo(BiggerLevel.Format, Info);
+ if Info.IsSpecial then
+ begin
+ InitImage(CompatibleCopy);
+ CloneImage(BiggerLevel, CompatibleCopy);
+ ConvertImage(CompatibleCopy, ifDefault);
+ end
+ else
+ CompatibleCopy := BiggerLevel;
+
+ // Create new smaller image
+ NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel);
+ GetImageFormatInfo(CompatibleCopy.Format, Info);
+ // If input is indexed we must copy its palette
+ if Info.IsIndexed then
+ CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries);
+
+ if (Filter = sfNearest) or Info.IsIndexed then
+ begin
+ StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
+ SmallerLevel, 0, 0, Width, Height);
+ end
+ else
+ begin
+ StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
+ SmallerLevel, 0, 0, Width, Height, Filter);
+ end;
+
+ // Free copy and convert result to special format if necessary
+ if CompatibleCopy.Format <> BiggerLevel.Format then
+ begin
+ ConvertImage(SmallerLevel, BiggerLevel.Format);
+ FreeImage(CompatibleCopy);
+ end;
+end;
+
+
+{ Various format support functions }
+
+procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt);
+begin
+ case BytesPerPixel of
+ 1: PByte(Dest)^ := PByte(Src)^;
+ 2: PWord(Dest)^ := PWord(Src)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
+ 4: PLongWord(Dest)^ := PLongWord(Src)^;
+ 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
+ 8: PInt64(Dest)^ := PInt64(Src)^;
+ 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
+ end;
+end;
+
+function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean;
+begin
+ case BytesPerPixel of
+ 1: Result := PByte(PixelA)^ = PByte(PixelB)^;
+ 2: Result := PWord(PixelA)^ = PWord(PixelB)^;
+ 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and
+ (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
+ 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
+ 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and
+ (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
+ 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
+ 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and
+ (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1);
+ else
+ Result := False;
+ end;
+end;
+
+procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
+ DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
+var
+ SrcInfo, DstInfo: PImageFormatInfo;
+ PixFP: TColorFPRec;
+begin
+ SrcInfo := FInfos[SrcFormat];
+ DstInfo := FInfos[DstFormat];
+
+ PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette);
+ SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP);
+end;
+
+procedure ClampFloatPixel(var PixF: TColorFPRec);
+begin
+ if PixF.A > 1.0 then
+ PixF.A := 1.0;
+ if PixF.R > 1.0 then
+ PixF.R := 1.0;
+ if PixF.G > 1.0 then
+ PixF.G := 1.0;
+ if PixF.B > 1.0 then
+ PixF.B := 1.0;
+
+ if PixF.A < 0.0 then
+ PixF.A := 0.0;
+ if PixF.R < 0.0 then
+ PixF.R := 0.0;
+ if PixF.G < 0.0 then
+ PixF.G := 0.0;
+ if PixF.B < 0.0 then
+ PixF.B := 0.0;
+end;
+
+procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+var
+ I, W: LongInt;
+begin
+ W := Width * Bpp;
+ for I := 0 to Height - 1 do
+ Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W);
+end;
+
+procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+var
+ I, W: LongInt;
+begin
+ W := Width * Bpp;
+ for I := 0 to Height - 1 do
+ Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
+end;
+
+procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+ Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[Y * WidthBytes + X shr 3] and
+ Mask1[X and 7]) shr Shift1[X and 7];
+end;
+
+procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
+ Shift2: array[0..3] of Byte = (6, 4, 2, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[X shr 2] and Mask2[X and 3]) shr
+ Shift2[X and 3];
+end;
+
+procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask4: array[0..1] of Byte = ($F0, $0F);
+ Shift4: array[0..1] of Byte = (4, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[Y * WidthBytes + X shr 1] and
+ Mask4[X and 1]) shr Shift4[X and 1];
+end;
+
+function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ for I := 0 to NumPixels - 1 do
+ begin
+ if Data^ >= 1 shl 15 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Inc(Data);
+ end;
+end;
+
+function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ for I := 0 to NumPixels - 1 do
+ begin
+ if Data^ >= 1 shl 24 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Inc(Data);
+ end;
+end;
+
+function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
+ LineWidth, Index: LongInt): Pointer;
+var
+ LineBytes: LongInt;
+begin
+ Assert(not FormatInfo.IsSpecial);
+ LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1);
+ Result := @PByteArray(ImageBits)[Index * LineBytes];
+end;
+
+function IsImageFormatValid(Format: TImageFormat): Boolean;
+begin
+ Result := FInfos[Format] <> nil;
+end;
+
+const
+ HalfMin: Single = 5.96046448e-08; // Smallest positive half
+ HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half
+ HalfMax: Single = 65504.0; // Largest positive half
+ HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0)
+ HalfNaN: THalfFloat = 65535;
+ HalfPosInf: THalfFloat = 31744;
+ HalfNegInf: THalfFloat = 64512;
+
+
+{
+
+ Half/Float conversions inspired by half class from OpenEXR library.
+
+
+ Float (Pascal Single type) is an IEEE 754 single-precision
+
+ floating point number.
+
+ Bit layout of Single:
+
+ 31 (msb)
+ |
+ | 30 23
+ | | |
+ | | | 22 0 (lsb)
+ | | | | |
+ X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
+ s e m
+
+ Bit layout of half:
+
+ 15 (msb)
+ |
+ | 14 10
+ | | |
+ | | | 9 0 (lsb)
+ | | | | |
+ X XXXXX XXXXXXXXXX
+ s e m
+
+ S is the sign-bit, e is the exponent and m is the significand (mantissa).
+}
+
+
+function HalfToFloat(Half: THalfFloat): Single;
+var
+ Dst, Sign, Mantissa: LongWord;
+ Exp: LongInt;
+begin
+ // extract sign, exponent, and mantissa from half number
+ Sign := Half shr 15;
+ Exp := (Half and $7C00) shr 10;
+ Mantissa := Half and 1023;
+
+ if (Exp > 0) and (Exp < 31) then
+ begin
+ // common normalized number
+ Exp := Exp + (127 - 15);
+ Mantissa := Mantissa shl 13;
+ Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
+ // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
+ end
+ else if (Exp = 0) and (Mantissa = 0) then
+ begin
+ // zero - preserve sign
+ Dst := Sign shl 31;
+ end
+ else if (Exp = 0) and (Mantissa <> 0) then
+ begin
+ // denormalized number - renormalize it
+ while (Mantissa and $00000400) = 0 do
+ begin
+ Mantissa := Mantissa shl 1;
+ Dec(Exp);
+ end;
+ Inc(Exp);
+ Mantissa := Mantissa and not $00000400;
+ // now assemble normalized number
+ Exp := Exp + (127 - 15);
+ Mantissa := Mantissa shl 13;
+ Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
+ // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
+ end
+ else if (Exp = 31) and (Mantissa = 0) then
+ begin
+ // +/- infinity
+ Dst := (Sign shl 31) or $7F800000;
+ end
+ else //if (Exp = 31) and (Mantisa <> 0) then
+ begin
+ // not a number - preserve sign and mantissa
+ Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
+ end;
+
+ // reinterpret LongWord as Single
+ Result := PSingle(@Dst)^;
+end;
+
+function FloatToHalf(Float: Single): THalfFloat;
+var
+ Src: LongWord;
+ Sign, Exp, Mantissa: LongInt;
+begin
+ Src := PLongWord(@Float)^;
+ // extract sign, exponent, and mantissa from Single number
+ Sign := Src shr 31;
+ Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15;
+ Mantissa := Src and $007FFFFF;
+
+ if (Exp > 0) and (Exp < 30) then
+ begin
+ // simple case - round the significand and combine it with the sign and exponent
+ Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13);
+ end
+ else if Src = 0 then
+ begin
+ // input float is zero - return zero
+ Result := 0;
+ end
+ else
+ begin
+ // difficult case - lengthy conversion
+ if Exp <= 0 then
+ begin
+ if Exp < -10 then
+ begin
+ // input float's value is less than HalfMin, return zero
+ Result := 0;
+ end
+ else
+ begin
+ // Float is a normalized Single whose magnitude is less than HalfNormMin.
+ // We convert it to denormalized half.
+ Mantissa := (Mantissa or $00800000) shr (1 - Exp);
+ // round to nearest
+ if (Mantissa and $00001000) > 0 then
+ Mantissa := Mantissa + $00002000;
+ // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
+ Result := (Sign shl 15) or (Mantissa shr 13);
+ end;
+ end
+ else if Exp = 255 - 127 + 15 then
+ begin
+ if Mantissa = 0 then
+ begin
+ // input float is infinity, create infinity half with original sign
+ Result := (Sign shl 15) or $7C00;
+ end
+ else
+ begin
+ // input float is NaN, create half NaN with original sign and mantissa
+ Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
+ end;
+ end
+ else
+ begin
+ // Exp is > 0 so input float is normalized Single
+
+ // round to nearest
+ if (Mantissa and $00001000) > 0 then
+ begin
+ Mantissa := Mantissa + $00002000;
+ if (Mantissa and $00800000) > 0 then
+ begin
+ Mantissa := 0;
+ Exp := Exp + 1;
+ end;
+ end;
+
+ if Exp > 30 then
+ begin
+ // exponent overflow - return infinity half
+ Result := (Sign shl 15) or $7C00;
+ end
+ else
+ // assemble normalized half
+ Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
+ end;
+ end;
+end;
+
+function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec;
+begin
+ Result.A := HalfToFloat(ColorHF.A);
+ Result.R := HalfToFloat(ColorHF.R);
+ Result.G := HalfToFloat(ColorHF.G);
+ Result.B := HalfToFloat(ColorHF.B);
+end;
+
+function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec;
+begin
+ Result.A := FloatToHalf(ColorFP.A);
+ Result.R := FloatToHalf(ColorFP.R);
+ Result.G := FloatToHalf(ColorFP.G);
+ Result.B := FloatToHalf(ColorFP.B);
+end;
+
+procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
+var
+ I: Integer;
+ Pix: PColor32;
+begin
+ InitImage(PalImage);
+ NewImage(Entries, 1, ifA8R8G8B8, PalImage);
+ Pix := PalImage.Bits;
+ for I := 0 to Entries - 1 do
+ begin
+ Pix^ := Pal[I].Color;
+ Inc(Pix);
+ end;
+end;
+
+
+{ Pixel readers/writers for different image formats }
+
+procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColor64Rec);
+var
+ A, R, G, B: Byte;
+begin
+ FillChar(Pix, SizeOf(Pix), 0);
+ A := 0;
+ R := 0;
+ G := 0;
+ B := 0;
+ // returns 64 bit color value with 16 bits for each channel
+ case SrcInfo.BytesPerPixel of
+ 1:
+ begin
+ PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B);
+ Pix.A := A shl 8;
+ Pix.R := R shl 8;
+ Pix.G := G shl 8;
+ Pix.B := B shl 8;
+ end;
+ 2:
+ begin
+ PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B);
+ Pix.A := A shl 8;
+ Pix.R := R shl 8;
+ Pix.G := G shl 8;
+ Pix.B := B shl 8;
+ end;
+ 3:
+ with Pix do
+ begin
+ R := MulDiv(PColor24Rec(Src).R, 65535, 255);
+ G := MulDiv(PColor24Rec(Src).G, 65535, 255);
+ B := MulDiv(PColor24Rec(Src).B, 65535, 255);
+ end;
+ 4:
+ with Pix do
+ begin
+ A := MulDiv(PColor32Rec(Src).A, 65535, 255);
+ R := MulDiv(PColor32Rec(Src).R, 65535, 255);
+ G := MulDiv(PColor32Rec(Src).G, 65535, 255);
+ B := MulDiv(PColor32Rec(Src).B, 65535, 255);
+ end;
+ 6:
+ with Pix do
+ begin
+ R := PColor48Rec(Src).R;
+ G := PColor48Rec(Src).G;
+ B := PColor48Rec(Src).B;
+ end;
+ 8: Pix.Color := PColor64(Src)^;
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each ChannelToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Pix.A := 65535;
+
+ if SrcInfo.IsRBSwapped then
+ SwapValues(Pix.R, Pix.B);
+end;
+
+procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColor64Rec);
+var
+ PixW: TColor64Rec;
+begin
+ PixW := Pix;
+ if DstInfo.IsRBSwapped then
+ SwapValues(PixW.R, PixW.B);
+ // Pix contains 64 bit color value with 16 bit for each channel
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
+ PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
+ 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
+ PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
+ 3:
+ with PColor24Rec(Dst)^ do
+ begin
+ R := MulDiv(PixW.R, 255, 65535);
+ G := MulDiv(PixW.G, 255, 65535);
+ B := MulDiv(PixW.B, 255, 65535);
+ end;
+ 4:
+ with PColor32Rec(Dst)^ do
+ begin
+ A := MulDiv(PixW.A, 255, 65535);
+ R := MulDiv(PixW.R, 255, 65535);
+ G := MulDiv(PixW.G, 255, 65535);
+ B := MulDiv(PixW.B, 255, 65535);
+ end;
+ 6:
+ with PColor48Rec(Dst)^ do
+ begin
+ R := PixW.R;
+ G := PixW.G;
+ B := PixW.B;
+ end;
+ 8: PColor64(Dst)^ := PixW.Color;
+ end;
+end;
+
+procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Gray: TColor64Rec; var Alpha: Word);
+begin
+ FillChar(Gray, SizeOf(Gray), 0);
+ // Source alpha is scaled to 16 bits and stored in Alpha,
+ // grayscale value is scaled to 64 bits and stored in Gray
+ case SrcInfo.BytesPerPixel of
+ 1: Gray.A := MulDiv(Src^, 65535, 255);
+ 2:
+ if SrcInfo.HasAlphaChannel then
+ with PWordRec(Src)^ do
+ begin
+ Alpha := MulDiv(High, 65535, 255);
+ Gray.A := MulDiv(Low, 65535, 255);
+ end
+ else
+ Gray.A := PWord(Src)^;
+ 4:
+ if SrcInfo.HasAlphaChannel then
+ with PLongWordRec(Src)^ do
+ begin
+ Alpha := High;
+ Gray.A := Low;
+ end
+ else
+ with PLongWordRec(Src)^ do
+ begin
+ Gray.A := High;
+ Gray.R := Low;
+ end;
+ 8: Gray.Color := PColor64(Src)^;
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each GrayToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Alpha := 65535;
+end;
+
+procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Gray: TColor64Rec; Alpha: Word);
+begin
+ // Gray contains grayscale value scaled to 64 bits, Alpha contains
+ // alpha value scaled to 16 bits
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := MulDiv(Gray.A, 255, 65535);
+ 2:
+ if DstInfo.HasAlphaChannel then
+ with PWordRec(Dst)^ do
+ begin
+ High := MulDiv(Alpha, 255, 65535);
+ Low := MulDiv(Gray.A, 255, 65535);
+ end
+ else
+ PWord(Dst)^ := Gray.A;
+ 4:
+ if DstInfo.HasAlphaChannel then
+ with PLongWordRec(Dst)^ do
+ begin
+ High := Alpha;
+ Low := Gray.A;
+ end
+ else
+ with PLongWordRec(Dst)^ do
+ begin
+ High := Gray.A;
+ Low := Gray.R;
+ end;
+ 8: PColor64(Dst)^ := Gray.Color;
+ end;
+end;
+
+procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColorFPRec);
+var
+ PixHF: TColorHFRec;
+begin
+ if SrcInfo.BytesPerPixel in [4, 16] then
+ begin
+ // IEEE 754 single-precision channels
+ FillChar(Pix, SizeOf(Pix), 0);
+ case SrcInfo.BytesPerPixel of
+ 4: Pix.R := PSingle(Src)^;
+ 16: Pix := PColorFPRec(Src)^;
+ end;
+ end
+ else
+ begin
+ // half float channels
+ FillChar(PixHF, SizeOf(PixHF), 0);
+ case SrcInfo.BytesPerPixel of
+ 2: PixHF.R := PHalfFloat(Src)^;
+ 8: PixHF := PColorHFRec(Src)^;
+ end;
+ Pix := ColorHalfToFloat(PixHF);
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each FloatToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Pix.A := 1.0;
+ if SrcInfo.IsRBSwapped then
+ SwapValues(Pix.R, Pix.B);
+end;
+
+procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColorFPRec);
+var
+ PixW: TColorFPRec;
+ PixHF: TColorHFRec;
+begin
+ PixW := Pix;
+ if DstInfo.IsRBSwapped then
+ SwapValues(PixW.R, PixW.B);
+ if DstInfo.BytesPerPixel in [4, 16] then
+ begin
+ case DstInfo.BytesPerPixel of
+ 4: PSingle(Dst)^ := PixW.R;
+ 16: PColorFPRec(Dst)^ := PixW;
+ end;
+ end
+ else
+ begin
+ PixHF := ColorFloatToHalf(PixW);
+ case DstInfo.BytesPerPixel of
+ 2: PHalfFloat(Dst)^ := PixHF.R;
+ 8: PColorHFRec(Dst)^ := PixHF;
+ end;
+ end;
+end;
+
+procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Index: LongWord);
+begin
+ case SrcInfo.BytesPerPixel of
+ 1: Index := Src^;
+ end;
+end;
+
+procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ Index: LongWord);
+begin
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := Byte(Index);
+ 2: PWord(Dst)^ := Word(Index);
+ 4: PLongWord(Dst)^ := Index;
+ end;
+end;
+
+
+{ Pixel readers/writers for 32bit and FP colors}
+
+function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+var
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.Format = ifA8R8G8B8 then
+ begin
+ Result := PColor32Rec(Bits)^
+ end
+ else if Info.Format = ifR8G8B8 then
+ begin
+ PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
+ Result.A := $FF;
+ end
+ else if Info.IsFloatingPoint then
+ begin
+ FloatGetSrcPixel(Bits, Info, PixF);
+ Result.A := ClampToByte(Round(PixF.A * 255.0));
+ Result.R := ClampToByte(Round(PixF.R * 255.0));
+ Result.G := ClampToByte(Round(PixF.G * 255.0));
+ Result.B := ClampToByte(Round(PixF.B * 255.0));
+ end
+ else if Info.HasGrayChannel then
+ begin
+ GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
+ Result.A := MulDiv(Alpha, 255, 65535);
+ Result.R := MulDiv(Pix64.A, 255, 65535);
+ Result.G := MulDiv(Pix64.A, 255, 65535);
+ Result.B := MulDiv(Pix64.A, 255, 65535);
+ end
+ else if Info.IsIndexed then
+ begin
+ IndexGetSrcPixel(Bits, Info, Index);
+ Result := Palette[Index];
+ end
+ else
+ begin
+ ChannelGetSrcPixel(Bits, Info, Pix64);
+ Result.A := MulDiv(Pix64.A, 255, 65535);
+ Result.R := MulDiv(Pix64.R, 255, 65535);
+ Result.G := MulDiv(Pix64.G, 255, 65535);
+ Result.B := MulDiv(Pix64.B, 255, 65535);
+ end;
+end;
+
+procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+var
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.Format = ifA8R8G8B8 then
+ begin
+ PColor32Rec(Bits)^ := Color
+ end
+ else if Info.Format = ifR8G8B8 then
+ begin
+ PColor24Rec(Bits)^ := Color.Color24Rec;
+ end
+ else if Info.IsFloatingPoint then
+ begin
+ PixF.A := Color.A * OneDiv8Bit;
+ PixF.R := Color.R * OneDiv8Bit;
+ PixF.G := Color.G * OneDiv8Bit;
+ PixF.B := Color.B * OneDiv8Bit;
+ FloatSetDstPixel(Bits, Info, PixF);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ Alpha := MulDiv(Color.A, 65535, 255);
+ Pix64.Color := 0;
+ Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B), 65535, 255);
+ GraySetDstPixel(Bits, Info, Pix64, Alpha);
+ end
+ else if Info.IsIndexed then
+ begin
+ Index := FindColor(Palette, Info.PaletteEntries, Color.Color);
+ IndexSetDstPixel(Bits, Info, Index);
+ end
+ else
+ begin
+ Pix64.A := MulDiv(Color.A, 65535, 255);
+ Pix64.R := MulDiv(Color.R, 65535, 255);
+ Pix64.G := MulDiv(Color.G, 65535, 255);
+ Pix64.B := MulDiv(Color.B, 65535, 255);
+ ChannelSetDstPixel(Bits, Info, Pix64);
+ end;
+end;
+
+function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+var
+ Pix32: TColor32Rec;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.IsFloatingPoint then
+ begin
+ FloatGetSrcPixel(Bits, Info, Result);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
+ Result.A := Alpha * OneDiv16Bit;
+ Result.R := Pix64.A * OneDiv16Bit;
+ Result.G := Pix64.A * OneDiv16Bit;
+ Result.B := Pix64.A * OneDiv16Bit;
+ end
+ else if Info.IsIndexed then
+ begin
+ IndexGetSrcPixel(Bits, Info, Index);
+ Pix32 := Palette[Index];
+ Result.A := Pix32.A * OneDiv8Bit;
+ Result.R := Pix32.R * OneDiv8Bit;
+ Result.G := Pix32.G * OneDiv8Bit;
+ Result.B := Pix32.B * OneDiv8Bit;
+ end
+ else
+ begin
+ ChannelGetSrcPixel(Bits, Info, Pix64);
+ Result.A := Pix64.A * OneDiv16Bit;
+ Result.R := Pix64.R * OneDiv16Bit;
+ Result.G := Pix64.G * OneDiv16Bit;
+ Result.B := Pix64.B * OneDiv16Bit;
+ end;
+end;
+
+procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+var
+ Pix32: TColor32Rec;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.IsFloatingPoint then
+ begin
+ FloatSetDstPixel(Bits, Info, Color);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ Alpha := ClampToWord(Round(Color.A * 65535.0));
+ Pix64.Color := 0;
+ Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B) * 65535.0));
+ GraySetDstPixel(Bits, Info, Pix64, Alpha);
+ end
+ else if Info.IsIndexed then
+ begin
+ Pix32.A := ClampToByte(Round(Color.A * 255.0));
+ Pix32.R := ClampToByte(Round(Color.R * 255.0));
+ Pix32.G := ClampToByte(Round(Color.G * 255.0));
+ Pix32.B := ClampToByte(Round(Color.B * 255.0));
+ Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color);
+ IndexSetDstPixel(Bits, Info, Index);
+ end
+ else
+ begin
+ Pix64.A := ClampToWord(Round(Color.A * 65535.0));
+ Pix64.R := ClampToWord(Round(Color.R * 65535.0));
+ Pix64.G := ClampToWord(Round(Color.G * 65535.0));
+ Pix64.B := ClampToWord(Round(Color.B * 65535.0));
+ ChannelSetDstPixel(Bits, Info, Pix64);
+ end;
+end;
+
+
+{ Image format conversion functions }
+
+procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+begin
+ // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
+ // images) are made separately from general ARGB conversion to
+ // make them faster
+ if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst)^ := PColor24Rec(Src)^;
+ if DstInfo.HasAlphaChannel then
+ PColor32Rec(Dst).A := 255;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst)^ := PColor24Rec(Src)^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general ARGB conversion
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G +
+ GrayConv.B * PColor24Rec(Src).B);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+
+ // alpha is saved from source pixel to Alpha,
+ // Gray value is computed and set to highest word of Pix64 so
+ // Pix64.Color contains grayscale value scaled to 64 bits
+ Alpha := Pix64.A;
+ with GrayConv do
+ Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B);
+
+ GraySetDstPixel(Dst, DstInfo, Pix64, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+
+ // floating point channel values are scaled to 1.0
+ PixF.A := Pix64.A * OneDiv16Bit;
+ PixF.R := Pix64.R * OneDiv16Bit;
+ PixF.G := Pix64.G * OneDiv16Bit;
+ PixF.B := Pix64.B * OneDiv16Bit;
+
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+begin
+ ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
+ GetOption(ImagingColorReductionMask), DstPal);
+end;
+
+procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
+ end
+ else
+ if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8;
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general grayscale conversion
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
+ // are made separately from general conversions to make them faster
+ if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst).R := Src^;
+ PColor24Rec(Dst).G := Src^;
+ PColor24Rec(Dst).B := Src^;
+ if DstInfo.HasAlphaChannel then
+ PColor32Rec(Dst).A := $FF;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha);
+
+ // most significant word of grayscale value is used for
+ // each channel and alpha channel is set to Alpha
+ Pix64.R := Pix64.A;
+ Pix64.G := Pix64.A;
+ Pix64.B := Pix64.A;
+ Pix64.A := Alpha;
+
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ // most significant word of grayscale value is used for
+ // each channel and alpha channel is set to Alpha
+ // then all is scaled to 0..1
+ PixF.R := Gray.A * OneDiv16Bit;
+ PixF.G := Gray.A * OneDiv16Bit;
+ PixF.B := Gray.A * OneDiv16Bit;
+ PixF.A := Alpha * OneDiv16Bit;
+
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+var
+ I: LongInt;
+ Idx: LongWord;
+ Gray: TColor64Rec;
+ Alpha, Shift: Word;
+begin
+ FillGrayscalePalette(DstPal, DstInfo.PaletteEntries);
+ Shift := Log2Int(DstInfo.PaletteEntries);
+ // most common conversion (Gray8->Index8)
+ // is made separately from general conversions to make it faster
+ if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Src^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // gray value is read from src and index to precomputed
+ // grayscale palette is computed and written to dst
+ // (we assume here that there will be no more than 65536 palette
+ // entries in dst format, gray value is shifted so the highest
+ // gray value match the highest possible index in palette)
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ Idx := Gray.A shr (16 - Shift);
+ IndexSetDstPixel(Dst, DstInfo, Idx);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general floating point conversion
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ ClampFloatPixel(PixF);
+
+ // floating point channel values are scaled to 1.0
+ Pix64.A := ClampToWord(Round(PixF.A * 65535));
+ Pix64.R := ClampToWord(Round(PixF.R * 65535));
+ Pix64.G := ClampToWord(Round(PixF.G * 65535));
+ Pix64.B := ClampToWord(Round(PixF.B * 65535));
+
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ PixF: TColorFPRec;
+ Gray: TColor64Rec;
+ Alpha: Word;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ ClampFloatPixel(PixF);
+
+ // alpha is saved from source pixel to Alpha,
+ // Gray value is computed and set to highest word of Pix64 so
+ // Pix64.Color contains grayscale value scaled to 64 bits
+ Alpha := ClampToWord(Round(PixF.A * 65535.0));
+ Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G +
+ GrayConv.B * PixF.B) * 65535.0));
+
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+begin
+ ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
+ GetOption(ImagingColorReductionMask), DstPal);
+end;
+
+procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
+var
+ I: LongInt;
+begin
+ // there is only one indexed format now, so it is just a copy
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Src^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+ for I := 0 to SrcInfo.PaletteEntries - 1 do
+ DstPal[I] := SrcPal[I];
+end;
+
+procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Idx: LongWord;
+begin
+ // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ with PColor24Rec(Dst)^ do
+ begin
+ R := SrcPal[Src^].R;
+ G := SrcPal[Src^].G;
+ B := SrcPal[Src^].B;
+ end;
+ if DstInfo.Format = ifA8R8G8B8 then
+ PColor32Rec(Dst).A := SrcPal[Src^].A;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // scaled to 16bits and written to dest
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ with Pix64 do
+ begin
+ A := SrcPal[Idx].A shl 8;
+ R := SrcPal[Idx].R shl 8;
+ G := SrcPal[Idx].G shl 8;
+ B := SrcPal[Idx].B shl 8;
+ end;
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ Alpha: Word;
+ Idx: LongWord;
+begin
+ // most common conversion (Index8->Gray8)
+ // is made separately from general conversions to make it faster
+ if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G +
+ GrayConv.B * SrcPal[Src^].B);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // transformed to grayscale and assigned to the highest
+ // byte of Gray value
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ Alpha := SrcPal[Idx].A shl 8;
+ Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G +
+ GrayConv.B * SrcPal[Idx].B), 65535, 255);
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Idx: LongWord;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // scaled to 0..1 and written to dest
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ with PixF do
+ begin
+ A := SrcPal[Idx].A * OneDiv8Bit;
+ R := SrcPal[Idx].R * OneDiv8Bit;
+ G := SrcPal[Idx].G * OneDiv8Bit;
+ B := SrcPal[Idx].B * OneDiv8Bit;
+ end;
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+
+{ Special formats conversion functions }
+
+type
+ // DXT RGB color block
+ TDXTColorBlock = packed record
+ Color0, Color1: Word;
+ Mask: LongWord;
+ end;
+ PDXTColorBlock = ^TDXTColorBlock;
+
+ // DXT explicit alpha for a block
+ TDXTAlphaBlockExp = packed record
+ Alphas: array[0..3] of Word;
+ end;
+ PDXTAlphaBlockExp = ^TDXTAlphaBlockExp;
+
+ // DXT interpolated alpha for a block
+ TDXTAlphaBlockInt = packed record
+ Alphas: array[0..7] of Byte;
+ end;
+ PDXTAlphaBlockInt = ^TDXTAlphaBlockInt;
+
+ TPixelInfo = record
+ Color: Word;
+ Alpha: Byte;
+ Orig: TColor32Rec;
+ end;
+
+ TPixelBlock = array[0..15] of TPixelInfo;
+
+function DecodeCol(Color: Word): TColor32Rec;
+{$IFDEF USE_INLINE} inline; {$ENDIF}
+begin
+ Result.A := $FF;
+{ Result.R := ((Color and $F800) shr 11) shl 3;
+ Result.G := ((Color and $07E0) shr 5) shl 2;
+ Result.B := (Color and $001F) shl 3;}
+ // this color expansion is slower but gives better results
+ Result.R := (Color shr 11) * 255 div 31;
+ Result.G := ((Color shr 5) and $3F) * 255 div 63;
+ Result.B := (Color and $1F) * 255 div 31;
+end;
+
+procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ Colors: array[0..3] of TColor32Rec;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ if Block.Color0 > Block.Color1 then
+ begin
+ // interpolation for block without alpha
+ Colors[2].A := $FF;
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].A := $FF;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end
+ else
+ begin
+ // interpolation for block with alpha
+ Colors[2].A := $FF;
+ Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
+ Colors[3].A := 0;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end;
+
+ // we distribute the dxt block colors across the 4x4 block of the
+ // destination image accroding to the dxt block mask
+ K := 0;
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
+ Colors[Sel];
+ Inc(K);
+ end;
+ end;
+end;
+
+procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockExp;
+ Colors: array[0..3] of TColor32Rec;
+ AWord: Word;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ AlphaBlock := PDXTAlphaBlockExp(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+
+ // we distribute the dxt block colors and alphas
+ // across the 4x4 block of the destination image
+ // accroding to the dxt block mask and alpha block
+ K := 0;
+ for J := 0 to 3 do
+ begin
+ AWord := AlphaBlock.Alphas[J];
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then
+ begin
+ Colors[Sel].A := AWord and $0F;
+ Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4);
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
+ Colors[Sel];
+ end;
+ Inc(K);
+ AWord := AWord shr 4;
+ end;
+ end;
+ end;
+end;
+
+procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt);
+begin
+ with AlphaBlock do
+ if Alphas[0] > Alphas[1] then
+ begin
+ // Interpolation of six alphas
+ Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
+ Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
+ Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
+ Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
+ Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
+ Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
+ end
+ else
+ begin
+ // Interpolation of four alphas, two alphas are set directly
+ Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5;
+ Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5;
+ Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5;
+ Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5;
+ Alphas[6] := 0;
+ Alphas[7] := $FF;
+ end;
+end;
+
+procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Colors: array[0..3] of TColor32Rec;
+ AMask: array[0..1] of LongWord;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ // 6 bit alpha mask is copied into two long words for
+ // easier usage
+ AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
+ AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
+ // alpha interpolation between two endpoint alphas
+ GetInterpolatedAlphas(AlphaBlock);
+
+ // we distribute the dxt block colors and alphas
+ // across the 4x4 block of the destination image
+ // accroding to the dxt block mask and alpha block mask
+ K := 0;
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
+ begin
+ Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7];
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
+ Colors[Sel];
+ end;
+ Inc(K);
+ AMask[J shr 1] := AMask[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
+ Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ Src: PColor32Rec;
+begin
+ I := 0;
+ // 4x4 pixel block is filled with information about every
+ // pixel in the block: alpha, original color, 565 color
+ for Y := 0 to 3 do
+ for X := 0 to 3 do
+ begin
+ Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X];
+ Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or
+ (Src.B shr 3);
+ Block[I].Alpha := Src.A;
+ Block[I].Orig := Src^;
+ Inc(I);
+ end;
+end;
+
+function ColorDistance(const C1, C2: TColor32Rec): LongInt;
+{$IFDEF USE_INLINE} inline;{$ENDIF}
+begin
+ Result := (C1.R - C2.R) * (C1.R - C2.R) +
+ (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B);
+end;
+
+procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word);
+var
+ I, J, Farthest, Dist: LongInt;
+ Colors: array[0..15] of TColor32Rec;
+begin
+ // we choose two colors from the pixel block which has the
+ // largest distance between them
+ for I := 0 to 15 do
+ Colors[I] := Block[I].Orig;
+ Farthest := -1;
+ for I := 0 to 15 do
+ for J := I + 1 to 15 do
+ begin
+ Dist := ColorDistance(Colors[I], Colors[J]);
+ if Dist > Farthest then
+ begin
+ Farthest := Dist;
+ Ep0 := Block[I].Color;
+ Ep1 := Block[J].Color;
+ end;
+ end;
+end;
+
+procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte);
+var
+ I: LongInt;
+begin
+ Min := 255;
+ Max := 0;
+ // we choose the lowest and the highest alpha values
+ for I := 0 to 15 do
+ begin
+ if Block[I].Alpha < Min then
+ Min := Block[I].Alpha;
+ if Block[I].Alpha > Max then
+ Max := Block[I].Alpha;
+ end;
+end;
+
+procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean);
+var
+ Temp: Word;
+begin
+ // if dxt block has alpha information, Ep0 must be smaller
+ // than Ep1, if the block has no alpha Ep1 must be smaller
+ if HasAlpha then
+ begin
+ if Ep0 > Ep1 then
+ begin
+ Temp := Ep0;
+ Ep0 := Ep1;
+ Ep1 := Temp;
+ end;
+ end
+ else
+ if Ep0 < Ep1 then
+ begin
+ Temp := Ep0;
+ Ep0 := Ep1;
+ Ep1 := Temp;
+ end;
+end;
+
+function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt;
+ const Block: TPixelBlock): LongWord;
+var
+ I, J, Closest, Dist: LongInt;
+ Colors: array[0..3] of TColor32Rec;
+ Mask: array[0..15] of Byte;
+begin
+ FillChar(Mask, sizeof(Mask), 0);
+ // we decode endpoint colors
+ Colors[0] := DecodeCol(Ep0);
+ Colors[1] := DecodeCol(Ep1);
+ // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
+ if NumCols = 3 then
+ begin
+ Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
+ Colors[3].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[3].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[3].B := (Colors[0].B + Colors[1].B) shr 1;
+ end
+ else
+ begin
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end;
+
+ for I := 0 to 15 do
+ begin
+ // this is only for DXT1 with alpha
+ if (Block[I].Alpha < 128) and (NumCols = 3) then
+ begin
+ Mask[I] := 3;
+ Continue;
+ end;
+ // for each of the 16 input pixels the nearest color in the
+ // 4 dxt colors is found
+ Closest := MaxInt;
+ for J := 0 to NumCols - 1 do
+ begin
+ Dist := ColorDistance(Block[I].Orig, Colors[J]);
+ if Dist < Closest then
+ begin
+ Closest := Dist;
+ Mask[I] := J;
+ end;
+ end;
+ end;
+
+ Result := 0;
+ for I := 0 to 15 do
+ Result := Result or (Mask[I] shl (I shl 1));
+end;
+
+procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray);
+var
+ Alphas: array[0..7] of Byte;
+ M: array[0..15] of Byte;
+ I, J, Closest, Dist: LongInt;
+begin
+ FillChar(M, sizeof(M), 0);
+ Alphas[0] := Ep0;
+ Alphas[1] := Ep1;
+ // interpolation between two given alpha endpoints
+ // (I use 6 interpolated values mode)
+ Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
+ Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
+ Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
+ Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
+ Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
+ Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
+
+ // the closest interpolated values for each of the input alpha
+ // is found
+ for I := 0 to 15 do
+ begin
+ Closest := MaxInt;
+ for J := 0 to 7 do
+ begin
+ Dist := Abs(Alphas[J] - Block[I].Alpha);
+ if Dist < Closest then
+ begin
+ Closest := Dist;
+ M[I] := J;
+ end;
+ end;
+ end;
+
+ Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6);
+ Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or
+ ((M[5] and 1) shl 7);
+ Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5);
+ Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6);
+ Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or
+ ((M[13] and 1) shl 7);
+ Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5);
+end;
+
+
+procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ HasAlpha: Boolean;
+ Block: TDXTColorBlock;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ HasAlpha := False;
+ for I := 0 to 15 do
+ if Pixels[I].Alpha < 128 then
+ begin
+ HasAlpha := True;
+ Break;
+ end;
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, HasAlpha);
+ if HasAlpha then
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels)
+ else
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockExp;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ for I := 0 to 7 do
+ PByteArray(@AlphaBlock.Alphas)[I] :=
+ (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, False);
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ PDXTAlphaBlockExp(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, False);
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+type
+ TBTCBlock = packed record
+ MLower, MUpper: Byte;
+ BitField: Word;
+ end;
+ PBTCBlock = ^TBTCBlock;
+
+procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ Block: TBTCBlock;
+ M, MLower, MUpper, K: Integer;
+ Pixels: array[0..15] of Byte;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ M := 0;
+ MLower := 0;
+ MUpper := 0;
+ FillChar(Block, SizeOf(Block), 0);
+ K := 0;
+
+ // Store 4x4 pixels and compute average, lower, and upper intensity levels
+ for I := 0 to 3 do
+ for J := 0 to 3 do
+ begin
+ Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J];
+ Inc(M, Pixels[K]);
+ Inc(K);
+ end;
+
+ M := M div 16;
+ K := 0;
+
+ // Now compute upper and lower levels, number of upper pixels,
+ // and update bit field (1 when pixel is above avg. level M)
+ for I := 0 to 15 do
+ begin
+ if Pixels[I] > M then
+ begin
+ Inc(MUpper, Pixels[I]);
+ Inc(K);
+ Block.BitField := Block.BitField or (1 shl I);
+ end
+ else
+ Inc(MLower, Pixels[I]);
+ end;
+
+ // Scale levels and save them to block
+ if K > 0 then
+ Block.MUpper := ClampToByte(MUpper div K)
+ else
+ Block.MUpper := 0;
+ Block.MLower := ClampToByte(MLower div (16 - K));
+
+ // Finally save block to dest data
+ PBTCBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
+ Width, Height, BytesPP, ChannelIdx: Integer);
+var
+ X, Y, I: Integer;
+ Src: PByte;
+begin
+ I := 0;
+ // 4x4 pixel block is filled with information about every pixel in the block,
+ // but only one channel value is stored in Alpha field
+ for Y := 0 to 3 do
+ for X := 0 to 3 do
+ begin
+ Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP +
+ (XPos * 4 + X) * BytesPP + ChannelIdx];
+ Block[I].Alpha := Src^;
+ Inc(I);
+ end;
+end;
+
+procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Encode one channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ end;
+end;
+
+procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Encode Red/X channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ // Encode Green/Y channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ end;
+end;
+
+procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J, K: Integer;
+ Block: TBTCBlock;
+ Dest: PByte;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ Block := PBTCBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ K := 0;
+
+ // Just write MUpper when there is '1' in bit field and MLower
+ // when there is '0'
+ for I := 0 to 3 do
+ for J := 0 to 3 do
+ begin
+ Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J];
+ if Block.BitField and (1 shl K) <> 0 then
+ Dest^ := Block.MUpper
+ else
+ Dest^ := Block.MLower;
+ Inc(K);
+ end;
+ end;
+end;
+
+procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ AMask: array[0..1] of LongWord;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ // 6 bit alpha mask is copied into two long words for
+ // easier usage
+ AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
+ AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
+ // alpha interpolation between two endpoint alphas
+ GetInterpolatedAlphas(AlphaBlock);
+
+ // we distribute the dxt block alphas
+ // across the 4x4 block of the destination image
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
+ AlphaBlock.Alphas[AMask[J shr 1] and 7];
+ AMask[J shr 1] := AMask[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ Color: TColor32Rec;
+ AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt;
+ AMask1: array[0..1] of LongWord;
+ AMask2: array[0..1] of LongWord;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Read the first alpha block and get masks
+ AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock1));
+ AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF;
+ AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF;
+ // Read the secind alpha block and get masks
+ AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock2));
+ AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF;
+ AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF;
+ // alpha interpolation between two endpoint alphas
+ GetInterpolatedAlphas(AlphaBlock1);
+ GetInterpolatedAlphas(AlphaBlock2);
+
+ Color.A := $FF;
+ Color.B := 0;
+
+ // Distribute alpha block values across 4x4 pixel block,
+ // first alpha block represents Red channel, second is Green.
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7];
+ Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7];
+ PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color;
+ AMask1[J shr 1] := AMask1[J shr 1] shr 3;
+ AMask2[J shr 1] := AMask2[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
+ SpecialFormat: TImageFormat);
+begin
+ case SpecialFormat of
+ ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ end;
+end;
+
+procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
+ SpecialFormat: TImageFormat);
+begin
+ case SpecialFormat of
+ ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ end;
+end;
+
+procedure ConvertSpecial(var Image: TImageData;
+ SrcInfo, DstInfo: PImageFormatInfo);
+var
+ WorkImage: TImageData;
+
+ procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
+ var
+ Width, Height: Integer;
+ begin
+ Width := Img.Width;
+ Height := Img.Height;
+ DstInfo.CheckDimensions(Info.Format, Width, Height);
+ ResizeImage(Img, Width, Height, rfNearest);
+ end;
+
+begin
+ if SrcInfo.IsSpecial and DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest 'normal' format
+ InitImage(WorkImage);
+ NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
+ SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
+ FreeImage(Image);
+ // Make sure output of SpecialToUnSpecial is the same as input of
+ // UnSpecialToSpecial
+ if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then
+ ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
+ // Convert work image to dest special format
+ CheckSize(WorkImage, DstInfo);
+ NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
+ UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
+ FreeImage(WorkImage);
+ end
+ else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest 'normal' format
+ InitImage(WorkImage);
+ NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
+ SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
+ FreeImage(Image);
+ // Now convert to dest format
+ ConvertImage(WorkImage, DstInfo.Format);
+ Image := WorkImage;
+ end
+ else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest format
+ WorkImage := Image;
+ ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
+ // Now convert from nearest to dest
+ CheckSize(WorkImage, DstInfo);
+ InitImage(Image);
+ NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
+ UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
+ FreeImage(WorkImage);
+ end;
+end;
+
+function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ if FInfos[Format] <> nil then
+ Result := Width * Height * FInfos[Format].BytesPerPixel
+ else
+ Result := 0;
+end;
+
+procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt);
+begin
+end;
+
+function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ // DXT can be used only for images with dimensions that are
+ // multiples of four
+ CheckDXTDimensions(Format, Width, Height);
+ Result := Width * Height;
+ if Format in [ifDXT1, ifATI1N] then
+ Result := Result div 2;
+end;
+
+procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt);
+begin
+ // DXT image dimensions must be multiples of four
+ Width := (Width + 3) and not 3; // div 4 * 4;
+ Height := (Height + 3) and not 3; // div 4 * 4;
+end;
+
+function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ // BTC can be used only for images with dimensions that are
+ // multiples of four
+ CheckDXTDimensions(Format, Width, Height);
+ Result := Width * Height div 4; // 2bits/pixel
+end;
+
+{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
+
+function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+begin
+ Result.Color := PLongWord(Bits)^;
+end;
+
+procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+begin
+ PLongWord(Bits)^ := Color.Color;
+end;
+
+function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ Result.A := PColor32Rec(Bits).A * OneDiv8Bit;
+ Result.R := PColor32Rec(Bits).R * OneDiv8Bit;
+ Result.G := PColor32Rec(Bits).G * OneDiv8Bit;
+ Result.B := PColor32Rec(Bits).B * OneDiv8Bit;
+end;
+
+procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0));
+ PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
+ PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
+ PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
+end;
+
+function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+begin
+ result.A := 0;
+ result.R := 0;
+ result.G := 0;
+ result.B := 0;
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ Result.A := $FF;
+ PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ Result.A := PWordRec(Bits).High
+ else
+ Result.A := $FF;
+ Result.R := PWordRec(Bits).Low;
+ Result.G := PWordRec(Bits).Low;
+ Result.B := PWordRec(Bits).Low;
+ end;
+ end;
+end;
+
+procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ PColor24Rec(Bits)^ := PColor24Rec(@Color)^;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ PWordRec(Bits).High := Color.A;
+ PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B);
+ end;
+ end;
+end;
+
+function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ result.A := 0.0;
+ result.R := 0.0;
+ result.G := 0.0;
+ result.B := 0.0;
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ Result.A := 1.0;
+ Result.R := PColor24Rec(Bits).R * OneDiv8Bit;
+ Result.G := PColor24Rec(Bits).G * OneDiv8Bit;
+ Result.B := PColor24Rec(Bits).B * OneDiv8Bit;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ Result.A := PWordRec(Bits).High * OneDiv8Bit
+ else
+ Result.A := 1.0;
+ Result.R := PWordRec(Bits).Low * OneDiv8Bit;
+ Result.G := PWordRec(Bits).Low * OneDiv8Bit;
+ Result.B := PWordRec(Bits).Low * OneDiv8Bit;
+ end;
+ end;
+end;
+
+procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
+ PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
+ PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0));
+ PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B) * 255.0));
+ end;
+ end;
+end;
+
+function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ result.A := 0.0;
+ result.R := 0.0;
+ result.G := 0.0;
+ result.B := 0.0;
+ case Info.Format of
+ ifA32R32G32B32F:
+ begin
+ Result := PColorFPRec(Bits)^;
+ end;
+ ifA32B32G32R32F:
+ begin
+ Result := PColorFPRec(Bits)^;
+ SwapValues(Result.R, Result.B);
+ end;
+ ifR32F:
+ begin
+ Result.A := 1.0;
+ Result.R := PSingle(Bits)^;
+ Result.G := 0.0;
+ Result.B := 0.0;
+ end;
+ end;
+end;
+
+procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ case Info.Format of
+ ifA32R32G32B32F:
+ begin
+ PColorFPRec(Bits)^ := Color;
+ end;
+ ifA32B32G32R32F:
+ begin
+ PColorFPRec(Bits)^ := Color;
+ SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B);
+ end;
+ ifR32F:
+ begin
+ PSingle(Bits)^ := Color.R;
+ end;
+ end;
+end;
+
+initialization
+ // Initialize default sampling filter function pointers and radii
+ SamplingFilterFunctions[sfNearest] := FilterNearest;
+ SamplingFilterFunctions[sfLinear] := FilterLinear;
+ SamplingFilterFunctions[sfCosine] := FilterCosine;
+ SamplingFilterFunctions[sfHermite] := FilterHermite;
+ SamplingFilterFunctions[sfQuadratic] := FilterQuadratic;
+ SamplingFilterFunctions[sfGaussian] := FilterGaussian;
+ SamplingFilterFunctions[sfSpline] := FilterSpline;
+ SamplingFilterFunctions[sfLanczos] := FilterLanczos;
+ SamplingFilterFunctions[sfMitchell] := FilterMitchell;
+ SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom;
+ SamplingFilterRadii[sfNearest] := 1.0;
+ SamplingFilterRadii[sfLinear] := 1.0;
+ SamplingFilterRadii[sfCosine] := 1.0;
+ SamplingFilterRadii[sfHermite] := 1.0;
+ SamplingFilterRadii[sfQuadratic] := 1.5;
+ SamplingFilterRadii[sfGaussian] := 1.25;
+ SamplingFilterRadii[sfSpline] := 2.0;
+ SamplingFilterRadii[sfLanczos] := 3.0;
+ SamplingFilterRadii[sfMitchell] := 2.0;
+ SamplingFilterRadii[sfCatmullRom] := 2.0;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes -----------------------------------
+ - Filtered resampling ~10% faster now.
+ - Fixed DXT3 alpha encoding.
+ - ifIndex8 format now has HasAlphaChannel=True.
+
+ -- 0.25.0 Changes/Bug Fixes -----------------------------------
+ - Made some resampling stuff public so that it can be used in canvas class.
+ - Added some color constructors.
+ - Added VisualizePalette helper function.
+ - Fixed ConvertSpecial, not very readable before and error when
+ converting special->special.
+
+ -- 0.24.3 Changes/Bug Fixes -----------------------------------
+ - Some refactorings a changes to DXT based formats.
+ - Added ifATI1N and ifATI2N image data formats support structures and functions.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added ifBTC image format support structures and functions.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - FillMipMapLevel now works well with indexed and special formats too.
+ - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
+ and created new Convert2To8 function. They are now used by more than one
+ file format loader.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - StretchResample now uses pixel get/set functions stored in
+ TImageFormatInfo so it is much faster for formats that override
+ them with optimized ones
+ - added pixel set/get functions optimized for various image formats
+ (to be stored in TImageFormatInfo)
+ - bug in ConvertSpecial caused problems when converting DXTC images
+ to bitmaps in ImagingCoponents
+ - bug in StretchRect caused that it didn't work with ifR32F and
+ ifR16F formats
+ - removed leftover code in FillMipMapLevel which disabled
+ filtered resizing of images witch ChannelSize <> 8bits
+ - added half float converting functions and support for half based
+ image formats where needed
+ - added TranslatePixel and IsImageFormatValid functions
+ - fixed possible range overflows when converting from FP to integer images
+ - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
+ SetPixel32Generic, SetPixelFPGeneric
+ - fixed occasional range overflows in StretchResample
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - added StretchNearest, StretchResample and some sampling functions
+ - added ChannelCount values to TImageFormatInfo constants
+ - added resolution validity check to GetDXTPixelsSize
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - added RBSwapFormat values to some TImageFromatInfo definitions
+ - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
+ - added CopyPixel, ComparePixels helper functions
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - replaced pixel format conversions for colors not to be
+ darkened when converting from low bit counts
+ - ReduceColorsMedianCut was updated to support creating one
+ optimal palette for more images and it is somewhat faster
+ now too
+ - there was ugly bug in DXTC dimensions checking
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingGif.pas b/src/lib/vampimg/ImagingGif.pas
--- /dev/null
@@ -0,0 +1,1239 @@
+{
+ $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z 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, ImagingIO, 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. Imaging can load just raw ifIndex8 frames or
+ also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
+ TGIFFileFormat = class(TImageFileFormat)
+ private
+ FLoadAnimated: LongBool;
+ function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
+ procedure LZWDecompress(Stream: TStream; 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;
+ published
+ property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
+ end;
+
+implementation
+
+const
+ SGIFFormatName = 'Graphics Interchange Format';
+ SGIFMasks = '*.gif';
+ GIFSupportedFormats: TImageFormats = [ifIndex8];
+ GIFDefaultLoadAnimated = True;
+
+type
+ TGIFVersion = (gv87, gv89);
+ TDisposalMethod = (dmNoRemoval, 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
+ // Netscape sub block types
+ GIFAppLoopExtension = 1;
+ GIFAppBufferExtension = 2;
+
+type
+ TGIFIdentifierCode = array[0..7] of AnsiChar;
+ TGIFAuthenticationCode = array[0..2] of AnsiChar;
+ TGIFApplicationRec = packed record
+ Identifier: TGIFIdentifierCode;
+ Authentication: TGIFAuthenticationCode;
+ 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;
+ FLoadAnimated := GIFDefaultLoadAnimated;
+
+ AddMasks(SGIFMasks);
+ RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
+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(Stream: TStream; 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) and
+ (Stream.Position < Stream.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);
+ Stream.Read(Bytes, 1);
+ if Bytes > 0 then
+ Stream.Read(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
+ Stream.Read(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;
+type
+ TFrameInfo = record
+ Left, Top: Integer;
+ Width, Height: Integer;
+ Disposal: TDisposalMethod;
+ HasTransparency: Boolean;
+ HasLocalPal: Boolean;
+ TransIndex: Integer;
+ BackIndex: Integer;
+ end;
+var
+ Header: TGIFHeader;
+ HasGlobalPal: Boolean;
+ GlobalPalLength: Integer;
+ GlobalPal: TPalette32Size256;
+ ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
+ BlockID: Byte;
+ HasGraphicExt: Boolean;
+ GraphicExt: TGraphicControlExtension;
+ FrameInfos: array of TFrameInfo;
+ AppRead: Boolean;
+ CachedFrame: TImageData;
+ AnimFrames: TDynImageDataArray;
+
+ function ReadBlockID: Byte;
+ begin
+ Result := GIFTrailer;
+ if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
+ Result := GIFTrailer;
+ end;
+
+ procedure ReadExtensions;
+ var
+ BlockSize, BlockType, ExtType: Byte;
+ AppRec: TGIFApplicationRec;
+ LoopCount: SmallInt;
+
+ procedure SkipBytes;
+ begin
+ with GetIO do
+ repeat
+ // Read block sizes and skip them
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ Seek(Handle, BlockSize, smFromCurrent);
+ until BlockSize = 0;
+ end;
+
+ begin
+ HasGraphicExt := False;
+ AppRead := 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));
+
+ while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
+ begin
+ if ExtType = GIFGraphicControlExtension then
+ begin
+ HasGraphicExt := True;
+ Read(Handle, @GraphicExt, SizeOf(GraphicExt));
+ end
+ else if (ExtType = GIFApplicationExtension) and not AppRead then
+ begin
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ if BlockSize >= SizeOf(AppRec) then
+ begin
+ Read(Handle, @AppRec, SizeOf(AppRec));
+ if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
+ begin
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ while BlockSize <> 0 do
+ begin
+ BlockType := ReadBlockID;
+ Dec(BlockSize);
+
+ case BlockType of
+ GIFAppLoopExtension:
+ if (BlockSize >= SizeOf(LoopCount)) then
+ begin
+ // Read loop count
+ Read(Handle, @LoopCount, SizeOf(LoopCount));
+ Dec(BlockSize, SizeOf(LoopCount));
+ end;
+ GIFAppBufferExtension:
+ begin
+ Dec(BlockSize, SizeOf(Word));
+ Seek(Handle, SizeOf(Word), smFromCurrent);
+ end;
+ end;
+ end;
+ SkipBytes;
+ AppRead := True;
+ end
+ else
+ begin
+ // Revert all bytes reading
+ Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
+ SkipBytes;
+ end;
+ end
+ else
+ begin
+ Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
+ SkipBytes;
+ end;
+ 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;
+ ExtType := BlockID;
+ end
+ end;
+ end;
+
+ procedure CopyLZWData(Dest: TStream);
+ var
+ CodeSize, BlockSize: Byte;
+ InputSize: Integer;
+ Buff: array[Byte] of Byte;
+ begin
+ InputSize := ImagingIO.GetInputSize(GetIO, Handle);
+ // Copy codesize to stream
+ GetIO.Read(Handle, @CodeSize, 1);
+ Dest.Write(CodeSize, 1);
+ repeat
+ // Read and write data blocks, last is block term value of 0
+ GetIO.Read(Handle, @BlockSize, 1);
+ Dest.Write(BlockSize, 1);
+ if BlockSize > 0 then
+ begin
+ GetIO.Read(Handle, @Buff[0], BlockSize);
+ Dest.Write(Buff[0], BlockSize);
+ end;
+ until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize);
+ end;
+
+ procedure ReadFrame;
+ var
+ ImageDesc: TImageDescriptor;
+ Interlaced: Boolean;
+ I, Idx, LocalPalLength: Integer;
+ LocalPal: TPalette32Size256;
+ LZWStream: TMemoryStream;
+
+ procedure RemoveBadFrame;
+ begin
+ FreeImage(Images[Idx]);
+ SetLength(Images, Length(Images) - 1);
+ end;
+
+ begin
+ Idx := Length(Images);
+ SetLength(Images, Idx + 1);
+ SetLength(FrameInfos, Idx + 1);
+ FillChar(LocalPal, SizeOf(LocalPal), 0);
+
+ with GetIO do
+ begin
+ // Read and parse image descriptor
+ Read(Handle, @ImageDesc, SizeOf(ImageDesc));
+ FrameInfos[Idx].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)
+
+ // From Mozilla source
+ if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
+ ImageDesc.Width := Header.ScreenWidth;
+ if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then
+ ImageDesc.Height := Header.ScreenHeight;
+
+ FrameInfos[Idx].Left := ImageDesc.Left;
+ FrameInfos[Idx].Top := ImageDesc.Top;
+ FrameInfos[Idx].Width := ImageDesc.Width;
+ FrameInfos[Idx].Height := ImageDesc.Height;
+ FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
+
+ // Create new image for this frame which would be later pasted onto logical screen
+ NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
+
+ // Load local palette if there is any
+ if FrameInfos[Idx].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 FrameInfos[Idx].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);
+
+ if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
+ begin
+ // Resize the screen if needed to fit the frame
+ ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
+ ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
+ end
+ else
+ begin
+ // Remove frame outside logical screen
+ RemoveBadFrame;
+ Exit;
+ end;
+
+ // If Grahic Control Extension is present make use of it
+ if HasGraphicExt then
+ begin
+ FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
+ FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
+ if FrameInfos[Idx].HasTransparency then
+ begin
+ FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
+ Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
+ end;
+ end
+ else
+ FrameInfos[Idx].HasTransparency := False;
+
+ LZWStream := TMemoryStream.Create;
+ try
+ try
+ // Copy LZW data to temp stream, needed for correct decompression
+ CopyLZWData(LZWStream);
+ LZWStream.Position := 0;
+ // Data decompression finally
+ LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
+ except
+ RemoveBadFrame;
+ Exit;
+ end;
+ finally
+ LZWStream.Free;
+ end;
+ end;
+ end;
+
+ procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
+ var
+ X, Y: Integer;
+ Src: PByte;
+ Dst: PColor32;
+ 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 := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
+ for X := 0 to Frame.Width - 1 do
+ begin
+ if (Frame.Palette[Src^].A <> 0) then
+ Dst^ := Frame.Palette[Src^].Color;
+ Inc(Src);
+ Inc(Dst);
+ end;
+ end;
+ end;
+
+ procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
+ var
+ I, First, Last: Integer;
+ UseCache: Boolean;
+ BGColor: TColor32;
+ begin
+ // We may need to use raw frame 0 to n to correctly animate n-th frame
+ Last := Index;
+ First := Max(0, Last);
+ // See if we can use last animate frame as a basis for this one
+ // (so we don't have to use previous raw frames).
+ UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
+ (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
+
+ // Reuse or release cache
+ if UseCache then
+ CloneImage(CachedFrame, AnimFrame)
+ else
+ FreeImage(CachedFrame);
+
+ // Default color for clearing of the screen
+ BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
+
+ // Now prepare logical screen for drawing of raw frame at Index.
+ // We may need to use all previous raw frames to get the screen
+ // to proper state (according to their disposal methods).
+
+ if not UseCache then
+ begin
+ if FrameInfos[Index].HasTransparency then
+ BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
+ // Clear whole screen
+ FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
+
+ // Try to maximize First so we don't have to use all 0 to n raw frames
+ while First > 0 do
+ begin
+ if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
+ begin
+ if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
+ Break;
+ end;
+ Dec(First);
+ end;
+
+ for I := First to Last - 1 do
+ begin
+ case FrameInfos[I].Disposal of
+ dmNoRemoval, dmLeave:
+ begin
+ // Copy previous raw frame onto screen
+ CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
+ end;
+ dmRestoreBackground:
+ if (I > First) then
+ begin
+ // Restore background color
+ FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
+ FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
+ end;
+ dmRestorePrevious: ; // Do nothing - previous state is already on screen
+ end;
+ end;
+ end
+ else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
+ begin
+ // We have our cached result but also need to restore
+ // background in a place of cached frame
+ if FrameInfos[CachedIndex].HasTransparency then
+ BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
+ FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
+ FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
+ end;
+
+ // Copy current raw frame to prepared screen
+ CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
+
+ // Cache animated result
+ CloneImage(AnimFrame, CachedFrame);
+ CachedIndex := Index;
+ end;
+
+begin
+ AppRead := False;
+
+ SetLength(Images, 0);
+ FillChar(GlobalPal, SizeOf(GlobalPal), 0);
+
+ with GetIO do
+ begin
+ // Read GIF header
+ Read(Handle, @Header, SizeOf(Header));
+ ScreenWidth := Header.ScreenWidth;
+ ScreenHeight := Header.ScreenHeight;
+ 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;
+ 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 blocks until we find the one of known type
+ while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
+ BlockID := ReadBlockID;
+ // 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;
+
+ if FLoadAnimated then
+ begin
+ // Aniated frames will be stored in AnimFrames
+ SetLength(AnimFrames, Length(Images));
+ InitImage(CachedFrame);
+ CachedIndex := -1;
+
+ for I := 0 to High(Images) do
+ begin
+ // Create new logical screen
+ NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
+ // Animate frames to current log screen
+ AnimateFrame(I, AnimFrames[I]);
+ end;
+
+ // Now release raw 8bit frames and put animated 32bit ones
+ // to output array
+ FreeImage(CachedFrame);
+ for I := 0 to High(AnimFrames) do
+ begin
+ FreeImage(Images[I]);
+ Images[I] := AnimFrames[I];
+ end;
+ 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.26.3 Changes/Bug Fixes ---------------------------------
+ - Fixed bug - loading of GIF with NETSCAPE app extensions
+ failed with Delphi 2009.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - GIF loading and animation mostly rewritten, based on
+ modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed loading of some rare GIFs, problems with LZW
+ decompression.
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Better solution to transparency for some GIFs. Background not
+ transparent by default.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingIO.pas b/src/lib/vampimg/ImagingIO.pas
--- /dev/null
@@ -0,0 +1,573 @@
+{
+ $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.
diff --git a/src/lib/vampimg/ImagingJpeg.pas b/src/lib/vampimg/ImagingJpeg.pas
--- /dev/null
@@ -0,0 +1,596 @@
+{
+ $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z 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. But not when
+ WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
+{$IF Defined(LCL) and not Defined(WINDOWS)}
+ {$UNDEF IMJPEGLIB}
+ {$DEFINE PASJPEG}
+{$IFEND}
+
+interface
+
+uses
+ SysUtils, ImagingTypes, Imaging, ImagingColors,
+{$IF Defined(IMJPEGLIB)}
+ imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
+ imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
+{$ELSEIF Defined(PASJPEG)}
+ jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
+ 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}
+{$IFEND}
+
+type
+ { Class for loading/saving Jpeg images. Supports load/save of
+ 8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
+ progressive encoding.
+ Based on IJG's JpegLib so doesn't support alpha channels and lossless
+ coding.}
+ 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;
+ BufferSize = 16384;
+
+resourcestring
+ SJpegError = 'JPEG Error';
+
+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;
+ JpegErrorMgr: jpeg_error_mgr;
+
+{ Intenal unit jpeglib support functions }
+
+procedure JpegError(CInfo: j_common_ptr);
+var
+ Buffer: string;
+begin
+ { Create the message and raise exception }
+ CInfo^.err^.format_message(CInfo, buffer);
+ raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
+end;
+
+procedure OutputMessage(CurInfo: j_common_ptr);
+begin
+end;
+
+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);
+ // Set standard error handlers and then override some
+ jc.common.err := jpeg_std_error(JpegErrorMgr);
+ jc.common.err.error_exit := JpegError;
+ jc.common.err.output_message := OutputMessage;
+
+ 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);
+ // Set standard error handlers and then override some
+ jc.common.err := jpeg_std_error(JpegErrorMgr);
+ jc.common.err.error_exit := JpegError;
+ jc.common.err.output_message := OutputMessage;
+
+ jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
+ JpegStdioDest(jc.c, Handle);
+ if Saver.FGrayScale then
+ jc.c.in_color_space := JCS_GRAYSCALE
+ else
+ jc.c.in_color_space := JCS_YCbCr;
+ jpeg_set_defaults(@jc.c);
+ jpeg_set_quality(@jc.c, Saver.FQuality, True);
+ 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;
+ Col32: PColor32Rec;
+{$IFDEF RGBSWAPPED}
+ Pix: PColor24Rec;
+{$ENDIF}
+begin
+ // Copy IO functions to global var used in JpegLib callbacks
+ Result := False;
+ 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;
+ else
+ Exit;
+ 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 AnsiChar;
+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.26.3 Changes/Bug Fixes ---------------------------------
+ - Changed the Jpeg error manager, messages were not properly formated.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Fixed wrong color space setting in InitCompressor.
+ - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
+ can't use FPC's PasJpeg in Windows).
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - FPC's PasJpeg wasn't really used in last version, fixed.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingNetworkGraphics.pas b/src/lib/vampimg/ImagingNetworkGraphics.pas
--- /dev/null
@@ -0,0 +1,2573 @@
+{
+ $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z 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 loaders/savers for Network Graphics image
+ file formats PNG, MNG, and JNG.}
+unit ImagingNetworkGraphics;
+
+interface
+
+{$I ImagingOptions.inc}
+
+{ If MN support is enabled we must make sure PNG and JNG are enabled too.}
+{$IFNDEF DONT_LINK_MNG}
+ {$UNDEF DONT_LINK_PNG}
+ {$UNDEF DONT_LINK_JNG}
+{$ENDIF}
+
+uses
+ Types, SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility, ImagingFormats, dzlib;
+
+type
+ { Basic class for Network Graphics file formats loaders/savers.}
+ TNetworkGraphicsFileFormat = class(TImageFileFormat)
+ protected
+ FSignature: TChar8;
+ FPreFilter: LongInt;
+ FCompressLevel: LongInt;
+ FLossyCompression: LongBool;
+ FLossyAlpha: LongBool;
+ FQuality: LongInt;
+ FProgressive: LongBool;
+ function GetSupportedFormats: TImageFormats; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ procedure CheckOptionsValidity; override;
+ published
+ { Sets precompression filter used when saving images with lossless compression.
+ 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.}
+ property PreFilter: LongInt read FPreFilter write FPreFilter;
+ { Sets ZLib compression level used when saving images with lossless compression.
+ Allowed values are in range 0 (no compresstion) to 9 (best compression).
+ Default value is 5.}
+ property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
+ { 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.}
+ property LossyCompression: LongBool read FLossyCompression write FLossyCompression;
+ { Defines whether alpha channel of lossy MNG frames or JNG images
+ is lossy compressed too. Allowed values are 0 (False) and 1 (True).
+ Default value is 0.}
+ property LossyAlpha: LongBool read FLossyAlpha write FLossyAlpha;
+ { Specifies compression quality used when saving lossy MNG frames or JNG images.
+ For details look at ImagingJpegQuality option.}
+ property Quality: LongInt read FQuality write FQuality;
+ { Specifies whether images are saved in progressive format when saving lossy
+ MNG frames or JNG images. For details look at ImagingJpegProgressive.}
+ property Progressive: LongBool read FProgressive write FProgressive;
+ end;
+
+ { Class for loading Portable Network Graphics Images.
+ Loads all types of this image format (all images in png test suite)
+ and saves all types with bitcount >= 8 (non-interlaced only).
+ Compression level and filtering can be set by options interface.
+
+ Supported ancillary chunks (loading):
+ tRNS, bKGD
+ (for indexed images transparency contains alpha values for palette,
+ RGB/Gray images with transparency are converted to formats with alpha
+ and pixels with transparent color are replaced with background color
+ with alpha = 0).}
+ TPNGFileFormat = class(TNetworkGraphicsFileFormat)
+ private
+ FLoadAnimated: LongBool;
+ protected
+ 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;
+ published
+ property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
+ end;
+
+{$IFNDEF DONT_LINK_MNG}
+ { Class for loading Multiple Network Graphics files.
+ This format has complex animation capabilities but Imaging only
+ extracts frames. Individual frames are stored as standard PNG or JNG
+ images. Loads all types of these frames stored in IHDR-IEND and
+ JHDR-IEND streams (Note that there are MNG chunks
+ like BASI which define images but does not contain image data itself,
+ those are ignored).
+ Imaging saves MNG files as MNG-VLC (very low complexity) so it is basicaly
+ an array of image frames without MNG animation chunks. Frames can be saved
+ as lossless PNG or lossy JNG images (look at TPNGFileFormat and
+ TJNGFileFormat for info). Every frame can be in different data format.
+
+ Many frame compression settings can be modified by options interface.}
+ TMNGFileFormat = class(TNetworkGraphicsFileFormat)
+ protected
+ 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;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+ { Class for loading JPEG Network Graphics Images.
+ Loads all types of this image format (all images in jng test suite)
+ and saves all types except 12 bit JPEGs.
+ Alpha channel in JNG images is stored separately from color/gray data and
+ can be lossy (as JPEG image) or lossless (as PNG image) compressed.
+ Type of alpha compression, compression level and quality,
+ and filtering can be set by options interface.
+
+ Supported ancillary chunks (loading):
+ tRNS, bKGD
+ (Images with transparency are converted to formats with alpha
+ and pixels with transparent color are replaced with background color
+ with alpha = 0).}
+ TJNGFileFormat = class(TNetworkGraphicsFileFormat)
+ protected
+ 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;
+ end;
+{$ENDIF}
+
+
+implementation
+
+uses
+{$IFNDEF DONT_LINK_JNG}
+ ImagingJpeg, ImagingIO,
+{$ENDIF}
+ ImagingCanvases;
+
+const
+ NGDefaultPreFilter = 5;
+ NGDefaultCompressLevel = 5;
+ NGDefaultLossyAlpha = False;
+ NGDefaultLossyCompression = False;
+ NGDefaultProgressive = False;
+ NGDefaultQuality = 90;
+ NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16,
+ ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16,
+ ifA16B16G16R16];
+ NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8];
+ PNGDefaultLoadAnimated = True;
+
+ SPNGFormatName = 'Portable Network Graphics';
+ SPNGMasks = '*.png';
+ SMNGFormatName = 'Multiple Network Graphics';
+ SMNGMasks = '*.mng';
+ SJNGFormatName = 'JPEG Network Graphics';
+ SJNGMasks = '*.jng';
+
+resourcestring
+ SErrorLoadingChunk = 'Error when reading %s chunk data. File may be corrupted.';
+
+type
+ { Chunk header.}
+ TChunkHeader = packed record
+ DataSize: LongWord;
+ ChunkID: TChar4;
+ end;
+
+ { IHDR chunk format - PNG header.}
+ TIHDR = packed record
+ Width: LongWord; // Image width
+ Height: LongWord; // Image height
+ BitDepth: Byte; // Bits per pixel or bits per sample (for truecolor)
+ ColorType: Byte; // 0 = grayscale, 2 = truecolor, 3 = palette,
+ // 4 = gray + alpha, 6 = truecolor + alpha
+ Compression: Byte; // Compression type: 0 = ZLib
+ Filter: Byte; // Used precompress filter
+ Interlacing: Byte; // Used interlacing: 0 = no int, 1 = Adam7
+ end;
+ PIHDR = ^TIHDR;
+
+ { MHDR chunk format - MNG header.}
+ TMHDR = packed record
+ FrameWidth: LongWord; // Frame width
+ FrameHeight: LongWord; // Frame height
+ TicksPerSecond: LongWord; // FPS of animation
+ NominalLayerCount: LongWord; // Number of layers in file
+ NominalFrameCount: LongWord; // Number of frames in file
+ NominalPlayTime: LongWord; // Play time of animation in ticks
+ SimplicityProfile: LongWord; // Defines which MNG features are used in this file
+ end;
+ PMHDR = ^TMHDR;
+
+ { JHDR chunk format - JNG header.}
+ TJHDR = packed record
+ Width: LongWord; // Image width
+ Height: LongWord; // Image height
+ ColorType: Byte; // 8 = grayscale (Y), 10 = color (YCbCr),
+ // 12 = gray + alpha (Y-alpha), 14 = color + alpha (YCbCr-alpha)
+ SampleDepth: Byte; // 8, 12 or 20 (8 and 12 samples together) bit
+ Compression: Byte; // Compression type: 8 = Huffman coding
+ Interlacing: Byte; // 0 = single scan, 8 = progressive
+ AlphaSampleDepth: Byte; // 0, 1, 2, 4, 8, 16 if alpha compression is 0 (PNG)
+ // 8 if alpha compression is 8 (JNG)
+ AlphaCompression: Byte; // 0 = PNG graysscale IDAT, 8 = grayscale 8-bit JPEG
+ AlphaFilter: Byte; // 0 = PNG filter or no filter (JPEG)
+ AlphaInterlacing: Byte; // 0 = non interlaced
+ end;
+ PJHDR = ^TJHDR;
+
+ { acTL chunk format - APNG animation control.}
+ TacTL = packed record
+ NumFrames: LongWord; // Number of frames
+ NumPlay: LongWord; // Number of times to loop the animation (0 = inf)
+ end;
+ PacTL =^TacTL;
+
+ { fcTL chunk format - APNG frame control.}
+ TfcTL = packed record
+ SeqNumber: LongWord; // Sequence number of the animation chunk, starting from 0
+ Width: LongWord; // Width of the following frame
+ Height: LongWord; // Height of the following frame
+ XOffset: LongWord; // X position at which to render the following frame
+ YOffset: LongWord; // Y position at which to render the following frame
+ DelayNumer: Word; // Frame delay fraction numerator
+ DelayDenom: Word; // Frame delay fraction denominator
+ DisposeOp: Byte; // Type of frame area disposal to be done after rendering this frame
+ BlendOp: Byte; // Type of frame area rendering for this frame
+ end;
+ PfcTL = ^TfcTL;
+
+const
+ { PNG file identifier.}
+ PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A;
+ { MNG file identifier.}
+ MNGSignature: TChar8 = #$8A'MNG'#$0D#$0A#$1A#$0A;
+ { JNG file identifier.}
+ JNGSignature: TChar8 = #$8B'JNG'#$0D#$0A#$1A#$0A;
+
+ { Constants for chunk identifiers and signature identifiers.
+ They are in big-endian format.}
+ IHDRChunk: TChar4 = 'IHDR';
+ IENDChunk: TChar4 = 'IEND';
+ MHDRChunk: TChar4 = 'MHDR';
+ MENDChunk: TChar4 = 'MEND';
+ JHDRChunk: TChar4 = 'JHDR';
+ IDATChunk: TChar4 = 'IDAT';
+ JDATChunk: TChar4 = 'JDAT';
+ JDAAChunk: TChar4 = 'JDAA';
+ JSEPChunk: TChar4 = 'JSEP';
+ PLTEChunk: TChar4 = 'PLTE';
+ BACKChunk: TChar4 = 'BACK';
+ DEFIChunk: TChar4 = 'DEFI';
+ TERMChunk: TChar4 = 'TERM';
+ tRNSChunk: TChar4 = 'tRNS';
+ bKGDChunk: TChar4 = 'bKGD';
+ gAMAChunk: TChar4 = 'gAMA';
+ acTLChunk: TChar4 = 'acTL';
+ fcTLChunk: TChar4 = 'fcTL';
+ fdATChunk: TChar4 = 'fdAT';
+
+ { APNG frame dispose operations.}
+ DisposeOpNone = 0;
+ DisposeOpBackground = 1;
+ DisposeOpPrevious = 2;
+
+ { APNG frame blending modes}
+ BlendOpSource = 0;
+ BlendOpOver = 1;
+
+ { Interlace start and offsets.}
+ RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1);
+ ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0);
+ RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2);
+ ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1);
+
+type
+ { Helper class that holds information about MNG frame in PNG or JNG format.}
+ TFrameInfo = class(TObject)
+ public
+ FrameWidth, FrameHeight: LongInt;
+ IsJpegFrame: Boolean;
+ IHDR: TIHDR;
+ JHDR: TJHDR;
+ fcTL: TfcTL;
+ Palette: PPalette24;
+ PaletteEntries: LongInt;
+ Transparency: Pointer;
+ TransparencySize: LongInt;
+ Background: Pointer;
+ BackgroundSize: LongInt;
+ IDATMemory: TMemoryStream;
+ JDATMemory: TMemoryStream;
+ JDAAMemory: TMemoryStream;
+ constructor Create;
+ destructor Destroy; override;
+ procedure AssignSharedProps(Source: TFrameInfo);
+ end;
+
+ { Defines type of Network Graphics file.}
+ TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG);
+
+ TNGFileHandler = class(TObject)
+ public
+ FileType: TNGFileType;
+ Frames: array of TFrameInfo;
+ MHDR: TMHDR; // Main header for MNG files
+ acTL: TacTL; // Global anim control for APNG files
+ GlobalPalette: PPalette24;
+ GlobalPaletteEntries: LongInt;
+ GlobalTransparency: Pointer;
+ GlobalTransparencySize: LongInt;
+ destructor Destroy; override;
+ procedure Clear;
+ function GetLastFrame: TFrameInfo;
+ function AddFrameInfo: TFrameInfo;
+ end;
+
+ { Network Graphics file parser and frame converter.}
+ TNGFileLoader = class(TNGFileHandler)
+ public
+ function LoadFile(Handle: TImagingHandle): Boolean;
+ procedure LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData);
+{$IFNDEF DONT_LINK_JNG}
+ procedure LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
+{$ENDIF}
+ procedure ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
+ end;
+
+ TNGFileSaver = class(TNGFileHandler)
+ public
+ PreFilter: LongInt;
+ CompressLevel: LongInt;
+ LossyAlpha: Boolean;
+ Quality: LongInt;
+ Progressive: Boolean;
+ function SaveFile(Handle: TImagingHandle): Boolean;
+ procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
+ procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
+{$IFNDEF DONT_LINK_JNG}
+ procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream);
+{$ENDIF}
+ procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+ end;
+
+{$IFNDEF DONT_LINK_JNG}
+ TCustomIOJpegFileFormat = class(TJpegFileFormat)
+ protected
+ FCustomIO: TIOFunctions;
+ procedure SetJpegIO(const JpegIO: TIOFunctions); override;
+ procedure SetCustomIO(const CustomIO: TIOFunctions);
+ end;
+{$ENDIF}
+
+ TAPNGAnimator = class
+ public
+ class procedure Animate(var Images: TDynImageDataArray; const acTL: TacTL; const SrcFrames: array of TFrameInfo);
+ end;
+
+{ Helper routines }
+
+function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+var
+ P, PA, PB, PC: LongInt;
+begin
+ P := A + B - C;
+ PA := Abs(P - A);
+ PB := Abs(P - B);
+ PC := Abs(P - C);
+ if (PA <= PB) and (PA <= PC) then
+ Result := A
+ else
+ if PB <= PC then
+ Result := B
+ else
+ Result := C;
+end;
+
+procedure SwapRGB(Line: PByte; Width, SampleDepth, BytesPerPixel: LongInt);
+var
+ I: LongInt;
+ Tmp: Word;
+begin
+ case SampleDepth of
+ 8:
+ for I := 0 to Width - 1 do
+ with PColor24Rec(Line)^ do
+ begin
+ Tmp := R;
+ R := B;
+ B := Tmp;
+ Inc(Line, BytesPerPixel);
+ end;
+ 16:
+ for I := 0 to Width - 1 do
+ with PColor48Rec(Line)^ do
+ begin
+ Tmp := R;
+ R := B;
+ B := Tmp;
+ Inc(Line, BytesPerPixel);
+ end;
+ end;
+ end;
+
+const
+ { Helper constants for 1/2/4 bit to 8 bit conversions.}
+ Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+ Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
+ Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
+ Shift2: array[0..3] of Byte = (6, 4, 2, 0);
+ Mask4: array[0..1] of Byte = ($F0, $0F);
+ Shift4: array[0..1] of Byte = (4, 0);
+
+function Get1BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 3] and Mask1[X and 7]) shr
+ Shift1[X and 7];
+end;
+
+function Get2BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 2] and Mask2[X and 3]) shr
+ Shift2[X and 3];
+end;
+
+function Get4BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 1] and Mask4[X and 1]) shr
+ Shift4[X and 1];
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+{ TCustomIOJpegFileFormat class implementation }
+
+procedure TCustomIOJpegFileFormat.SetCustomIO(const CustomIO: TIOFunctions);
+begin
+ FCustomIO := CustomIO;
+end;
+
+procedure TCustomIOJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
+begin
+ inherited SetJpegIO(FCustomIO);
+end;
+
+{$ENDIF}
+
+{ TFrameInfo class implementation }
+
+constructor TFrameInfo.Create;
+begin
+ IDATMemory := TMemoryStream.Create;
+ JDATMemory := TMemoryStream.Create;
+ JDAAMemory := TMemoryStream.Create;
+end;
+
+destructor TFrameInfo.Destroy;
+begin
+ FreeMem(Palette);
+ FreeMem(Transparency);
+ FreeMem(Background);
+ IDATMemory.Free;
+ JDATMemory.Free;
+ JDAAMemory.Free;
+ inherited Destroy;
+end;
+
+procedure TFrameInfo.AssignSharedProps(Source: TFrameInfo);
+begin
+ IHDR := Source.IHDR;
+ JHDR := Source.JHDR;
+ PaletteEntries := Source.PaletteEntries;
+ GetMem(Palette, PaletteEntries * SizeOf(TColor24Rec));
+ Move(Source.Palette^, Palette^, PaletteEntries * SizeOf(TColor24Rec));
+ TransparencySize := Source.TransparencySize;
+ GetMem(Transparency, TransparencySize);
+ Move(Source.Transparency^, Transparency^, TransparencySize);
+end;
+
+{ TNGFileHandler class implementation}
+
+destructor TNGFileHandler.Destroy;
+begin
+ Clear;
+ inherited Destroy;
+end;
+
+procedure TNGFileHandler.Clear;
+var
+ I: LongInt;
+begin
+ for I := 0 to Length(Frames) - 1 do
+ Frames[I].Free;
+ SetLength(Frames, 0);
+ FreeMemNil(GlobalPalette);
+ GlobalPaletteEntries := 0;
+ FreeMemNil(GlobalTransparency);
+ GlobalTransparencySize := 0;
+end;
+
+function TNGFileHandler.GetLastFrame: TFrameInfo;
+var
+ Len: LongInt;
+begin
+ Len := Length(Frames);
+ if Len > 0 then
+ Result := Frames[Len - 1]
+ else
+ Result := nil;
+end;
+
+function TNGFileHandler.AddFrameInfo: TFrameInfo;
+var
+ Len: LongInt;
+begin
+ Len := Length(Frames);
+ SetLength(Frames, Len + 1);
+ Result := TFrameInfo.Create;
+ Frames[Len] := Result;
+end;
+
+{ TNGFileLoader class implementation}
+
+function TNGFileLoader.LoadFile(Handle: TImagingHandle): Boolean;
+var
+ Sig: TChar8;
+ Chunk: TChunkHeader;
+ ChunkData: Pointer;
+ ChunkCrc: LongWord;
+
+ procedure ReadChunk;
+ begin
+ GetIO.Read(Handle, @Chunk, SizeOf(Chunk));
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ end;
+
+ procedure ReadChunkData;
+ var
+ ReadBytes: LongWord;
+ begin
+ FreeMemNil(ChunkData);
+ GetMem(ChunkData, Chunk.DataSize);
+ ReadBytes := GetIO.Read(Handle, ChunkData, Chunk.DataSize);
+ GetIO.Read(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ if ReadBytes <> Chunk.DataSize then
+ RaiseImaging(SErrorLoadingChunk, [string(Chunk.ChunkID)]);
+ end;
+
+ procedure SkipChunkData;
+ begin
+ GetIO.Seek(Handle, Chunk.DataSize + SizeOf(ChunkCrc), smFromCurrent);
+ end;
+
+ procedure StartNewPNGImage;
+ var
+ Frame: TFrameInfo;
+ begin
+ ReadChunkData;
+
+ if Chunk.ChunkID = fcTLChunk then
+ begin
+ if (Length(Frames) = 1) and (Frames[0].IDATMemory.Size = 0) then
+ begin
+ // First fcTL chunk maybe for first IDAT frame which is alredy created
+ Frame := Frames[0];
+ end
+ else
+ begin
+ // Subsequent APNG frames with data in fdAT
+ Frame := AddFrameInfo;
+ // Copy some shared props from first frame (IHDR is the same for all APNG frames, palette etc)
+ Frame.AssignSharedProps(Frames[0]);
+ end;
+ Frame.fcTL := PfcTL(ChunkData)^;
+ SwapEndianLongWord(@Frame.fcTL, 5);
+ Frame.fcTL.DelayNumer := SwapEndianWord(Frame.fcTL.DelayNumer);
+ Frame.fcTL.DelayDenom := SwapEndianWord(Frame.fcTL.DelayDenom);
+ Frame.FrameWidth := Frame.fcTL.Width;
+ Frame.FrameHeight := Frame.fcTL.Height;
+ end
+ else
+ begin
+ // This is frame defined by IHDR chunk
+ Frame := AddFrameInfo;
+ Frame.IHDR := PIHDR(ChunkData)^;
+ SwapEndianLongWord(@Frame.IHDR, 2);
+ Frame.FrameWidth := Frame.IHDR.Width;
+ Frame.FrameHeight := Frame.IHDR.Height;
+ end;
+ Frame.IsJpegFrame := False;
+ end;
+
+ procedure StartNewJNGImage;
+ var
+ Frame: TFrameInfo;
+ begin
+ ReadChunkData;
+ Frame := AddFrameInfo;
+ Frame.IsJpegFrame := True;
+ Frame.JHDR := PJHDR(ChunkData)^;
+ SwapEndianLongWord(@Frame.JHDR, 2);
+ Frame.FrameWidth := Frame.JHDR.Width;
+ Frame.FrameHeight := Frame.JHDR.Height;
+ end;
+
+ procedure AppendIDAT;
+ begin
+ ReadChunkData;
+ // Append current IDAT/fdAT chunk to storage stream
+ if Chunk.ChunkID = IDATChunk then
+ GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize)
+ else if Chunk.ChunkID = fdATChunk then
+ GetLastFrame.IDATMemory.Write(PByteArray(ChunkData)[4], Chunk.DataSize - SizeOf(LongWord));
+ end;
+
+ procedure AppendJDAT;
+ begin
+ ReadChunkData;
+ // Append current JDAT chunk to storage stream
+ GetLastFrame.JDATMemory.Write(ChunkData^, Chunk.DataSize);
+ end;
+
+ procedure AppendJDAA;
+ begin
+ ReadChunkData;
+ // Append current JDAA chunk to storage stream
+ GetLastFrame.JDAAMemory.Write(ChunkData^, Chunk.DataSize);
+ end;
+
+ procedure LoadPLTE;
+ begin
+ ReadChunkData;
+ if GetLastFrame = nil then
+ begin
+ // Load global palette
+ GetMem(GlobalPalette, Chunk.DataSize);
+ Move(ChunkData^, GlobalPalette^, Chunk.DataSize);
+ GlobalPaletteEntries := Chunk.DataSize div 3;
+ end
+ else if GetLastFrame.Palette = nil then
+ begin
+ if (Chunk.DataSize = 0) and (GlobalPalette <> nil) then
+ begin
+ // Use global palette
+ GetMem(GetLastFrame.Palette, GlobalPaletteEntries * SizeOf(TColor24Rec));
+ Move(GlobalPalette^, GetLastFrame.Palette^, GlobalPaletteEntries * SizeOf(TColor24Rec));
+ GetLastFrame.PaletteEntries := GlobalPaletteEntries;
+ end
+ else
+ begin
+ // Load pal from PLTE chunk
+ GetMem(GetLastFrame.Palette, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Palette^, Chunk.DataSize);
+ GetLastFrame.PaletteEntries := Chunk.DataSize div 3;
+ end;
+ end;
+ end;
+
+ procedure LoadtRNS;
+ begin
+ ReadChunkData;
+ if GetLastFrame = nil then
+ begin
+ // Load global transparency
+ GetMem(GlobalTransparency, Chunk.DataSize);
+ Move(ChunkData^, GlobalTransparency^, Chunk.DataSize);
+ GlobalTransparencySize := Chunk.DataSize;
+ end
+ else if GetLastFrame.Transparency = nil then
+ begin
+ if (Chunk.DataSize = 0) and (GlobalTransparency <> nil) then
+ begin
+ // Use global transparency
+ GetMem(GetLastFrame.Transparency, GlobalTransparencySize);
+ Move(GlobalTransparency^, GetLastFrame.Transparency^, Chunk.DataSize);
+ GetLastFrame.TransparencySize := GlobalTransparencySize;
+ end
+ else
+ begin
+ // Load pal from tRNS chunk
+ GetMem(GetLastFrame.Transparency, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Transparency^, Chunk.DataSize);
+ GetLastFrame.TransparencySize := Chunk.DataSize;
+ end;
+ end;
+ end;
+
+ procedure LoadbKGD;
+ begin
+ ReadChunkData;
+ if GetLastFrame.Background = nil then
+ begin
+ GetMem(GetLastFrame.Background, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Background^, Chunk.DataSize);
+ GetLastFrame.BackgroundSize := Chunk.DataSize;
+ end;
+ end;
+
+ procedure HandleacTL;
+ begin
+ FileType := ngAPNG;
+ ReadChunkData;
+ acTL := PacTL(ChunkData)^;
+ SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord));
+ end;
+
+begin
+ Result := False;
+ Clear;
+ ChunkData := nil;
+ with GetIO do
+ try
+ Read(Handle, @Sig, SizeOf(Sig));
+ // Set file type according to the signature
+ if Sig = PNGSignature then FileType := ngPNG
+ else if Sig = MNGSignature then FileType := ngMNG
+ else if Sig = JNGSignature then FileType := ngJNG
+ else Exit;
+
+ if FileType = ngMNG then
+ begin
+ // Store MNG header if present
+ ReadChunk;
+ ReadChunkData;
+ MHDR := PMHDR(ChunkData)^;
+ SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
+ end;
+
+ // Read chunks until ending chunk or EOF is reached
+ repeat
+ ReadChunk;
+ if (Chunk.ChunkID = IHDRChunk) or (Chunk.ChunkID = fcTLChunk) then StartNewPNGImage
+ else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage
+ else if (Chunk.ChunkID = IDATChunk) or (Chunk.ChunkID = fdATChunk) then AppendIDAT
+ else if Chunk.ChunkID = JDATChunk then AppendJDAT
+ else if Chunk.ChunkID = JDAAChunk then AppendJDAA
+ else if Chunk.ChunkID = PLTEChunk then LoadPLTE
+ else if Chunk.ChunkID = tRNSChunk then LoadtRNS
+ else if Chunk.ChunkID = bKGDChunk then LoadbKGD
+ else if Chunk.ChunkID = acTLChunk then HandleacTL
+ else SkipChunkData;
+ until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or
+ ((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk));
+
+ Result := True;
+ finally
+ FreeMemNil(ChunkData);
+ end;
+end;
+
+procedure TNGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR;
+ IDATStream: TMemoryStream; var Image: TImageData);
+type
+ TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte;
+var
+ LineBuffer: array[Boolean] of PByteArray;
+ ActLine: Boolean;
+ Data, TotalBuffer, ZeroLine, PrevLine: Pointer;
+ BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass,
+ SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt;
+
+ procedure DecodeAdam7;
+ const
+ BitTable: array[1..8] of LongInt = ($1, $3, 0, $F, 0, 0, 0, $FF);
+ StartBit: array[1..8] of LongInt = (7, 6, 0, 4, 0, 0, 0, 0);
+ var
+ Src, Dst, Dst2: PByte;
+ CurBit, Col: LongInt;
+ begin
+ Src := @LineBuffer[ActLine][1];
+ Col := ColumnStart[Pass];
+ with Image do
+ case BitCount of
+ 1, 2, 4:
+ begin
+ Dst := @PByteArray(Data)[I * BytesPerLine];
+ repeat
+ CurBit := StartBit[BitCount];
+ repeat
+ Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3];
+ Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount])
+ shl (StartBit[BitCount] - (Col * BitCount mod 8));
+ Inc(Col, ColumnIncrement[Pass]);
+ Dec(CurBit, BitCount);
+ until CurBit < 0;
+ Inc(Src);
+ until Col >= Width;
+ end;
+ else
+ begin
+ Dst := @PByteArray(Data)[I * BytesPerLine + Col * BytesPerPixel];
+ repeat
+ CopyPixel(Src, Dst, BytesPerPixel);
+ Inc(Dst, BytesPerPixel);
+ Inc(Src, BytesPerPixel);
+ Inc(Dst, ColumnIncrement[Pass] * BytesPerPixel - BytesPerPixel);
+ Inc(Col, ColumnIncrement[Pass]);
+ until Col >= Width;
+ end;
+ end;
+ end;
+
+ procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray;
+ BytesPerLine: LongInt);
+ var
+ I: LongInt;
+ begin
+ case Filter of
+ 0:
+ begin
+ // No filter
+ Move(Line^, Target^, BytesPerLine);
+ end;
+ 1:
+ begin
+ // Sub filter
+ Move(Line^, Target^, BytesPerPixel);
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + Target[I - BytesPerPixel]) and $FF;
+ end;
+ 2:
+ begin
+ // Up filter
+ for I := 0 to BytesPerLine - 1 do
+ Target[I] := (Line[I] + PrevLine[I]) and $FF;
+ end;
+ 3:
+ begin
+ // Average filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + (Target[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
+ end;
+ 4:
+ begin
+ // Paeth filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + PaethPredictor(Target[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
+ end;
+ end;
+ end;
+
+ procedure Convert124To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt; Indexed: Boolean);
+ var
+ X, Y, Mul: LongInt;
+ GetPixel: TGetPixelFunc;
+ begin
+ GetPixel := Get1BitPixel;
+ Mul := 255;
+ case IHDR.BitDepth of
+ 2:
+ begin
+ Mul := 85;
+ GetPixel := Get2BitPixel;
+ end;
+ 4:
+ begin
+ Mul := 17;
+ GetPixel := Get4BitPixel;
+ end;
+ end;
+ if Indexed then Mul := 1;
+
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul;
+ end;
+
+ procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt);
+ var
+ I: LongInt;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ if IHDR.BitDepth = 8 then
+ begin
+ PColor32Rec(Data).R := Byte(PColor32Rec(Data).R + PColor32Rec(Data).G);
+ PColor32Rec(Data).B := Byte(PColor32Rec(Data).B + PColor32Rec(Data).G);
+ end
+ else
+ begin
+ PColor64Rec(Data).R := Word(PColor64Rec(Data).R + PColor64Rec(Data).G);
+ PColor64Rec(Data).B := Word(PColor64Rec(Data).B + PColor64Rec(Data).G);
+ end;
+ Inc(Data, BytesPerPixel);
+ end;
+ end;
+
+begin
+ Image.Width := FrameWidth;
+ Image.Height := FrameHeight;
+ Image.Format := ifUnknown;
+
+ case IHDR.ColorType of
+ 0:
+ begin
+ // Gray scale image
+ case IHDR.BitDepth of
+ 1, 2, 4, 8: Image.Format := ifGray8;
+ 16: Image.Format := ifGray16;
+ end;
+ BitCount := IHDR.BitDepth;
+ end;
+ 2:
+ begin
+ // RGB image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifR8G8B8;
+ 16: Image.Format := ifR16G16B16;
+ end;
+ BitCount := IHDR.BitDepth * 3;
+ end;
+ 3:
+ begin
+ // Indexed image
+ case IHDR.BitDepth of
+ 1, 2, 4, 8: Image.Format := ifIndex8;
+ end;
+ BitCount := IHDR.BitDepth;
+ end;
+ 4:
+ begin
+ // Grayscale + alpha image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifA8Gray8;
+ 16: Image.Format := ifA16Gray16;
+ end;
+ BitCount := IHDR.BitDepth * 2;
+ end;
+ 6:
+ begin
+ // ARGB image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifA8R8G8B8;
+ 16: Image.Format := ifA16R16G16B16;
+ end;
+ BitCount := IHDR.BitDepth * 4;
+ end;
+ end;
+
+ // Start decoding
+ LineBuffer[True] := nil;
+ LineBuffer[False] := nil;
+ TotalBuffer := nil;
+ ZeroLine := nil;
+ BytesPerPixel := (BitCount + 7) div 8;
+ ActLine := True;
+ with Image do
+ try
+ BytesPerLine := (Width * BitCount + 7) div 8;
+ SrcDataSize := Height * BytesPerLine;
+ GetMem(Data, SrcDataSize);
+ FillChar(Data^, SrcDataSize, 0);
+ GetMem(ZeroLine, BytesPerLine);
+ FillChar(ZeroLine^, BytesPerLine, 0);
+
+ if IHDR.Interlacing = 1 then
+ begin
+ // Decode interlaced images
+ TotalPos := 0;
+ DecompressBuf(IDATStream.Memory, IDATStream.Size, 0,
+ Pointer(TotalBuffer), TotalSize);
+ GetMem(LineBuffer[True], BytesPerLine + 1);
+ GetMem(LineBuffer[False], BytesPerLine + 1);
+ for Pass := 0 to 6 do
+ begin
+ // Prepare next interlace run
+ if Width <= ColumnStart[Pass] then
+ Continue;
+ InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 -
+ ColumnStart[Pass]) div ColumnIncrement[Pass];
+ InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3;
+ I := RowStart[Pass];
+ FillChar(LineBuffer[True][0], BytesPerLine + 1, 0);
+ FillChar(LineBuffer[False][0], BytesPerLine + 1, 0);
+ while I < Height do
+ begin
+ // Copy line from decompressed data to working buffer
+ Move(PByteArray(TotalBuffer)[TotalPos],
+ LineBuffer[ActLine][0], InterlaceLineBytes + 1);
+ Inc(TotalPos, InterlaceLineBytes + 1);
+ // Swap red and blue channels if necessary
+ if (IHDR.ColorType in [2, 6]) then
+ SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, BytesPerPixel);
+ // Reverse-filter current scanline
+ FilterScanline(LineBuffer[ActLine][0], BytesPerPixel,
+ @LineBuffer[ActLine][1], @LineBuffer[not ActLine][1],
+ @LineBuffer[ActLine][1], InterlaceLineBytes);
+ // Decode Adam7 interlacing
+ DecodeAdam7;
+ ActLine := not ActLine;
+ // Continue with next row in interlaced order
+ Inc(I, RowIncrement[Pass]);
+ end;
+ end;
+ end
+ else
+ begin
+ // Decode non-interlaced images
+ PrevLine := ZeroLine;
+ DecompressBuf(IDATStream.Memory, IDATStream.Size, SrcDataSize + Height,
+ Pointer(TotalBuffer), TotalSize);
+ for I := 0 to Height - 1 do
+ begin
+ // Swap red and blue channels if necessary
+ if IHDR.ColorType in [2, 6] then
+ SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width,
+ IHDR.BitDepth, BytesPerPixel);
+ // reverse-filter current scanline
+ FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)],
+ BytesPerPixel, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ PrevLine, @PByteArray(Data)[I * BytesPerLine], BytesPerLine);
+ PrevLine := @PByteArray(Data)[I * BytesPerLine];
+ end;
+ end;
+
+ Size := Width * Height * BytesPerPixel;
+
+ if Size <> SrcDataSize then
+ begin
+ // If source data size is different from size of image in assigned
+ // format we must convert it (it is in 1/2/4 bit count)
+ GetMem(Bits, Size);
+ case IHDR.ColorType of
+ 0: Convert124To8(Data, Bits, Width, Height, BytesPerLine, False);
+ 3: Convert124To8(Data, Bits, Width, Height, BytesPerLine, True);
+ end;
+ FreeMem(Data);
+ end
+ else
+ begin
+ // If source data size is the same as size of
+ // image Bits in assigned format we simply copy pointer reference
+ Bits := Data;
+ end;
+
+ // LOCO transformation was used too (only for color types 2 and 6)
+ if (IHDR.Filter = 64) and (IHDR.ColorType in [2, 6]) then
+ TransformLOCOToRGB(Bits, Width * Height, BytesPerPixel);
+
+ // Images with 16 bit channels must be swapped because of PNG's big endianity
+ if IHDR.BitDepth = 16 then
+ SwapEndianWord(Bits, Width * Height * BytesPerPixel div SizeOf(Word));
+ finally
+ FreeMem(LineBuffer[True]);
+ FreeMem(LineBuffer[False]);
+ FreeMem(TotalBuffer);
+ FreeMem(ZeroLine);
+ end;
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+procedure TNGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream,
+ JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
+var
+ AlphaImage: TImageData;
+ FakeIHDR: TIHDR;
+ FmtInfo: TImageFormatInfo;
+ I: LongInt;
+ AlphaPtr: PByte;
+ GrayPtr: PWordRec;
+ ColorPtr: PColor32Rec;
+
+ procedure LoadJpegFromStream(Stream: TStream; var DestImage: TImageData);
+ var
+ JpegFormat: TCustomIOJpegFileFormat;
+ Handle: TImagingHandle;
+ DynImages: TDynImageDataArray;
+ begin
+ if JHDR.SampleDepth <> 12 then
+ begin
+ JpegFormat := TCustomIOJpegFileFormat.Create;
+ JpegFormat.SetCustomIO(StreamIO);
+ Stream.Position := 0;
+ Handle := StreamIO.OpenRead(Pointer(Stream));
+ try
+ JpegFormat.LoadData(Handle, DynImages, True);
+ DestImage := DynImages[0];
+ finally
+ StreamIO.Close(Handle);
+ JpegFormat.Free;
+ SetLength(DynImages, 0);
+ end;
+ end
+ else
+ NewImage(FrameWidth, FrameHeight, ifR8G8B8, DestImage);
+ end;
+
+begin
+ LoadJpegFromStream(JDATStream, Image);
+
+ // If present separate alpha channel is processed
+ if (JHDR.ColorType in [12, 14]) and (Image.Format in [ifGray8, ifR8G8B8]) then
+ begin
+ InitImage(AlphaImage);
+ if JHDR.AlphaCompression = 0 then
+ begin
+ // Alpha channel is PNG compressed
+ FakeIHDR.Width := JHDR.Width;
+ FakeIHDR.Height := JHDR.Height;
+ FakeIHDR.ColorType := 0;
+ FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
+ FakeIHDR.Filter := JHDR.AlphaFilter;
+ FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
+
+ LoadImageFromPNGFrame(FrameWidth, FrameHeight, FakeIHDR, IDATStream, AlphaImage);
+ end
+ else
+ begin
+ // Alpha channel is JPEG compressed
+ LoadJpegFromStream(JDAAStream, AlphaImage);
+ end;
+
+ // Check if alpha channel is the same size as image
+ if (Image.Width <> AlphaImage.Width) and (Image.Height <> AlphaImage.Height) then
+ ResizeImage(AlphaImage, Image.Width, Image.Height, rfNearest);
+
+ // Check alpha channels data format
+ GetImageFormatInfo(AlphaImage.Format, FmtInfo);
+ if (FmtInfo.BytesPerPixel > 1) or (not FmtInfo.HasGrayChannel) then
+ ConvertImage(AlphaImage, ifGray8);
+
+ // Convert image to fromat with alpha channel
+ if Image.Format = ifGray8 then
+ ConvertImage(Image, ifA8Gray8)
+ else
+ ConvertImage(Image, ifA8R8G8B8);
+
+ // Combine alpha channel with image
+ AlphaPtr := AlphaImage.Bits;
+ if Image.Format = ifA8Gray8 then
+ begin
+ GrayPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ GrayPtr.High := AlphaPtr^;
+ Inc(GrayPtr);
+ Inc(AlphaPtr);
+ end;
+ end
+ else
+ begin
+ ColorPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ ColorPtr.A := AlphaPtr^;
+ Inc(ColorPtr);
+ Inc(AlphaPtr);
+ end;
+ end;
+
+ FreeImage(AlphaImage);
+ end;
+end;
+
+{$ENDIF}
+
+procedure TNGFileLoader.ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
+var
+ FmtInfo: TImageFormatInfo;
+ BackGroundColor: TColor64Rec;
+ ColorKey: TColor64Rec;
+ Alphas: PByteArray;
+ AlphasSize: LongInt;
+ IsColorKeyPresent: Boolean;
+ IsBackGroundPresent: Boolean;
+ IsColorFormat: Boolean;
+
+ procedure ConverttRNS;
+ begin
+ if FmtInfo.IsIndexed then
+ begin
+ if Alphas = nil then
+ begin
+ GetMem(Alphas, Frame.TransparencySize);
+ Move(Frame.Transparency^, Alphas^, Frame.TransparencySize);
+ AlphasSize := Frame.TransparencySize;
+ end;
+ end
+ else if not FmtInfo.HasAlphaChannel then
+ begin
+ FillChar(ColorKey, SizeOf(ColorKey), 0);
+ Move(Frame.Transparency^, ColorKey, Min(Frame.TransparencySize, SizeOf(ColorKey)));
+ if IsColorFormat then
+ SwapValues(ColorKey.R, ColorKey.B);
+ SwapEndianWord(@ColorKey, 3);
+ // 1/2/4 bit images were converted to 8 bit so we must convert color key too
+ if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
+ case Frame.IHDR.BitDepth of
+ 1: ColorKey.B := Word(ColorKey.B * 255);
+ 2: ColorKey.B := Word(ColorKey.B * 85);
+ 4: ColorKey.B := Word(ColorKey.B * 17);
+ end;
+ IsColorKeyPresent := True;
+ end;
+ end;
+
+ procedure ConvertbKGD;
+ begin
+ FillChar(BackGroundColor, SizeOf(BackGroundColor), 0);
+ Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize,
+ SizeOf(BackGroundColor)));
+ if IsColorFormat then
+ SwapValues(BackGroundColor.R, BackGroundColor.B);
+ SwapEndianWord(@BackGroundColor, 3);
+ // 1/2/4 bit images were converted to 8 bit so we must convert back color too
+ if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
+ case Frame.IHDR.BitDepth of
+ 1: BackGroundColor.B := Word(BackGroundColor.B * 255);
+ 2: BackGroundColor.B := Word(BackGroundColor.B * 85);
+ 4: BackGroundColor.B := Word(BackGroundColor.B * 17);
+ end;
+ IsBackGroundPresent := True;
+ end;
+
+ procedure ReconstructPalette;
+ var
+ I: LongInt;
+ begin
+ with Image do
+ begin
+ GetMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec));
+ FillChar(Palette^, FmtInfo.PaletteEntries * SizeOf(TColor32Rec), $FF);
+ // if RGB palette was loaded from file then use it
+ if Frame.Palette <> nil then
+ for I := 0 to Min(Frame.PaletteEntries, FmtInfo.PaletteEntries) - 1 do
+ with Palette[I] do
+ begin
+ R := Frame.Palette[I].B;
+ G := Frame.Palette[I].G;
+ B := Frame.Palette[I].R;
+ end;
+ // if palette alphas were loaded from file then use them
+ if Alphas <> nil then
+ for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do
+ Palette[I].A := Alphas[I];
+ end;
+ end;
+
+ procedure ApplyColorKey;
+ var
+ DestFmt: TImageFormat;
+ OldPixel, NewPixel: Pointer;
+ begin
+ case Image.Format of
+ ifGray8: DestFmt := ifA8Gray8;
+ ifGray16: DestFmt := ifA16Gray16;
+ ifR8G8B8: DestFmt := ifA8R8G8B8;
+ ifR16G16B16: DestFmt := ifA16R16G16B16;
+ else
+ DestFmt := ifUnknown;
+ end;
+ if DestFmt <> ifUnknown then
+ begin
+ if not IsBackGroundPresent then
+ BackGroundColor := ColorKey;
+ ConvertImage(Image, DestFmt);
+ OldPixel := @ColorKey;
+ NewPixel := @BackGroundColor;
+ // Now back color and color key must be converted to image's data format, looks ugly
+ case Image.Format of
+ ifA8Gray8:
+ begin
+ TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
+ TColor32Rec(TInt64Rec(ColorKey).Low).G := $FF;
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ end;
+ ifA16Gray16:
+ begin
+ ColorKey.G := $FFFF;
+ end;
+ ifA8R8G8B8:
+ begin
+ TColor32Rec(TInt64Rec(ColorKey).Low).R := Byte(ColorKey.R);
+ TColor32Rec(TInt64Rec(ColorKey).Low).G := Byte(ColorKey.G);
+ TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
+ TColor32Rec(TInt64Rec(ColorKey).Low).A := $FF;
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).R := Byte(BackGroundColor.R);
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).G := Byte(BackGroundColor.G);
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ end;
+ ifA16R16G16B16:
+ begin
+ ColorKey.A := $FFFF;
+ end;
+ end;
+ ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel);
+ end;
+ end;
+
+begin
+ Alphas := nil;
+ IsColorKeyPresent := False;
+ IsBackGroundPresent := False;
+ GetImageFormatInfo(Image.Format, FmtInfo);
+
+ IsColorFormat := (Frame.IsJpegFrame and (Frame.JHDR.ColorType in [10, 14])) or
+ (not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6]));
+
+ // Convert some chunk data to useful format
+ if Frame.Transparency <> nil then
+ ConverttRNS;
+ if Frame.Background <> nil then
+ ConvertbKGD;
+
+ // Build palette for indexed images
+ if FmtInfo.IsIndexed then
+ ReconstructPalette;
+
+ // Apply color keying
+ if IsColorKeyPresent and not FmtInfo.HasAlphaChannel then
+ ApplyColorKey;
+
+ FreeMemNil(Alphas);
+end;
+
+{ TNGFileSaver class implementation }
+
+procedure TNGFileSaver.StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer;
+ FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
+var
+ TotalBuffer, CompBuffer, ZeroLine, PrevLine: Pointer;
+ FilterLines: array[0..4] of PByteArray;
+ TotalSize, CompSize, I, BytesPerLine, BytesPerPixel: LongInt;
+ Filter: Byte;
+ Adaptive: Boolean;
+
+ procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
+ var
+ I: LongInt;
+ begin
+ case Filter of
+ 0:
+ begin
+ // No filter
+ Move(Line^, Target^, BytesPerLine);
+ end;
+ 1:
+ begin
+ // Sub filter
+ Move(Line^, Target^, BytesPerPixel);
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - Line[I - BytesPerPixel]) and $FF;
+ end;
+ 2:
+ begin
+ // Up filter
+ for I := 0 to BytesPerLine - 1 do
+ Target[I] := (Line[I] - PrevLine[I]) and $FF;
+ end;
+ 3:
+ begin
+ // Average filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - (Line[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
+ end;
+ 4:
+ begin
+ // Paeth filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - PaethPredictor(Line[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
+ end;
+ end;
+ end;
+
+ procedure AdaptiveFilter(var Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
+ var
+ I, J, BestTest: LongInt;
+ Sums: array[0..4] of LongInt;
+ begin
+ // Compute the output scanline using all five filters,
+ // and select the filter that gives the smallest sum of
+ // absolute values of outputs
+ FillChar(Sums, SizeOf(Sums), 0);
+ BestTest := MaxInt;
+ for I := 0 to 4 do
+ begin
+ FilterScanline(I, BytesPerPixel, Line, PrevLine, FilterLines[I]);
+ for J := 0 to BytesPerLine - 1 do
+ Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J]));
+ if Sums[I] < BestTest then
+ begin
+ Filter := I;
+ BestTest := Sums[I];
+ end;
+ end;
+ Move(FilterLines[Filter]^, Target^, BytesPerLine);
+ end;
+
+begin
+ // Select precompression filter and compression level
+ Adaptive := False;
+ Filter := 0;
+ case PreFilter of
+ 6:
+ if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3))
+ then Adaptive := True;
+ 0..4: Filter := PreFilter;
+ else
+ if IHDR.ColorType in [2, 6] then
+ Filter := 4
+ end;
+ // Prepare data for compression
+ CompBuffer := nil;
+ FillChar(FilterLines, SizeOf(FilterLines), 0);
+ BytesPerPixel := FmtInfo.BytesPerPixel;
+ BytesPerLine := LongInt(IHDR.Width) * BytesPerPixel;
+ TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height);
+ GetMem(TotalBuffer, TotalSize);
+ GetMem(ZeroLine, BytesPerLine);
+ FillChar(ZeroLine^, BytesPerLine, 0);
+ if Adaptive then
+ for I := 0 to 4 do
+ GetMem(FilterLines[I], BytesPerLine);
+ PrevLine := ZeroLine;
+ try
+ // Process next scanlines
+ for I := 0 to IHDR.Height - 1 do
+ begin
+ // Filter scanline
+ if Adaptive then
+ AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
+ PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1])
+ else
+ FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
+ PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]);
+ PrevLine := @PByteArray(Bits)[I * BytesPerLine];
+ // Swap red and blue if necessary
+ if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then
+ SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ IHDR.Width, IHDR.BitDepth, FmtInfo.BytesPerPixel);
+ // Images with 16 bit channels must be swapped because of PNG's big endianess
+ if IHDR.BitDepth = 16 then
+ SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ BytesPerLine div SizeOf(Word));
+ // Set filter used for this scanline
+ PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter;
+ end;
+ // Compress IDAT data
+ CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, CompressLevel);
+ // Write IDAT data to stream
+ IDATStream.WriteBuffer(CompBuffer^, CompSize);
+ finally
+ FreeMem(TotalBuffer);
+ FreeMem(CompBuffer);
+ FreeMem(ZeroLine);
+ if Adaptive then
+ for I := 0 to 4 do
+ FreeMem(FilterLines[I]);
+ end;
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+procedure TNGFileSaver.StoreImageToJNGFrame(const JHDR: TJHDR;
+ const Image: TImageData; IDATStream, JDATStream,
+ JDAAStream: TMemoryStream);
+var
+ ColorImage, AlphaImage: TImageData;
+ FmtInfo: TImageFormatInfo;
+ AlphaPtr: PByte;
+ GrayPtr: PWordRec;
+ ColorPtr: PColor32Rec;
+ I: LongInt;
+ FakeIHDR: TIHDR;
+
+ procedure SaveJpegToStream(Stream: TStream; const Image: TImageData);
+ var
+ JpegFormat: TCustomIOJpegFileFormat;
+ Handle: TImagingHandle;
+ DynImages: TDynImageDataArray;
+ begin
+ JpegFormat := TCustomIOJpegFileFormat.Create;
+ JpegFormat.SetCustomIO(StreamIO);
+ // Only JDAT stream can be saved progressive
+ if Stream = JDATStream then
+ JpegFormat.FProgressive := Progressive
+ else
+ JpegFormat.FProgressive := False;
+ JpegFormat.FQuality := Quality;
+ SetLength(DynImages, 1);
+ DynImages[0] := Image;
+ Handle := StreamIO.OpenWrite(Pointer(Stream));
+ try
+ JpegFormat.SaveData(Handle, DynImages, 0);
+ finally
+ StreamIO.Close(Handle);
+ SetLength(DynImages, 0);
+ JpegFormat.Free;
+ end;
+ end;
+
+begin
+ GetImageFormatInfo(Image.Format, FmtInfo);
+ InitImage(ColorImage);
+ InitImage(AlphaImage);
+
+ if FmtInfo.HasAlphaChannel then
+ begin
+ // Create new image for alpha channel and color image without alpha
+ CloneImage(Image, ColorImage);
+ NewImage(Image.Width, Image.Height, ifGray8, AlphaImage);
+ case Image.Format of
+ ifA8Gray8: ConvertImage(ColorImage, ifGray8);
+ ifA8R8G8B8: ConvertImage(ColorImage, ifR8G8B8);
+ end;
+
+ // Store source image's alpha to separate image
+ AlphaPtr := AlphaImage.Bits;
+ if Image.Format = ifA8Gray8 then
+ begin
+ GrayPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ AlphaPtr^ := GrayPtr.High;
+ Inc(GrayPtr);
+ Inc(AlphaPtr);
+ end;
+ end
+ else
+ begin
+ ColorPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ AlphaPtr^ := ColorPtr.A;
+ Inc(ColorPtr);
+ Inc(AlphaPtr);
+ end;
+ end;
+
+ // Write color image to stream as JPEG
+ SaveJpegToStream(JDATStream, ColorImage);
+
+ if LossyAlpha then
+ begin
+ // Write alpha image to stream as JPEG
+ SaveJpegToStream(JDAAStream, AlphaImage);
+ end
+ else
+ begin
+ // Alpha channel is PNG compressed
+ FakeIHDR.Width := JHDR.Width;
+ FakeIHDR.Height := JHDR.Height;
+ FakeIHDR.ColorType := 0;
+ FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
+ FakeIHDR.Filter := JHDR.AlphaFilter;
+ FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
+
+ GetImageFormatInfo(AlphaImage.Format, FmtInfo);
+ StoreImageToPNGFrame(FakeIHDR, AlphaImage.Bits, FmtInfo, IDATStream);
+ end;
+
+ FreeImage(ColorImage);
+ FreeImage(AlphaImage);
+ end
+ else
+ begin
+ // Simply write JPEG to stream
+ SaveJpegToStream(JDATStream, Image);
+ end;
+end;
+
+{$ENDIF}
+
+procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
+var
+ Frame: TFrameInfo;
+ FmtInfo: TImageFormatInfo;
+
+ procedure StorePalette;
+ var
+ Pal: PPalette24;
+ Alphas: PByteArray;
+ I, PalBytes: LongInt;
+ AlphasDiffer: Boolean;
+ begin
+ // Fill and save RGB part of palette to PLTE chunk
+ PalBytes := FmtInfo.PaletteEntries * SizeOf(TColor24Rec);
+ GetMem(Pal, PalBytes);
+ AlphasDiffer := False;
+ for I := 0 to FmtInfo.PaletteEntries - 1 do
+ begin
+ Pal[I].B := Image.Palette[I].R;
+ Pal[I].G := Image.Palette[I].G;
+ Pal[I].R := Image.Palette[I].B;
+ if Image.Palette[I].A < 255 then
+ AlphasDiffer := True;
+ end;
+ Frame.Palette := Pal;
+ Frame.PaletteEntries := FmtInfo.PaletteEntries;
+ // Fill and save alpha part (if there are any alphas < 255) of palette to tRNS chunk
+ if AlphasDiffer then
+ begin
+ PalBytes := FmtInfo.PaletteEntries * SizeOf(Byte);
+ GetMem(Alphas, PalBytes);
+ for I := 0 to FmtInfo.PaletteEntries - 1 do
+ Alphas[I] := Image.Palette[I].A;
+ Frame.Transparency := Alphas;
+ Frame.TransparencySize := PalBytes;
+ end;
+ end;
+
+begin
+ // Add new frame
+ Frame := AddFrameInfo;
+ Frame.IsJpegFrame := IsJpegFrame;
+
+ with Frame do
+ begin
+ GetImageFormatInfo(Image.Format, FmtInfo);
+
+ if IsJpegFrame then
+ begin
+{$IFNDEF DONT_LINK_JNG}
+ // Fill JNG header
+ JHDR.Width := Image.Width;
+ JHDR.Height := Image.Height;
+ case Image.Format of
+ ifGray8: JHDR.ColorType := 8;
+ ifR8G8B8: JHDR.ColorType := 10;
+ ifA8Gray8: JHDR.ColorType := 12;
+ ifA8R8G8B8: JHDR.ColorType := 14;
+ end;
+ JHDR.SampleDepth := 8; // 8-bit samples and quantization tables
+ JHDR.Compression := 8; // Huffman coding
+ JHDR.Interlacing := Iff(Progressive, 8, 0);
+ JHDR.AlphaSampleDepth := Iff(FmtInfo.HasAlphaChannel, 8, 0);
+ JHDR.AlphaCompression := Iff(LossyAlpha, 8, 0);
+ JHDR.AlphaFilter := 0;
+ JHDR.AlphaInterlacing := 0;
+
+ StoreImageToJNGFrame(JHDR, Image, IDATMemory, JDATMemory, JDAAMemory);
+
+ // Finally swap endian
+ SwapEndianLongWord(@JHDR, 2);
+{$ENDIF}
+ end
+ else
+ begin
+ // Fill PNG header
+ IHDR.Width := Image.Width;
+ IHDR.Height := Image.Height;
+ IHDR.Compression := 0;
+ IHDR.Filter := 0;
+ IHDR.Interlacing := 0;
+ IHDR.BitDepth := FmtInfo.BytesPerPixel * 8;
+
+ // Select appropiate PNG color type and modify bitdepth
+ if FmtInfo.HasGrayChannel then
+ begin
+ IHDR.ColorType := 0;
+ if FmtInfo.HasAlphaChannel then
+ begin
+ IHDR.ColorType := 4;
+ IHDR.BitDepth := IHDR.BitDepth div 2;
+ end;
+ end
+ else
+ begin
+ if FmtInfo.IsIndexed then
+ IHDR.ColorType := 3
+ else
+ if FmtInfo.HasAlphaChannel then
+ begin
+ IHDR.ColorType := 6;
+ IHDR.BitDepth := IHDR.BitDepth div 4;
+ end
+ else
+ begin
+ IHDR.ColorType := 2;
+ IHDR.BitDepth := IHDR.BitDepth div 3;
+ end;
+ end;
+
+ if FileType = ngAPNG then
+ begin
+ // Fill fcTL chunk of APNG file
+ fcTL.SeqNumber := 0; // Decided when writing to file
+ fcTL.Width := IHDR.Width;
+ fcTL.Height := IHDR.Height;
+ fcTL.XOffset := 0;
+ fcTL.YOffset := 0;
+ fcTL.DelayNumer := 1;
+ fcTL.DelayDenom := 3;
+ fcTL.DisposeOp := DisposeOpNone;
+ fcTL.BlendOp := BlendOpSource;
+ SwapEndianLongWord(@fcTL, 5);
+ fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer);
+ fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom);
+ end;
+
+ // Compress PNG image and store it to stream
+ StoreImageToPNGFrame(IHDR, Image.Bits, FmtInfo, IDATMemory);
+ // Store palette if necesary
+ if FmtInfo.IsIndexed then
+ StorePalette;
+
+ // Finally swap endian
+ SwapEndianLongWord(@IHDR, 2);
+ end;
+ end;
+end;
+
+function TNGFileSaver.SaveFile(Handle: TImagingHandle): Boolean;
+var
+ I: LongInt;
+ Chunk: TChunkHeader;
+ SeqNo: LongWord;
+
+ function GetNextSeqNo: LongWord;
+ begin
+ // Seq numbers of fcTL and fdAT are "interleaved" as they share the counter.
+ // Example: first fcTL for IDAT has seq=0, next is fcTL for seond frame with
+ // seq=1, then first fdAT with seq=2, fcTL seq=3, fdAT=4, ...
+ Result := SwapEndianLongWord(SeqNo);
+ Inc(SeqNo);
+ end;
+
+ function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer;
+ Size: LongInt): LongWord;
+ begin
+ Result := $FFFFFFFF;
+ CalcCrc32(Result, @ChunkHdr.ChunkID, SizeOf(ChunkHdr.ChunkID));
+ CalcCrc32(Result, Data, Size);
+ Result := SwapEndianLongWord(Result xor $FFFFFFFF);
+ end;
+
+ procedure WriteChunk(var Chunk: TChunkHeader; ChunkData: Pointer);
+ var
+ ChunkCrc: LongWord;
+ SizeToWrite: LongInt;
+ begin
+ SizeToWrite := Chunk.DataSize;
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ ChunkCrc := CalcChunkCrc(Chunk, ChunkData, SizeToWrite);
+ GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
+ if SizeToWrite <> 0 then
+ GetIO.Write(Handle, ChunkData, SizeToWrite);
+ GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ end;
+
+ procedure WritefdAT(Frame: TFrameInfo);
+ var
+ ChunkCrc: LongWord;
+ ChunkSeqNo: LongWord;
+ begin
+ Chunk.ChunkID := fdATChunk;
+ ChunkSeqNo := GetNextSeqNo;
+ // fdAT saves seq number LongWord before compressed pixels
+ Chunk.DataSize := Frame.IDATMemory.Size + SizeOf(LongWord);
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ // Calc CRC
+ ChunkCrc := $FFFFFFFF;
+ CalcCrc32(ChunkCrc, @Chunk.ChunkID, SizeOf(Chunk.ChunkID));
+ CalcCrc32(ChunkCrc, @ChunkSeqNo, SizeOf(ChunkSeqNo));
+ CalcCrc32(ChunkCrc, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
+ ChunkCrc := SwapEndianLongWord(ChunkCrc xor $FFFFFFFF);
+ // Write out all fdAT data
+ GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
+ GetIO.Write(Handle, @ChunkSeqNo, SizeOf(ChunkSeqNo));
+ GetIO.Write(Handle, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
+ GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ end;
+
+ procedure WritePNGMainImageChunks(Frame: TFrameInfo);
+ begin
+ with Frame do
+ begin
+ // Write IHDR chunk
+ Chunk.DataSize := SizeOf(IHDR);
+ Chunk.ChunkID := IHDRChunk;
+ WriteChunk(Chunk, @IHDR);
+ // Write PLTE chunk if data is present
+ if Palette <> nil then
+ begin
+ Chunk.DataSize := PaletteEntries * SizeOf(TColor24Rec);
+ Chunk.ChunkID := PLTEChunk;
+ WriteChunk(Chunk, Palette);
+ end;
+ // Write tRNS chunk if data is present
+ if Transparency <> nil then
+ begin
+ Chunk.DataSize := TransparencySize;
+ Chunk.ChunkID := tRNSChunk;
+ WriteChunk(Chunk, Transparency);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ SeqNo := 0;
+
+ case FileType of
+ ngPNG, ngAPNG: GetIO.Write(Handle, @PNGSignature, SizeOf(TChar8));
+ ngMNG: GetIO.Write(Handle, @MNGSignature, SizeOf(TChar8));
+ ngJNG: GetIO.Write(Handle, @JNGSignature, SizeOf(TChar8));
+ end;
+
+ if FileType = ngMNG then
+ begin
+ SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
+ Chunk.DataSize := SizeOf(MHDR);
+ Chunk.ChunkID := MHDRChunk;
+ WriteChunk(Chunk, @MHDR);
+ end;
+
+ for I := 0 to Length(Frames) - 1 do
+ with Frames[I] do
+ begin
+ if IsJpegFrame then
+ begin
+ // Write JHDR chunk
+ Chunk.DataSize := SizeOf(JHDR);
+ Chunk.ChunkID := JHDRChunk;
+ WriteChunk(Chunk, @JHDR);
+ // Write JNG image data
+ Chunk.DataSize := JDATMemory.Size;
+ Chunk.ChunkID := JDATChunk;
+ WriteChunk(Chunk, JDATMemory.Memory);
+ // Write alpha channel if present
+ if JHDR.AlphaSampleDepth > 0 then
+ begin
+ if JHDR.AlphaCompression = 0 then
+ begin
+ // Alpha is PNG compressed
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ end
+ else
+ begin
+ // Alpha is JNG compressed
+ Chunk.DataSize := JDAAMemory.Size;
+ Chunk.ChunkID := JDAAChunk;
+ WriteChunk(Chunk, JDAAMemory.Memory);
+ end;
+ end;
+ // Write image end
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end
+ else if FileType <> ngAPNG then
+ begin
+ // Regular PNG frame (single PNG image or MNG frame)
+ WritePNGMainImageChunks(Frames[I]);
+ // Write PNG image data
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ // Write image end
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end
+ else if FileType = ngAPNG then
+ begin
+ // APNG frame - first frame must have acTL and fcTL before IDAT,
+ // subsequent frames have fcTL and fdAT.
+ if I = 0 then
+ begin
+ WritePNGMainImageChunks(Frames[I]);
+ Chunk.DataSize := SizeOf(acTL);
+ Chunk.ChunkID := acTLChunk;
+ WriteChunk(Chunk, @acTL);
+ end;
+ // Write fcTL before frame data
+ Chunk.DataSize := SizeOf(fcTL);
+ Chunk.ChunkID := fcTLChunk;
+ fcTl.SeqNumber := GetNextSeqNo;
+ WriteChunk(Chunk, @fcTL);
+ // Write data - IDAT for first frame and fdAT for following ones
+ if I = 0 then
+ begin
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ end
+ else
+ WritefdAT(Frames[I]);
+ // Write image end after last frame
+ if I = Length(Frames) - 1 then
+ begin
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end;
+ end;
+ end;
+
+ if FileType = ngMNG then
+ begin
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := MENDChunk;
+ WriteChunk(Chunk, nil);
+ end;
+end;
+
+procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+begin
+ PreFilter := FileFormat.FPreFilter;
+ CompressLevel := FileFormat.FCompressLevel;
+ LossyAlpha := FileFormat.FLossyAlpha;
+ Quality := FileFormat.FQuality;
+ Progressive := FileFormat.FProgressive;
+end;
+
+{ TAPNGAnimator class implemnetation }
+
+class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray;
+ const acTL: TacTL; const SrcFrames: array of TFrameInfo);
+var
+ I, SrcIdx, Offset, Len: Integer;
+ DestFrames: TDynImageDataArray;
+ SrcCanvas, DestCanvas: TImagingCanvas;
+ PreviousCache: TImageData;
+
+ function AnimatingNeeded: Boolean;
+ var
+ I: Integer;
+ begin
+ Result := False;
+ for I := 0 to Len - 1 do
+ with SrcFrames[I] do
+ begin
+ if (FrameWidth <> IHDR.Width) or (FrameHeight <> IHDR.Height) or (Len <> acTL.NumFrames) or
+ (not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and
+ not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and
+ not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ end;
+
+begin
+ Len := Length(SrcFrames);
+ if (Len = 0) or not AnimatingNeeded then
+ Exit;
+
+ if (Len = acTL.NumFrames + 1) and (SrcFrames[0].fcTL.Width = 0) then
+ begin
+ // If default image (stored in IDAT chunk) isn't part of animation we ignore it
+ Offset := 1;
+ Len := Len - 1;
+ end
+ else
+ Offset := 0;
+
+ SetLength(DestFrames, Len);
+ DestCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
+ SrcCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
+ InitImage(PreviousCache);
+ NewImage(SrcFrames[0].IHDR.Width, SrcFrames[0].IHDR.Height, Images[0].Format, PreviousCache);
+
+ for I := 0 to Len - 1 do
+ begin
+ SrcIdx := I + Offset;
+ NewImage(SrcFrames[SrcIdx].IHDR.Width, SrcFrames[SrcIdx].IHDR.Height,
+ Images[SrcIdx].Format, DestFrames[I]);
+ if DestFrames[I].Format = ifIndex8 then
+ Move(Images[SrcIdx].Palette^, DestFrames[I].Palette^, 256 * SizeOf(TColor32));
+ DestCanvas.CreateForData(@DestFrames[I]);
+
+ if (SrcFrames[SrcIdx].fcTL.DisposeOp = DisposeOpPrevious) and (SrcFrames[SrcIdx - 1].fcTL.DisposeOp <> DisposeOpPrevious) then
+ begin
+ // Cache current output buffer so we may return to it later (previous dispose op)
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ PreviousCache, 0, 0);
+ end;
+
+ if (I = 0) or (SrcIdx = 0) then
+ begin
+ // Clear whole frame with transparent black color (default for first frame)
+ DestCanvas.FillColor32 := pcClear;
+ DestCanvas.Clear;
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpBackground then
+ begin
+ // Restore background color (clear) on previous frame's area and leave previous content outside of it
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ DestFrames[I], 0, 0);
+ DestCanvas.FillColor32 := pcClear;
+ DestCanvas.FillRect(BoundsToRect(SrcFrames[SrcIdx - 1].fcTL.XOffset, SrcFrames[SrcIdx - 1].fcTL.YOffset,
+ SrcFrames[SrcIdx - 1].FrameWidth, SrcFrames[SrcIdx - 1].FrameHeight));
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpNone then
+ begin
+ // Clone previous frame - no change to output buffer
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ DestFrames[I], 0, 0);
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpPrevious then
+ begin
+ // Revert to previous frame (cached, can't just restore DestFrames[I - 2])
+ CopyRect(PreviousCache, 0, 0, PreviousCache.Width, PreviousCache.Height,
+ DestFrames[I], 0, 0);
+ end;
+
+ // Copy pixels or alpha blend them over
+ if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpSource then
+ begin
+ CopyRect(Images[SrcIdx], 0, 0, Images[SrcIdx].Width, Images[SrcIdx].Height,
+ DestFrames[I], SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
+ end
+ else if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpOver then
+ begin
+ SrcCanvas.CreateForData(@Images[SrcIdx]);
+ SrcCanvas.DrawAlpha(SrcCanvas.ClipRect, DestCanvas,
+ SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
+ end;
+
+ FreeImage(Images[SrcIdx]);
+ end;
+
+ DestCanvas.Free;
+ SrcCanvas.Free;
+ FreeImage(PreviousCache);
+
+ // Assign dest frames to final output images
+ Images := DestFrames;
+end;
+
+{ TNetworkGraphicsFileFormat class implementation }
+
+constructor TNetworkGraphicsFileFormat.Create;
+begin
+ inherited Create;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+
+ FPreFilter := NGDefaultPreFilter;
+ FCompressLevel := NGDefaultCompressLevel;
+ FLossyAlpha := NGDefaultLossyAlpha;
+ FLossyCompression := NGDefaultLossyCompression;
+ FQuality := NGDefaultQuality;
+ FProgressive := NGDefaultProgressive;
+end;
+
+procedure TNetworkGraphicsFileFormat.CheckOptionsValidity;
+begin
+ // Just check if save options has valid values
+ if not (FPreFilter in [0..6]) then
+ FPreFilter := NGDefaultPreFilter;
+ if not (FCompressLevel in [0..9]) then
+ FCompressLevel := NGDefaultCompressLevel;
+ if not (FQuality in [1..100]) then
+ FQuality := NGDefaultQuality;
+end;
+
+function TNetworkGraphicsFileFormat.GetSupportedFormats: TImageFormats;
+begin
+ if FLossyCompression then
+ Result := NGLossyFormats
+ else
+ Result := NGLosslessFormats;
+end;
+
+procedure TNetworkGraphicsFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if not FLossyCompression then
+ begin
+ // Convert formats for lossless compression
+ if Info.HasGrayChannel then
+ begin
+ if Info.HasAlphaChannel then
+ begin
+ if Info.BytesPerPixel <= 2 then
+ // Convert <= 16bit grayscale images with alpha to ifA8Gray8
+ ConvFormat := ifA8Gray8
+ else
+ // Convert > 16bit grayscale images with alpha to ifA16Gray16
+ ConvFormat := ifA16Gray16
+ end
+ else
+ // Convert grayscale images without alpha to ifGray16
+ ConvFormat := ifGray16;
+ end
+ else
+ if Info.IsFloatingPoint then
+ // Convert floating point images to 64 bit ARGB (or RGB if no alpha)
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16B16G16R16, ifB16G16R16)
+ else if Info.HasAlphaChannel or Info.IsSpecial then
+ // Convert all other images with alpha or special images to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else
+ // Convert images without alpha to R8G8B8
+ ConvFormat := ifR8G8B8;
+ end
+ else
+ begin
+ // Convert formats for lossy compression
+ if Info.HasGrayChannel then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8Gray8, ifGray8)
+ else
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
+ end;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TNetworkGraphicsFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ ReadCount: LongInt;
+ Sig: TChar8;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ FillChar(Sig, SizeOf(Sig), 0);
+ ReadCount := Read(Handle, @Sig, SizeOf(Sig));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount = SizeOf(Sig)) and (Sig = FSignature);
+ end;
+end;
+
+{ TPNGFileFormat class implementation }
+
+constructor TPNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPNGFormatName;
+ FIsMultiImageFormat := True;
+ FLoadAnimated := PNGDefaultLoadAnimated;
+ AddMasks(SPNGMasks);
+
+ FSignature := PNGSignature;
+
+ RegisterOption(ImagingPNGPreFilter, @FPreFilter);
+ RegisterOption(ImagingPNGCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated);
+end;
+
+function TPNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ I, Len: LongInt;
+ NGFileLoader: TNGFileLoader;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
+ begin
+ Len := Length(NGFileLoader.Frames);
+ SetLength(Images, Len);
+ for I := 0 to Len - 1 do
+ with NGFileLoader.Frames[I] do
+ begin
+ // Build actual image bits
+ if not IsJpegFrame then
+ NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
+ Result := True;
+ end;
+ // Animate APNG images
+ if (NGFileLoader.FileType = ngAPNG) and FLoadAnimated then
+ TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames);
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TPNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ I: Integer;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ NGFileSaver: TNGFileSaver;
+ DefaultFormat: TImageFormat;
+ Screen: TImageData;
+ AnimWidth, AnimHeight: Integer;
+begin
+ Result := False;
+ DefaultFormat := ifDefault;
+ AnimWidth := 0;
+ AnimHeight := 0;
+ NGFileSaver := TNGFileSaver.Create;
+
+ // Save images with more frames as APNG format
+ if Length(Images) > 1 then
+ begin
+ NGFileSaver.FileType := ngAPNG;
+ NGFileSaver.acTL.NumFrames := FLastIdx - FFirstIdx + 1;
+ NGFileSaver.acTL.NumPlay := 1;
+ SwapEndianLongWord(@NGFileSaver.acTL, SizeOf(NGFileSaver.acTL) div SizeOf(LongWord));
+ // Get max dimensions of frames
+ AnimWidth := Images[FFirstIdx].Width;
+ AnimHeight := Images[FFirstIdx].Height;
+ for I := FFirstIdx + 1 to FLastIdx do
+ begin
+ AnimWidth := Max(AnimWidth, Images[I].Width);
+ AnimHeight := Max(AnimHeight, Images[I].Height);
+ end;
+ end
+ else
+ NGFileSaver.FileType := ngPNG;
+ NGFileSaver.SetFileOptions(Self);
+
+ with NGFileSaver do
+ try
+ // Store all frames to be saved frames file saver
+ for I := FFirstIdx to FLastIdx do
+ begin
+ if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
+ try
+ if FileType = ngAPNG then
+ begin
+ // IHDR chunk is shared for all frames so all frames must have the
+ // same data format as the first image.
+ if I = FFirstIdx then
+ begin
+ DefaultFormat := ImageToSave.Format;
+ // Subsequenet frames may be bigger than the first one.
+ // APNG doens't support this - max allowed size is what's written in
+ // IHDR - size of main/default/first image. If some frame is
+ // bigger than the first one we need to resize (create empty bigger
+ // image and copy) the first frame so all following frames could fit to
+ // its area.
+ if (ImageToSave.Width <> AnimWidth) or (ImageToSave.Height <> AnimHeight) then
+ begin
+ InitImage(Screen);
+ NewImage(AnimWidth, AnimHeight, ImageToSave.Format, Screen);
+ CopyRect(ImageToSave, 0, 0, ImageToSave.Width, ImageToSave.Height, Screen, 0, 0);
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ ImageToSave := Screen;
+ end;
+ end
+ else if ImageToSave.Format <> DefaultFormat then
+ begin
+ if MustBeFreed then
+ ConvertImage(ImageToSave, DefaultFormat)
+ else
+ begin
+ CloneImage(Images[I], ImageToSave);
+ ConvertImage(ImageToSave, DefaultFormat);
+ MustBeFreed := True;
+ end;
+ end;
+ end;
+
+ // Add image as PNG frame
+ AddFrame(ImageToSave, False);
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end
+ else
+ Exit;
+ end;
+
+ // Finally save PNG file
+ SaveFile(Handle);
+ Result := True;
+ finally
+ NGFileSaver.Free;
+ end;
+end;
+
+{$IFNDEF DONT_LINK_MNG}
+
+{ TMNGFileFormat class implementation }
+
+constructor TMNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SMNGFormatName;
+ FIsMultiImageFormat := True;
+ AddMasks(SMNGMasks);
+
+ FSignature := MNGSignature;
+
+ RegisterOption(ImagingMNGLossyCompression, @FLossyCompression);
+ RegisterOption(ImagingMNGLossyAlpha, @FLossyAlpha);
+ RegisterOption(ImagingMNGPreFilter, @FPreFilter);
+ RegisterOption(ImagingMNGCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingMNGQuality, @FQuality);
+ RegisterOption(ImagingMNGProgressive, @FProgressive);
+end;
+
+function TMNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ NGFileLoader: TNGFileLoader;
+ I, Len: LongInt;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) then
+ begin
+ Len := Length(NGFileLoader.Frames);
+ if Len > 0 then
+ begin
+ SetLength(Images, Len);
+ for I := 0 to Len - 1 do
+ with NGFileLoader.Frames[I] do
+ begin
+ // Build actual image bits
+ if IsJpegFrame then
+ NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I])
+ else
+ NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
+ end;
+ end
+ else
+ begin
+ // Some MNG files (with BASI-IEND streams) dont have actual pixel data
+ SetLength(Images, 1);
+ NewImage(NGFileLoader.MHDR.FrameWidth, NGFileLoader.MHDR.FrameWidth, ifDefault, Images[0]);
+ end;
+ Result := True;
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TMNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ NGFileSaver: TNGFileSaver;
+ I, LargestWidth, LargestHeight: LongInt;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+begin
+ Result := False;
+ LargestWidth := 0;
+ LargestHeight := 0;
+
+ NGFileSaver := TNGFileSaver.Create;
+ NGFileSaver.FileType := ngMNG;
+ NGFileSaver.SetFileOptions(Self);
+
+ with NGFileSaver do
+ try
+ // Store all frames to be saved frames file saver
+ for I := FFirstIdx to FLastIdx do
+ begin
+ if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
+ try
+ // Add image as PNG or JNG frame
+ AddFrame(ImageToSave, FLossyCompression);
+ // Remember largest frame width and height
+ LargestWidth := Iff(LargestWidth < ImageToSave.Width, ImageToSave.Width, LargestWidth);
+ LargestHeight := Iff(LargestHeight < ImageToSave.Height, ImageToSave.Height, LargestHeight);
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end
+ else
+ Exit;
+ end;
+
+ // Fill MNG header
+ MHDR.FrameWidth := LargestWidth;
+ MHDR.FrameHeight := LargestHeight;
+ MHDR.TicksPerSecond := 0;
+ MHDR.NominalLayerCount := 0;
+ MHDR.NominalFrameCount := Length(Frames);
+ MHDR.NominalPlayTime := 0;
+ MHDR.SimplicityProfile := 473; // 111011001 binary, defines MNG-VLC with transparency and JNG support
+
+ // Finally save MNG file
+ SaveFile(Handle);
+ Result := True;
+ finally
+ NGFileSaver.Free;
+ end;
+end;
+
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+
+{ TJNGFileFormat class implementation }
+
+constructor TJNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SJNGFormatName;
+ AddMasks(SJNGMasks);
+
+ FSignature := JNGSignature;
+ FLossyCompression := True;
+
+ RegisterOption(ImagingJNGLossyAlpha, @FLossyAlpha);
+ RegisterOption(ImagingJNGAlphaPreFilter, @FPreFilter);
+ RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingJNGQuality, @FQuality);
+ RegisterOption(ImagingJNGProgressive, @FProgressive);
+end;
+
+function TJNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ NGFileLoader: TNGFileLoader;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
+ with NGFileLoader.Frames[0] do
+ begin
+ SetLength(Images, 1);
+ // Build actual image bits
+ if IsJpegFrame then
+ NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[0]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[0], Images[0]);
+ Result := True;
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TJNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ NGFileSaver: TNGFileSaver;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+begin
+ // Make image JNG compatible, store it in saver, and save it to file
+ Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
+ if Result then
+ begin
+ NGFileSaver := TNGFileSaver.Create;
+ with NGFileSaver do
+ try
+ FileType := ngJNG;
+ SetFileOptions(Self);
+ AddFrame(ImageToSave, True);
+ SaveFile(Handle);
+ finally
+ // Free NG saver and compatible image
+ NGFileSaver.Free;
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+ end;
+end;
+
+{$ENDIF}
+
+initialization
+ RegisterImageFileFormat(TPNGFileFormat);
+{$IFNDEF DONT_LINK_MNG}
+ RegisterImageFileFormat(TMNGFileFormat);
+{$ENDIF}
+{$IFNDEF DONT_LINK_JNG}
+ RegisterImageFileFormat(TJNGFileFormat);
+{$ENDIF}
+finalization
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added APNG saving support.
+ - Added APNG support to NG loader and animating to PNG loader.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Changed file format conditional compilation to reflect changes
+ in LINK symbols.
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Changes for better thread safety.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added loading of global palettes and transparencies in MNG files
+ (and by doing so fixed crash when loading images with global PLTE or tRNS).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Small changes in converting to supported formats.
+ - 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 -----------------------------------
+ - MNG and JNG support added, PNG support redesigned to support NG file handlers
+ - added classes for working with NG file formats
+ - stuff from old ImagingPng unit added and that unit was deleted
+ - unit created and initial stuff added
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - when saving indexed images save alpha to tRNS?
+ - added some defines and ifdefs to dzlib unit to allow choosing
+ impaszlib, fpc's paszlib, zlibex or other zlib implementation
+ - added colorkeying support
+ - fixed 16bit channel image handling - pixels were not swapped
+ - fixed arithmetic overflow (in paeth filter) in FPC
+ - data of unknown chunks are skipped and not needlesly loaded
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - adaptive filtering added to PNG saving
+ - TPNGFileFormat class added
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingOptions.inc b/src/lib/vampimg/ImagingOptions.inc
--- /dev/null
@@ -0,0 +1,204 @@
+{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z 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} // Ff defined, assembler versions of some
+ // functions will be used (only for x86).
+
+ // Debug options: If none of these two are defined
+ // your project settings are used.
+{ $DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow
+ // checking, stack frames, assertions, and
+ // other debugging options will be turned on.
+{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
+
+
+
+(* File format support linking options.
+ Define formats which you don't want to be registred automatically.
+ Default: all formats are registered = no symbols defined.
+ Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line
+*)
+
+{$DEFINE DONT_LINK_JPEG} // link support for Jpeg images
+//{$DEFINE DONT_LINK_PNG} // link support for PNG images
+//{$DEFINE DONT_LINK_TARGA} // link support for Targa images
+//{$DEFINE DONT_LINK_BITMAP} // link support for Windows Bitmap images
+//{$DEFINE DONT_LINK_DDS} // link support for DDS images
+//{$DEFINE DONT_LINK_GIF} // link support for GIF images
+{$DEFINE DONT_LINK_MNG} // link support for MNG images
+{$DEFINE DONT_LINK_JNG} // link support for JNG images
+//{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
+
+//{$DEFINE DONT_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. }
+
+{ $DEFINE COMPONENT_SET_VCL} // use Delphi VCL
+{ $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}
+
+{$IF Defined(IMAGING_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}
+{$ELSEIF Defined(IMAGING_RELEASE)}
+ {$ASSERTIONS OFF}
+ {$DEBUGINFO OFF}
+ {$RANGECHECKS OFF}
+ {$IOCHECKS OFF}
+ {$OVERFLOWCHECKS OFF}
+ {$IFDEF DCC}
+ {$OPTIMIZATION ON}
+ {$STACKFRAMES OFF}
+ {$LOCALSYMBOLS OFF}
+ {$ENDIF}
+ {$IFDEF FPC}
+ {$S-}
+ {$ENDIF}
+{$IFEND}
+
+
+{ 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}
+{$ENDIF}
+
+{$IFDEF DELPHI}
+ {$UNDEF COMPONENT_SET_LCL}
+ {$DEFINE COMPONENT_SET_VCL}
+{$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}
+ {$ASMMODE INTEL} // intel assembler mode
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF HAS_INLINE}
+ {$INLINE ON} // turns inlining on for compilers that support it
+{$ENDIF}
+
+
+{$WARNINGS OFF}
+{$HINTS OFF}
+{$NOTES OFF}
diff --git a/src/lib/vampimg/ImagingPcx.pas b/src/lib/vampimg/ImagingPcx.pas
--- /dev/null
@@ -0,0 +1,378 @@
+{
+ $Id: ImagingPcx.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 for ZSoft Paintbrush images known as PCX.}
+unit ImagingPcx;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingFormats, ImagingUtility, ImagingIO;
+
+type
+ { Class for loading ZSoft Paintbrush images known as PCX. It is old
+ format which can store 1bit, 2bit, 4bit, 8bit, and 24bit (and 32bit but is
+ probably non-standard) images. Only loading is supported (you can still come
+ accross some PCX files) but saving is not (I don't wont this venerable format
+ to spread).}
+ TPCXFileFormat = class(TImageFileFormat)
+ protected
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ end;
+
+implementation
+
+const
+ SPCXFormatName = 'ZSoft Paintbrush Image';
+ SPCXMasks = '*.pcx';
+
+type
+ TPCXHeader = packed record
+ Id: Byte; // Always $0A
+ Version: Byte; // 0, 2, 3, 4, 5
+ Encoding: Byte; // 0, 1
+ BitsPerPixel: Byte; // 1, 2, 4, 8
+ X0, Y0: Word; // Image window top-left
+ X1, Y1: Word; // Image window bottom-right
+ DpiX: Word;
+ DpiY: Word;
+ Palette16: array [0..15] of TColor24Rec;
+ Reserved1: Byte;
+ Planes: Byte; // 1, 3, 4
+ BytesPerLine: Word;
+ PaletteType: Word; // 1: color or s/w 2: grayscale
+ Reserved2: array [0..57] of Byte;
+ end;
+
+{ TPCXFileFormat }
+
+constructor TPCXFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPCXFormatName;
+ FCanLoad := True;
+ FCanSave := False;
+ FIsMultiImageFormat := False;
+
+ AddMasks(SPCXMasks);
+end;
+
+function TPCXFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+const
+ ifMono: TImageFormat = TImageFormat(250);
+ ifIndex2: TImageFormat = TImageFormat(251);
+ ifIndex4: TImageFormat = TImageFormat(252);
+var
+ Hdr: TPCXHeader;
+ PalID, B: Byte;
+ PalPCX: TPalette24Size256;
+ FileDataFormat: TImageFormat;
+ I, J, UncompSize, BytesPerLine, ByteNum, BitNum: LongInt;
+ UncompData, RowPointer, PixelIdx: PByte;
+ Pixel24: PColor24Rec;
+ Pixel32: PColor32Rec;
+ AlphaPlane, RedPlane, GreenPlane, BluePlane,
+ Plane1, Plane2, Plane3, Plane4: PByteArray;
+
+ procedure RleDecode(Target: PByte; UnpackedSize: LongInt);
+ var
+ Count: LongInt;
+ Source: Byte;
+ begin
+ while UnpackedSize > 0 do
+ with GetIO do
+ begin
+ GetIO.Read(Handle, @Source, SizeOf(Source));
+ if (Source and $C0) = $C0 then
+ begin
+ // RLE data
+ Count := Source and $3F;
+ if UnpackedSize < Count then
+ Count := UnpackedSize;
+ Read(Handle, @Source, SizeOf(Source));
+ FillChar(Target^, Count, Source);
+ //Inc(Source);
+ Inc(Target, Count);
+ Dec(UnpackedSize, Count);
+ end
+ else
+ begin
+ // Uncompressed data
+ Target^ := Source;
+ Inc(Target);
+ Dec(UnpackedSize);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ begin
+ // Read PCX header and store input position (start of image data)
+ Read(Handle, @Hdr, SizeOf(Hdr));
+ FileDataFormat := ifUnknown;
+
+ // Determine image's data format and find its Imaging equivalent
+ // (using some custom TImageFormat constants)
+ case Hdr.BitsPerPixel of
+ 1:
+ case Hdr.Planes of
+ 1: FileDataFormat := ifMono;
+ 4: FileDataFormat := ifIndex4;
+ end;
+ 2: FileDataFormat := ifIndex2;
+ 4: FileDataFormat := ifIndex4;
+ 8:
+ case Hdr.Planes of
+ 1: FileDataFormat := ifIndex8;
+ 3: FileDataFormat := ifR8G8B8;
+ 4: FileDataFormat := ifA8R8G8B8;
+ end;
+ end;
+
+ // No compatible Imaging format found, exit
+ if FileDataFormat = ifUnknown then
+ Exit;
+
+ // Get width, height, and output data format (unsupported formats
+ // like ifMono are converted later to ifIndex8)
+ Width := Hdr.X1 - Hdr.X0 + 1;
+ Height := Hdr.Y1 - Hdr.Y0 + 1;
+ if FileDataFormat in [ifIndex8, ifR8G8B8] then
+ Format := FileDataFormat
+ else
+ Format := ifIndex8;
+
+ NewImage(Width, Height, Format, Images[0]);
+
+ if not (FileDataFormat in [ifIndex8, ifR8G8B8]) then
+ begin
+ // other formats use palette embedded to file header
+ for I := Low(Hdr.Palette16) to High(Hdr.Palette16) do
+ begin
+ Palette[I].A := $FF;
+ Palette[I].R := Hdr.Palette16[I].B;
+ Palette[I].G := Hdr.Palette16[I].G;
+ Palette[I].B := Hdr.Palette16[I].R;
+ end;
+ end;
+
+ // Now we determine various data sizes
+ BytesPerLine := Hdr.BytesPerLine * Hdr.Planes;
+ UncompSize := BytesPerLine * Height;
+
+ GetMem(UncompData, UncompSize);
+ try
+ if Hdr.Encoding = 1 then
+ begin
+ // Image data is compressed -> read and decompress
+ RleDecode(UncompData, UncompSize);
+ end
+ else
+ begin
+ // Just read uncompressed data
+ Read(Handle, UncompData, UncompSize);
+ end;
+
+ if FileDataFormat in [ifR8G8B8, ifA8R8G8B8] then
+ begin
+ // RGB and ARGB images are stored in layout different from
+ // Imaging's (and most other file formats'). First there is
+ // Width red values then there is Width green values and so on
+ RowPointer := UncompData;
+
+ if FileDataFormat = ifA8R8G8B8 then
+ begin
+ Pixel32 := Bits;
+ for I := 0 to Height - 1 do
+ begin
+ AlphaPlane := PByteArray(RowPointer);
+ RedPlane := @AlphaPlane[Hdr.BytesPerLine];
+ GreenPlane := @AlphaPlane[Hdr.BytesPerLine * 2];
+ BluePlane := @AlphaPlane[Hdr.BytesPerLine * 3];
+ for J := 0 to Width - 1 do
+ begin
+ Pixel32.A := AlphaPlane[J];
+ Pixel32.R := RedPlane[J];
+ Pixel32.G := GreenPlane[J];
+ Pixel32.B := BluePlane[J];
+ Inc(Pixel32);
+ end;
+ Inc(RowPointer, BytesPerLine);
+ end;
+ end
+ else
+ begin
+ Pixel24 := Bits;
+ for I := 0 to Height - 1 do
+ begin
+ RedPlane := PByteArray(RowPointer);
+ GreenPlane := @RedPlane[Hdr.BytesPerLine];
+ BluePlane := @RedPlane[Hdr.BytesPerLine * 2];
+ for J := 0 to Width - 1 do
+ begin
+ Pixel24.R := RedPlane[J];
+ Pixel24.G := GreenPlane[J];
+ Pixel24.B := BluePlane[J];
+ Inc(Pixel24);
+ end;
+ Inc(RowPointer, BytesPerLine);
+ end;
+ end;
+ end
+ else if FileDataFormat = ifIndex8 then
+ begin
+ // Just copy 8bit lines
+ for I := 0 to Height - 1 do
+ Move(PByteArray(UncompData)[I * Hdr.BytesPerLine], PByteArray(Bits)[I * Width], Width);
+ end
+ else if FileDataFormat = ifMono then
+ begin
+ // Convert 1bit images to ifIndex8
+ Convert1To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ end
+ else if FileDataFormat = ifIndex2 then
+ begin
+ // Convert 2bit images to ifIndex8. Note that 2bit PCX images
+ // usually use (from specs, I've never seen one myself) CGA palette
+ // which is not array of RGB tripplets. So 2bit PCXs are loaded but
+ // their colors would be wrong
+ Convert2To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ end
+ else if FileDataFormat = ifIndex4 then
+ begin
+ // 4bit images can be stored similar to RGB images (in four one bit planes)
+ // or like array of nibbles (which is more common)
+ if (Hdr.BitsPerPixel = 1) and (Hdr.Planes = 4) then
+ begin
+ RowPointer := UncompData;
+ PixelIdx := Bits;
+ for I := 0 to Height - 1 do
+ begin
+ Plane1 := PByteArray(RowPointer);
+ Plane2 := @Plane1[Hdr.BytesPerLine];
+ Plane3 := @Plane1[Hdr.BytesPerLine * 2];
+ Plane4 := @Plane1[Hdr.BytesPerLine * 3];
+
+ for J := 0 to Width - 1 do
+ begin
+ B := 0;
+ ByteNum := J div 8;
+ BitNum := 7 - (J mod 8);
+ if (Plane1[ByteNum] shr BitNum) and $1 <> 0 then B := B or $01;
+ if (Plane2[ByteNum] shr BitNum) and $1 <> 0 then B := B or $02;
+ if (Plane3[ByteNum] shr BitNum) and $1 <> 0 then B := B or $04;
+ if (Plane4[ByteNum] shr BitNum) and $1 <> 0 then B := B or $08;
+ PixelIdx^ := B;
+ Inc(PixelIdx);
+ end;
+ Inc(RowPointer, BytesPerLine);
+ end;
+ end
+ else if (Hdr.BitsPerPixel = 4) and (Hdr.Planes = 1) then
+ begin
+ // Convert 4bit images to ifIndex8
+ Convert4To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ end
+ end;
+
+ if FileDataFormat = ifIndex8 then
+ begin
+ // 8bit palette is appended at the end of the file
+ // with $0C identifier
+ //Seek(Handle, -769, smFromEnd);
+ Read(Handle, @PalID, SizeOf(PalID));
+ if PalID = $0C then
+ begin
+ Read(Handle, @PalPCX, SizeOf(PalPCX));
+ for I := Low(PalPCX) to High(PalPCX) do
+ begin
+ Palette[I].A := $FF;
+ Palette[I].R := PalPCX[I].B;
+ Palette[I].G := PalPCX[I].G;
+ Palette[I].B := PalPCX[I].R;
+ end;
+ end
+ else
+ Seek(Handle, -SizeOf(PalID), smFromCurrent);
+ end;
+
+ finally
+ FreeMem(UncompData);
+ end;
+ Result := True;
+ end;
+end;
+
+function TPCXFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Hdr: TPCXHeader;
+ 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.Id = $0A) and
+ (Hdr.Version in [0, 2, 3, 4, 5]) and
+ (Hdr.Encoding in [0..1]) and
+ (Hdr.BitsPerPixel in [1, 2, 4, 8]) and
+ (Hdr.Planes in [1, 3, 4]) and
+ (Hdr.PaletteType in [1..2]);
+ end;
+
+end;
+
+initialization
+ RegisterImageFileFormat(TPCXFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Made loader stream-safe - stream position is exactly at the end of the
+ image after loading and file size doesn't need to be know during the process.
+ - Initial TPCXFileFormat class implemented.
+
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingPortableMaps.pas b/src/lib/vampimg/ImagingPortableMaps.pas
--- /dev/null
@@ -0,0 +1,1020 @@
+{
+ $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44: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 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: AnsiChar;
+ 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;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
+ 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 AnsiChar;
+ LineEnd, LinePos: LongInt;
+ MapInfo: TPortableMapInfo;
+ LineBreak: string;
+
+ 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: AnsiChar;
+ 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 begining of the the string
+ Dec(LinePos);
+
+ Result := string(S);
+ end;
+
+ function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ begin
+ Result := StrToInt(ReadString);
+ end;
+
+ procedure FindLineBreak;
+ var
+ C: AnsiChar;
+ begin
+ LineBreak := #10;
+ repeat
+ CheckBuffer;
+ C := LineBuffer[LinePos];
+ Inc(LinePos);
+
+ if C = #13 then
+ LineBreak := #13#10;
+
+ until C = #10;
+ end;
+
+ function ParseHeader: Boolean;
+ var
+ Id: TChar2;
+ I: TTupleType;
+ TupleTypeName: string;
+ Scale: Single;
+ OldSeparator: Char;
+ begin
+ Result := False;
+ with GetIO do
+ begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ Read(Handle, @Id, SizeOf(Id));
+ FindLineBreak;
+
+ if Id[1] in ['1'..'6'] then
+ begin
+ // Read header for PBM, PGM, and PPM files
+ MapInfo.Width := ReadIntValue;
+ MapInfo.Height := ReadIntValue;
+
+ if Id[1] in ['1', '4'] then
+ begin
+ MapInfo.MaxVal := 1;
+ MapInfo.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
+ MapInfo.MaxVal := ReadIntValue;
+ MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
+ end;
+
+ MapInfo.Depth := 1;
+ case Id[1] of
+ '1', '4': MapInfo.TupleType := ttBlackAndWhite;
+ '2', '5': MapInfo.TupleType := ttGrayScale;
+ '3', '6':
+ begin
+ MapInfo.TupleType := ttRGB;
+ MapInfo.Depth := 3;
+ end;
+ end;
+ end
+ else if Id[1] = '7' then
+ begin
+ // Read values from PAM header
+ // WIDTH
+ if (ReadString <> SPAMWidth) then Exit;
+ MapInfo.Width := ReadIntValue;
+ // HEIGHT
+ if (ReadString <> SPAMheight) then Exit;
+ MapInfo.Height := ReadIntValue;
+ // DEPTH
+ if (ReadString <> SPAMDepth) then Exit;
+ MapInfo.Depth := ReadIntValue;
+ // MAXVAL
+ if (ReadString <> SPAMMaxVal) then Exit;
+ MapInfo.MaxVal := ReadIntValue;
+ MapInfo.BitCount := Iff(MapInfo.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
+ MapInfo.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
+ MapInfo.Width := ReadIntValue;
+ MapInfo.Height := ReadIntValue;
+ OldSeparator := DecimalSeparator;
+ DecimalSeparator := '.';
+ Scale := StrToFloatDef(ReadString, 0);
+ DecimalSeparator := OldSeparator;
+ MapInfo.IsBigEndian := Scale > 0.0;
+ if Id[1] = 'F' then
+ MapInfo.TupleType := ttRGBFP
+ else
+ MapInfo.TupleType := ttGrayScaleFP;
+ MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
+ MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
+ end;
+
+ FixInputPos;
+ MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
+
+ if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
+ begin
+ // Mimic the behaviour of Photoshop and other editors/viewers:
+ // If linenreaks in file are DOS CR/LF 16bit binary values are
+ // little endian, Unix LF only linebreak indicates big endian.
+ MapInfo.IsBigEndian := LineBreak = #10;
+ end;
+
+ // Check if values found in header are valid
+ Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
+ (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
+ // Now check if image has proper number of channels (PAM)
+ if Result then
+ case MapInfo.TupleType of
+ ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
+ ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
+ ttRGB: Result := MapInfo.Depth = 3;
+ ttRGBAlpha: Result := MapInfo.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 MapInfo.TupleType of
+ ttBlackAndWhite: Format := ifGray8;
+ ttBlackAndWhiteAlpha: Format := ifA8Gray8;
+ ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
+ ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
+ ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
+ ttRGBAlpha: Format := IffFormat(MapInfo.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(MapInfo.Width, MapInfo.Height, Format, Images[0]);
+ Info := GetFormatInfo(Format);
+
+ // Now read pixels from file to dest image
+ if not MapInfo.Binary then
+ begin
+ Dest := Bits;
+ for I := 0 to Width * Height - 1 do
+ begin
+ case Format of
+ ifGray8:
+ begin
+ Dest^ := ReadIntValue;
+ if MapInfo.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 MapInfo.BitCount > 1 then
+ begin
+ if not (MapInfo.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, MapInfo.BitCount div 8);
+ if MapInfo.TupleType = ttRGBFP then
+ with PColorFPRec(Dest)^ do
+ begin
+ A := 1.0;
+ R := PixelFP.R;
+ G := PixelFP.G;
+ B := PixelFP.B;
+ if MapInfo.IsBigEndian then
+ SwapEndianLongWord(PLongWord(Dest), 3);
+ end
+ else
+ begin
+ PSingle(Dest)^ := PixelFP.B;
+ if MapInfo.IsBigEndian then
+ SwapEndianLongWord(PLongWord(Dest), 1);
+ end;
+ Inc(Dest, Info.BytesPerPixel);
+ end;
+ end;
+
+ if MapInfo.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(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
+ PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
+ end
+ else if MapInfo.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;
+
+ // Swap byte order if needed
+ if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
+ SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
+ 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 (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
+ (MapInfo.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 (MapInfo.BitCount shr 3) - 1 do
+ begin
+ if MapInfo.BitCount = 8 then
+ Dest^ := Dest^ * 255 div MapInfo.MaxVal
+ else
+ PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
+ Inc(Dest, MapInfo.BitCount shr 3);
+ end;
+ end;
+
+ Result := True;
+ end;
+end;
+
+function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
+const
+ // Use Unix linebreak, for many viewers/editors it means that
+ // 16bit samples are stored as big endian - so we need to swap byte order
+ // before saving
+ 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;
+ {$IF Defined(DCC) and Defined(UNICODE)}
+ GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
+ {$ELSE}
+ GetIO.Write(Handle, @S[1], Length(S));
+ {$IFEND}
+ Inc(LineLength, Length(S));
+ end;
+
+ procedure WriteHeader;
+ var
+ OldSeparator: Char;
+ begin
+ WriteString('P' + MapInfo.FormatId);
+ if not MapInfo.HasPAMHeader then
+ begin
+ // Write header of PGM, PPM, and PFM files
+ WriteString(IntToStr(ImageToSave.Width));
+ WriteString(IntToStr(ImageToSave.Height));
+ case MapInfo.TupleType of
+ ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.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, MapInfo.Depth]));
+ WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
+ WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.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
+ MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
+ MapInfo.Depth := Info.ChannelCount;
+ if MapInfo.TupleType = ttInvalid then
+ begin
+ if Info.HasGrayChannel then
+ begin
+ if Info.HasAlphaChannel then
+ MapInfo.TupleType := ttGrayScaleAlpha
+ else
+ MapInfo.TupleType := ttGrayScale;
+ end
+ else
+ begin
+ if Info.HasAlphaChannel then
+ MapInfo.TupleType := ttRGBAlpha
+ else
+ MapInfo.TupleType := ttRGB;
+ end;
+ end;
+ // Write file header
+ WriteHeader;
+
+ if not MapInfo.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 (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
+ begin
+ // Save integer binary images
+ if MapInfo.BitCount = 8 then
+ begin
+ if MapInfo.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 MapInfo.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 MapInfo.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 MapInfo.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 MapInfo.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;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ if FSaveBinary then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := FSaveBinary;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+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;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ if FSaveBinary then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := FSaveBinary;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+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;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := True;
+ MapInfo.HasPAMHeader := True;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+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;
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ Info := GetFormatInfo(Images[Index].Format);
+
+ if (Info.ChannelCount > 1) or Info.IsIndexed then
+ MapInfo.TupleType := ttRGBFP
+ else
+ MapInfo.TupleType := ttGrayScaleFP;
+
+ if MapInfo.TupleType = ttGrayScaleFP then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+
+ MapInfo.Binary := True;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+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.26.3 Changes/Bug Fixes -----------------------------------
+ - Fixed D2009 Unicode related bug in PNM saving.
+
+ -- 0.24.3 Changes/Bug Fixes -----------------------------------
+ - Improved compatibility of 16bit/component image loading.
+ - Changes for better thread safety.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingPsd.pas b/src/lib/vampimg/ImagingPsd.pas
--- /dev/null
@@ -0,0 +1,806 @@
+{
+ $Id: ImagingPsd.pas 154 2008-12-27 15:41:09Z 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 Photoshop PSD image format.}
+unit ImagingPsd;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, ImagingTypes, Imaging, ImagingColors, ImagingUtility;
+
+type
+ { Class for loading and saving Adobe Photoshop PSD images.
+ Loading and saving of indexed, grayscale, RGB(A), HDR (FP32), and CMYK
+ (auto converted to RGB) images is supported. Non-HDR gray, RGB,
+ and CMYK images can have 8bit or 16bit color channels.
+ There is no support for loading mono images, duotone images are treated
+ like grayscale images, and multichannel and CIE Lab images are loaded as
+ RGB images but without actual conversion to RGB color space.
+ Also no layer information is loaded.}
+ TPSDFileFormat = class(TImageFileFormat)
+ protected
+ FSaveAsLayer: 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
+ property SaveAsLayer: LongBool read FSaveAsLayer write FSaveAsLayer;
+ end;
+
+implementation
+
+uses
+ ImagingExtras;
+
+const
+ SPSDFormatName = 'Photoshop Image';
+ SPSDMasks = '*.psd,*.pdd';
+ PSDSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8,
+ ifR8G8B8, ifA8R8G8B8, ifGray16, ifA16Gray16, ifR16G16B16, ifA16R16G16B16,
+ ifR32F, ifA32R32G32B32F];
+ PSDDefaultSaveAsLayer = True;
+
+const
+ SPSDMagic = '8BPS';
+ CompressionNone: Word = 0;
+ CompressionRLE: Word = 1;
+
+type
+ {$MINENUMSIZE 2}
+ { PSD Image color mode.}
+ TPSDColorMode = (
+ cmMono = 0,
+ cmGrayscale = 1,
+ cmIndexed = 2,
+ cmRGB = 3,
+ cmCMYK = 4,
+ cmMultiChannel = 7,
+ cmDuoTone = 8,
+ cmLab = 9
+ );
+
+ { PSD image main header.}
+ TPSDHeader = packed record
+ Signature: TChar4; // Format ID '8BPS'
+ Version: Word; // Always 1
+ Reserved: array[0..5] of Byte; // Reserved, all zero
+ Channels: Word; // Number of color channels (1-24) including alpha channels
+ Rows : LongWord; // Height of image in pixels (1-30000)
+ Columns: LongWord; // Width of image in pixels (1-30000)
+ Depth: Word; // Number of bits per channel (1, 8, and 16)
+ Mode: TPSDColorMode; // Color mode
+ end;
+
+ TPSDChannelInfo = packed record
+ ChannelID: Word; // 0 = Red, 1 = Green, 2 = Blue etc., -1 = Transparency mask, -2 = User mask
+ Size: LongWord; // Size of channel data.
+ end;
+
+procedure SwapHeader(var Header: TPSDHeader);
+begin
+ Header.Version := SwapEndianWord(Header.Version);
+ Header.Channels := SwapEndianWord(Header.Channels);
+ Header.Depth := SwapEndianWord(Header.Depth);
+ Header.Rows := SwapEndianLongWord(Header.Rows);
+ Header.Columns := SwapEndianLongWord(Header.Columns);
+ Header.Mode := TPSDColorMode(SwapEndianWord(Word(Header.Mode)));
+end;
+
+{
+ TPSDFileFormat class implementation
+}
+
+constructor TPSDFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPSDFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSupportedFormats := PSDSupportedFormats;
+ AddMasks(SPSDMasks);
+
+ FSaveAsLayer := PSDDefaultSaveAsLayer;
+ RegisterOption(ImagingPSDSaveAsLayer, @FSaveAsLayer);
+end;
+
+function TPSDFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Header: TPSDHeader;
+ ByteCount: LongWord;
+ RawPal: array[0..767] of Byte;
+ Compression, PackedSize: Word;
+ LineSize, ChannelPixelSize, WidthBytes,
+ CurrChannel, MaxRLESize, I, Y, X: LongInt;
+ Info: TImageFormatInfo;
+ PackedLine, LineBuffer: PByte;
+ RLELineSizes: array of Word;
+ Col32: TColor32Rec;
+ Col64: TColor64Rec;
+ PCol32: PColor32Rec;
+ PCol64: PColor64Rec;
+ PColF: PColorFPRec;
+
+ { PackBits RLE decode code from Mike Lischke's GraphicEx library.}
+ procedure DecodeRLE(Source, Dest: PByte; PackedSize, UnpackedSize: LongInt);
+ var
+ Count: LongInt;
+ begin
+ while (UnpackedSize > 0) and (PackedSize > 0) do
+ begin
+ Count := ShortInt(Source^);
+ Inc(Source);
+ Dec(PackedSize);
+ if Count < 0 then
+ begin
+ // Replicate next byte -Count + 1 times
+ if Count = -128 then
+ Continue;
+ Count := -Count + 1;
+ if Count > UnpackedSize then
+ Count := UnpackedSize;
+ FillChar(Dest^, Count, Source^);
+ Inc(Source);
+ Dec(PackedSize);
+ Inc(Dest, Count);
+ Dec(UnpackedSize, Count);
+ end
+ else
+ begin
+ // Copy next Count + 1 bytes from input
+ Inc(Count);
+ if Count > UnpackedSize then
+ Count := UnpackedSize;
+ if Count > PackedSize then
+ Count := PackedSize;
+ Move(Source^, Dest^, Count);
+ Inc(Dest, Count);
+ Inc(Source, Count);
+ Dec(PackedSize, Count);
+ Dec(UnpackedSize, Count);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ begin
+ // Read PSD header
+ Read(Handle, @Header, SizeOf(Header));
+ SwapHeader(Header);
+ // Determine image data format
+ Format := ifUnknown;
+ case Header.Mode of
+ cmGrayscale, cmDuoTone:
+ begin
+ if Header.Depth in [8, 16] then
+ begin
+ if Header.Channels = 1 then
+ Format := IffFormat(Header.Depth = 8, ifGray8, ifGray16)
+ else if Header.Channels >= 2 then
+ Format := IffFormat(Header.Depth = 8, ifA8Gray8, ifA16Gray16);
+ end
+ else if (Header.Depth = 32) and (Header.Channels = 1) then
+ Format := ifR32F;
+ end;
+ cmIndexed:
+ begin
+ if Header.Depth = 8 then
+ Format := ifIndex8;
+ end;
+ cmRGB, cmMultiChannel, cmCMYK, cmLab:
+ begin
+ if Header.Depth in [8, 16] then
+ begin
+ if Header.Channels = 3 then
+ Format := IffFormat(Header.Depth = 8, ifR8G8B8, ifR16G16B16)
+ else if Header.Channels >= 4 then
+ Format := IffFormat(Header.Depth = 8, ifA8R8G8B8, ifA16R16G16B16);
+ end
+ else if Header.Depth = 32 then
+ Format := ifA32R32G32B32F;
+ end;
+ cmMono:; // Not supported
+ end;
+
+ // Exit if no compatible format was found
+ if Format = ifUnknown then
+ Exit;
+
+ NewImage(Header.Columns, Header.Rows, Format, Images[0]);
+ Info := GetFormatInfo(Format);
+
+ // Read or skip Color Mode Data Block (palette)
+ Read(Handle, @ByteCount, SizeOf(ByteCount));
+ ByteCount := SwapEndianLongWord(ByteCount);
+ if Format = ifIndex8 then
+ begin
+ // Read palette only for indexed images
+ Read(Handle, @RawPal, SizeOf(RawPal));
+ for I := 0 to 255 do
+ begin
+ Palette[I].A := $FF;
+ Palette[I].R := RawPal[I + 0];
+ Palette[I].G := RawPal[I + 256];
+ Palette[I].B := RawPal[I + 512];
+ end;
+ end
+ else
+ Seek(Handle, ByteCount, smFromCurrent);
+
+ // Skip Image Resources Block
+ Read(Handle, @ByteCount, SizeOf(ByteCount));
+ ByteCount := SwapEndianLongWord(ByteCount);
+ Seek(Handle, ByteCount, smFromCurrent);
+ // Now there is Layer and Mask Information Block
+ Read(Handle, @ByteCount, SizeOf(ByteCount));
+ ByteCount := SwapEndianLongWord(ByteCount);
+ // Skip Layer and Mask Information Block
+ Seek(Handle, ByteCount, smFromCurrent);
+
+ // Read compression flag
+ Read(Handle, @Compression, SizeOf(Compression));
+ Compression := SwapEndianWord(Compression);
+
+ if Compression = CompressionRLE then
+ begin
+ // RLE compressed PSDs (most) have first lengths of compressed scanlines
+ // for each channel stored
+ SetLength(RLELineSizes, Height * Header.Channels);
+ Read(Handle, @RLELineSizes[0], Length(RLELineSizes) * SizeOf(Word));
+ SwapEndianWord(@RLELineSizes[0], Height * Header.Channels);
+ MaxRLESize := RLELineSizes[0];
+ for I := 1 to High(RLELineSizes) do
+ begin
+ if MaxRLESize < RLELineSizes[I] then
+ MaxRLESize := RLELineSizes[I];
+ end;
+ end
+ else
+ MaxRLESize := 0;
+
+ ChannelPixelSize := Info.BytesPerPixel div Info.ChannelCount;
+ LineSize := Width * ChannelPixelSize;
+ WidthBytes := Width * Info.BytesPerPixel;
+ GetMem(LineBuffer, LineSize);
+ GetMem(PackedLine, MaxRLESize);
+
+ try
+ // Image color chanels are stored separately in PSDs so we will load
+ // one by one and copy their data to appropriate addresses of dest image.
+ for I := 0 to Header.Channels - 1 do
+ begin
+ // Now determine to which color channel of destination image we are going
+ // to write pixels.
+ if I <= 4 then
+ begin
+ // If PSD has alpha channel we need to switch current channel order -
+ // PSDs have alpha stored after blue channel but Imaging has alpha
+ // before red.
+ if Info.HasAlphaChannel and (Header.Mode <> cmCMYK) then
+ begin
+ if I = Info.ChannelCount - 1 then
+ CurrChannel := I
+ else
+ CurrChannel := Info.ChannelCount - 2 - I;
+ end
+ else
+ CurrChannel := Info.ChannelCount - 1 - I;
+ end
+ else
+ begin
+ // No valid channel remains
+ CurrChannel := -1;
+ end;
+
+ if CurrChannel >= 0 then
+ begin
+ for Y := 0 to Height - 1 do
+ begin
+ if Compression = CompressionRLE then
+ begin
+ // Read RLE line and decompress it
+ PackedSize := RLELineSizes[I * Height + Y];
+ Read(Handle, PackedLine, PackedSize);
+ DecodeRLE(PackedLine, LineBuffer, PackedSize, LineSize);
+ end
+ else
+ begin
+ // Just read uncompressed line
+ Read(Handle, LineBuffer, LineSize);
+ end;
+
+ // Swap endian if needed
+ if ChannelPixelSize = 4 then
+ SwapEndianLongWord(PLongWord(LineBuffer), Width)
+ else if ChannelPixelSize = 2 then
+ SwapEndianWord(PWordArray(LineBuffer), Width);
+
+ if Info.ChannelCount > 1 then
+ begin
+ // Copy each pixel fragment to its right place in destination image
+ for X := 0 to Width - 1 do
+ begin
+ Move(PByteArray(LineBuffer)[X * ChannelPixelSize],
+ PByteArray(Bits)[Y * WidthBytes + X * Info.BytesPerPixel + CurrChannel * ChannelPixelSize],
+ ChannelPixelSize);
+ end;
+ end
+ else
+ begin
+ // Just copy the line
+ Move(LineBuffer^, PByteArray(Bits)[Y * LineSize], LineSize);
+ end;
+ end;
+ end
+ else
+ begin
+ // Skip current color channel, not needed for image loading - just to
+ // get stream's position to the end of PSD
+ if Compression = CompressionRLE then
+ begin
+ for Y := 0 to Height - 1 do
+ Seek(Handle, RLELineSizes[I * Height + Y], smFromCurrent);
+ end
+ else
+ Seek(Handle, LineSize * Height, smFromCurrent);
+ end;
+ end;
+
+ if Header.Mode = cmCMYK then
+ begin
+ // Convert CMYK images to RGB (alpha is ignored here). PSD stores CMYK
+ // channels in the way that first requires substraction from max channel value
+ if ChannelPixelSize = 1 then
+ begin
+ PCol32 := Bits;
+ for X := 0 to Width * Height - 1 do
+ begin
+ Col32.A := 255 - PCol32.A;
+ Col32.R := 255 - PCol32.R;
+ Col32.G := 255 - PCol32.G;
+ Col32.B := 255 - PCol32.B;
+ CMYKToRGB(Col32.A, Col32.R, Col32.G, Col32.B, PCol32.R, PCol32.G, PCol32.B);
+ PCol32.A := 255;
+ Inc(PCol32);
+ end;
+ end
+ else
+ begin
+ PCol64 := Bits;
+ for X := 0 to Width * Height - 1 do
+ begin
+ Col64.A := 65535 - PCol64.A;
+ Col64.R := 65535 - PCol64.R;
+ Col64.G := 65535 - PCol64.G;
+ Col64.B := 65535 - PCol64.B;
+ CMYKToRGB16(Col64.A, Col64.R, Col64.G, Col64.B, PCol64.R, PCol64.G, PCol64.B);
+ PCol64.A := 65535;
+ Inc(PCol64);
+ end;
+ end;
+ end;
+
+ if Header.Depth = 32 then
+ begin
+ if (Header.Channels = 3) and (Header.Mode = cmRGB) then
+ begin
+ // RGB images were loaded as ARGB so we must wet alpha manually to 1.0
+ PColF := Bits;
+ for X := 0 to Width * Height - 1 do
+ begin
+ PColF.A := 1.0;
+ Inc(PColF);
+ end;
+ end;
+ end;
+
+ Result := True;
+ finally
+ FreeMem(LineBuffer);
+ FreeMem(PackedLine);
+ end;
+ end;
+end;
+
+function TPSDFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+type
+ TURect = packed record
+ Top, Left, Bottom, Right: LongWord;
+ end;
+const
+ BlendMode: TChar8 = '8BIMnorm';
+ LayerOptions: array[0..3] of Byte = (255, 0, 0, 0);
+ LayerName: array[0..7] of AnsiChar = #7'Layer 0';
+var
+ MustBeFreed: Boolean;
+ ImageToSave: TImageData;
+ Info: TImageFormatInfo;
+ Header: TPSDHeader;
+ I, CurrChannel, ChannelPixelSize: LongInt;
+ LayerBlockOffset, SaveOffset, ChannelInfoOffset: Integer;
+ ChannelInfo: TPSDChannelInfo;
+ R: TURect;
+ LongVal: LongWord;
+ WordVal, LayerCount: Word;
+ RawPal: array[0..767] of Byte;
+ ChannelDataSizes: array of Integer;
+
+ function PackLine(Src, Dest: PByteArray; Length: Integer): Integer;
+ var
+ I, Remaining: Integer;
+ begin
+ Remaining := Length;
+ Result := 0;
+ while Remaining > 0 do
+ begin
+ I := 0;
+ // Look for characters same as the first
+ while (I < 128) and (Remaining - I > 0) and (Src[0] = Src[I]) do
+ Inc(I);
+
+ if I > 2 then
+ begin
+ Dest[0] := Byte(-(I - 1));
+ Dest[1] := Src[0];
+ Dest := PByteArray(@Dest[2]);
+
+ Src := PByteArray(@Src[I]);
+ Dec(Remaining, I);
+ Inc(Result, 2);
+ end
+ else
+ begin
+ // Look for different characters
+ I := 0;
+ while (I < 128) and (Remaining - (I + 1) > 0) and
+ ((Src[I] <> Src[I + 1]) or (Remaining - (I + 2) <= 0) or
+ (Src[I] <> Src[I + 2])) do
+ begin
+ Inc(I);
+ end;
+ // If there's only 1 remaining, the previous WHILE doesn't catch it
+ if Remaining = 1 then
+ I := 1;
+
+ if I > 0 then
+ begin
+ // Some distinct ones found
+ Dest[0] := I - 1;
+ Move(Src[0], Dest[1], I);
+ Dest := PByteArray(@Dest[1 + I]);
+ Src := PByteArray(@Src[I]);
+ Dec(Remaining, I);
+ Inc(Result, I + 1);
+ end;
+ end;
+ end;
+ end;
+
+ procedure WriteChannelData(SeparateChannelStorage: Boolean);
+ var
+ I, X, Y, LineSize, WidthBytes, RLETableOffset, CurrentOffset, WrittenLineSize: Integer;
+ LineBuffer, RLEBuffer: PByteArray;
+ RLELengths: array of Word;
+ Compression: Word;
+ begin
+ LineSize := ImageToSave.Width * ChannelPixelSize;
+ WidthBytes := ImageToSave.Width * Info.BytesPerPixel;
+ GetMem(LineBuffer, LineSize);
+ GetMem(RLEBuffer, LineSize * 3);
+ SetLength(RLELengths, ImageToSave.Height * Info.ChannelCount);
+ RLETableOffset := 0;
+ // No compression for FP32, Photoshop won't open them
+ Compression := Iff(Info.IsFloatingPoint, CompressionNone, CompressionRLE);
+
+ if not SeparateChannelStorage then
+ begin
+ // This is for storing background merged image. There's only one
+ // complession flag and one RLE lenghts table for all channels
+ WordVal := Swap(Compression);
+ GetIO.Write(Handle, @WordVal, SizeOf(WordVal));
+ if Compression = CompressionRLE then
+ begin
+ RLETableOffset := GetIO.Tell(Handle);
+ GetIO.Write(Handle, @RLELengths[0], SizeOf(Word) * ImageToSave.Height * Info.ChannelCount);
+ end;
+ end;
+
+ for I := 0 to Info.ChannelCount - 1 do
+ begin
+ if SeparateChannelStorage then
+ begin
+ // Layer image data has compression flag and RLE lenghts table
+ // independent for each channel
+ WordVal := Swap(CompressionRLE);
+ GetIO.Write(Handle, @WordVal, SizeOf(WordVal));
+ if Compression = CompressionRLE then
+ begin
+ RLETableOffset := GetIO.Tell(Handle);
+ GetIO.Write(Handle, @RLELengths[0], SizeOf(Word) * ImageToSave.Height);
+ ChannelDataSizes[I] := 0;
+ end;
+ end;
+
+ // Now determine which color channel we are going to write to file.
+ if Info.HasAlphaChannel then
+ begin
+ if I = Info.ChannelCount - 1 then
+ CurrChannel := I
+ else
+ CurrChannel := Info.ChannelCount - 2 - I;
+ end
+ else
+ CurrChannel := Info.ChannelCount - 1 - I;
+
+ for Y := 0 to ImageToSave.Height - 1 do
+ begin
+ if Info.ChannelCount > 1 then
+ begin
+ // Copy each pixel fragment to its right place in destination image
+ for X := 0 to ImageToSave.Width - 1 do
+ begin
+ Move(PByteArray(ImageToSave.Bits)[Y * WidthBytes + X * Info.BytesPerPixel + CurrChannel * ChannelPixelSize],
+ PByteArray(LineBuffer)[X * ChannelPixelSize], ChannelPixelSize);
+ end;
+ end
+ else
+ Move(PByteArray(ImageToSave.Bits)[Y * LineSize], LineBuffer^, LineSize);
+
+ // Write current channel line to file (swap endian if needed first)
+ if ChannelPixelSize = 4 then
+ SwapEndianLongWord(PLongWord(LineBuffer), ImageToSave.Width)
+ else if ChannelPixelSize = 2 then
+ SwapEndianWord(PWordArray(LineBuffer), ImageToSave.Width);
+
+ if Compression = CompressionRLE then
+ begin
+ // Compress and write line
+ WrittenLineSize := PackLine(LineBuffer, RLEBuffer, LineSize);
+ {RLELineSize := 7;
+ RLEBuffer[0] := 129; RLEBuffer[1] := 255; RLEBuffer[2] := 131; RLEBuffer[3] := 100;
+ RLEBuffer[4] := 1; RLEBuffer[5] := 0; RLEBuffer[6] := 255;}
+ RLELengths[ImageToSave.Height * I + Y] := SwapEndianWord(WrittenLineSize);
+ GetIO.Write(Handle, RLEBuffer, WrittenLineSize);
+ end
+ else
+ begin
+ WrittenLineSize := LineSize;
+ GetIO.Write(Handle, LineBuffer, WrittenLineSize);
+ end;
+
+ if SeparateChannelStorage then
+ Inc(ChannelDataSizes[I], WrittenLineSize);
+ end;
+
+ if SeparateChannelStorage and (Compression = CompressionRLE) then
+ begin
+ // Update channel RLE lengths
+ CurrentOffset := GetIO.Tell(Handle);
+ GetIO.Seek(Handle, RLETableOffset, smFromBeginning);
+ GetIO.Write(Handle, @RLELengths[ImageToSave.Height * I], SizeOf(Word) * ImageToSave.Height);
+ GetIO.Seek(Handle, CurrentOffset, smFromBeginning);
+ Inc(ChannelDataSizes[I], SizeOf(Word) * ImageToSave.Height);
+ end;
+ end;
+
+ if not SeparateChannelStorage and (Compression = CompressionRLE) then
+ begin
+ // Update channel RLE lengths
+ CurrentOffset := GetIO.Tell(Handle);
+ GetIO.Seek(Handle, RLETableOffset, smFromBeginning);
+ GetIO.Write(Handle, @RLELengths[0], SizeOf(Word) * ImageToSave.Height * Info.ChannelCount);
+ GetIO.Seek(Handle, CurrentOffset, smFromBeginning);
+ end;
+
+ FreeMem(LineBuffer);
+ FreeMem(RLEBuffer);
+ end;
+
+begin
+ Result := False;
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with GetIO, ImageToSave do
+ try
+ Info := GetFormatInfo(Format);
+ ChannelPixelSize := Info.BytesPerPixel div Info.ChannelCount;
+
+ // Fill header with proper info and save it
+ FillChar(Header, SizeOf(Header), 0);
+ Header.Signature := SPSDMagic;
+ Header.Version := 1;
+ Header.Channels := Info.ChannelCount;
+ Header.Rows := Height;
+ Header.Columns := Width;
+ Header.Depth := Info.BytesPerPixel div Info.ChannelCount * 8;
+ if Info.IsIndexed then
+ Header.Mode := cmIndexed
+ else if Info.HasGrayChannel or (Info.ChannelCount = 1) then
+ Header.Mode := cmGrayscale
+ else
+ Header.Mode := cmRGB;
+
+ SwapHeader(Header);
+ Write(Handle, @Header, SizeOf(Header));
+
+ // Write palette size and data
+ LongVal := SwapEndianLongWord(IffUnsigned(Info.IsIndexed, SizeOf(RawPal), 0));
+ Write(Handle, @LongVal, SizeOf(LongVal));
+ if Info.IsIndexed then
+ begin
+ for I := 0 to Info.PaletteEntries - 1 do
+ begin
+ RawPal[I] := Palette[I].R;
+ RawPal[I + 256] := Palette[I].G;
+ RawPal[I + 512] := Palette[I].B;
+ end;
+ Write(Handle, @RawPal, SizeOf(RawPal));
+ end;
+
+ // Write empty resource and layer block sizes
+ LongVal := 0;
+ Write(Handle, @LongVal, SizeOf(LongVal));
+ LayerBlockOffset := Tell(Handle);
+ Write(Handle, @LongVal, SizeOf(LongVal));
+
+ if FSaveAsLayer and (ChannelPixelSize < 4) then // No Layers for FP32 images
+ begin
+ LayerCount := SwapEndianWord(Iff(Info.HasAlphaChannel, Word(-1), 1)); // Must be -1 to get transparency in Photoshop
+ R.Top := 0;
+ R.Left := 0;
+ R.Bottom := SwapEndianLongWord(Height);
+ R.Right := SwapEndianLongWord(Width);
+ WordVal := SwapEndianWord(Info.ChannelCount);
+ Write(Handle, @LongVal, SizeOf(LongVal)); // Layer section size, empty now
+ Write(Handle, @LayerCount, SizeOf(LayerCount)); // Layer count
+ Write(Handle, @R, SizeOf(R)); // Bounds rect
+ Write(Handle, @WordVal, SizeOf(WordVal)); // Channeel count
+
+ ChannelInfoOffset := Tell(Handle);
+ SetLength(ChannelDataSizes, Info.ChannelCount); // Empty channel infos
+ FillChar(ChannelInfo, SizeOf(ChannelInfo), 0);
+ for I := 0 to Info.ChannelCount - 1 do
+ Write(Handle, @ChannelInfo, SizeOf(ChannelInfo));
+
+ Write(Handle, @BlendMode, SizeOf(BlendMode)); // Blend mode = normal
+ Write(Handle, @LayerOptions, SizeOf(LayerOptions)); // Predefined options
+ LongVal := SwapEndianLongWord(16); // Extra data size (4 (mask size) + 4 (ranges size) + 8 (name))
+ Write(Handle, @LongVal, SizeOf(LongVal));
+ LongVal := 0;
+ Write(Handle, @LongVal, SizeOf(LongVal)); // Mask size = 0
+ LongVal := 0;
+ Write(Handle, @LongVal, SizeOf(LongVal)); // Blend ranges size
+ Write(Handle, @LayerName, SizeOf(LayerName)); // Layer name
+
+ WriteChannelData(True); // Write Layer image data
+
+ Write(Handle, @LongVal, SizeOf(LongVal)); // Global mask info size = 0
+
+ SaveOffset := Tell(Handle);
+ Seek(Handle, LayerBlockOffset, smFromBeginning);
+
+ // Update layer and mask section sizes
+ LongVal := SwapEndianLongWord(SaveOffset - LayerBlockOffset - 4);
+ Write(Handle, @LongVal, SizeOf(LongVal));
+ LongVal := SwapEndianLongWord(SaveOffset - LayerBlockOffset - 8);
+ Write(Handle, @LongVal, SizeOf(LongVal));
+
+ // Update layer channel info
+ Seek(Handle, ChannelInfoOffset, smFromBeginning);
+ for I := 0 to Info.ChannelCount - 1 do
+ begin
+ ChannelInfo.ChannelID := SwapEndianWord(I);
+ if (I = Info.ChannelCount - 1) and Info.HasAlphaChannel then
+ ChannelInfo.ChannelID := Swap(Word(-1));
+ ChannelInfo.Size := SwapEndianLongWord(ChannelDataSizes[I] + 2); // datasize (incl RLE table) + comp. flag
+ Write(Handle, @ChannelInfo, SizeOf(ChannelInfo));
+ end;
+
+ Seek(Handle, SaveOffset, smFromBeginning);
+ end;
+
+ // Write background merged image
+ WriteChannelData(False);
+
+ Result := True;
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+procedure TPSDFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsFloatingPoint then
+ ConvFormat := IffFormat(Info.ChannelCount = 1, ifR32F, ifA32R32G32B32F)
+ else if Info.HasGrayChannel then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
+ else if Info.RBSwapFormat in GetSupportedFormats then
+ ConvFormat := Info.RBSwapFormat
+ else
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TPSDFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Header: TPSDHeader;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ begin
+ ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
+ SwapHeader(Header);
+ GetIO.Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount >= SizeOf(Header)) and
+ (Header.Signature = SPSDMagic) and
+ (Header.Version = 1);
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(TPSDFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - PSDs are now saved with RLE compression.
+ - Mask layer saving added to SaveData for images with alpha
+ (shows proper transparency when opened in Photoshop). Can be
+ enabled/disabled using option
+ - Fixed memory leak in SaveData.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Saving implemented.
+ - Loading implemented.
+ - Unit created with initial stuff!
+}
+
+end.
diff --git a/src/lib/vampimg/ImagingTarga.pas b/src/lib/vampimg/ImagingTarga.pas
--- /dev/null
@@ -0,0 +1,622 @@
+{
+ $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z 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: TChar16; // 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.
diff --git a/src/lib/vampimg/ImagingTypes.pas b/src/lib/vampimg/ImagingTypes.pas
--- /dev/null
@@ -0,0 +1,499 @@
+{
+ $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z 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 = 26;
+ { Current patch of Imaging.}
+ ImagingVersionPatch = 4;
+
+ { 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;
+ { Boolean option that specifies whether PNG images with more frames (APNG format)
+ are animated by Imaging (according to frame disposal/blend methods) or just
+ raw frames are loaded and sent to user (if you want to animate APNG yourself).
+ Default value is 1.}
+ ImagingPNGLoadAnimated = 27;
+
+ { 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;
+ { Boolean option that specifies whether GIF images with more frames
+ are animated by Imaging (according to frame disposal methods) or just
+ raw frames are loaded and sent to user (if you want to animate GIF yourself).
+ Default value is 1.
+ Raw frames are 256 color indexed images (ifIndex8), whereas
+ animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).}
+ ImagingGIFLoadAnimated = 56;
+
+ { 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,
+ ifATI1N = 224,
+ ifATI2N = 225);
+
+ { 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
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Added ifATI1N and ifATI2N image data formats.
+
+ -- 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.
diff --git a/src/lib/vampimg/ImagingUtility.pas b/src/lib/vampimg/ImagingUtility.pas
--- /dev/null
@@ -0,0 +1,1522 @@
+{
+ $Id: ImagingUtility.pas 175 2009-10-06 11:55: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 utility functions and types for Imaging library.}
+unit ImagingUtility;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Classes, Types;
+
+const
+ STrue = 'True';
+ SFalse = 'False';
+
+type
+ TByteArray = array[0..MaxInt - 1] of Byte;
+ PByteArray = ^TByteArray;
+ TWordArray = array[0..MaxInt div 2 - 1] of Word;
+ PWordArray = ^TWordArray;
+ TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
+ PLongIntArray = ^TLongIntArray;
+ TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
+ PLongWordArray = ^TLongWordArray;
+ TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
+ PInt64Array = ^TInt64Array;
+ TSingleArray = array[0..MaxInt div 4 - 1] of Single;
+ PSingleArray = ^TSingleArray;
+ TBooleanArray = array[0..MaxInt - 1] of Boolean;
+ PBooleanArray = ^TBooleanArray;
+
+ TDynByteArray = array of Byte;
+ TDynIntegerArray = array of Integer;
+ TDynBooleanArray = array of Boolean;
+
+ TWordRec = packed record
+ case Integer of
+ 0: (WordValue: Word);
+ 1: (Low, High: Byte);
+ end;
+ PWordRec = ^TWordRec;
+ TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
+ PWordRecArray = ^TWordRecArray;
+
+ TLongWordRec = packed record
+ case Integer of
+ 0: (LongWordValue: LongWord);
+ 1: (Low, High: Word);
+ { Array variants - Index 0 means lowest significant byte (word, ...).}
+ 2: (Words: array[0..1] of Word);
+ 3: (Bytes: array[0..3] of Byte);
+ end;
+ PLongWordRec = ^TLongWordRec;
+ TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
+ PLongWordRecArray = ^TLongWordRecArray;
+
+ TInt64Rec = packed record
+ case Integer of
+ 0: (Int64Value: Int64);
+ 1: (Low, High: LongWord);
+ { Array variants - Index 0 means lowest significant byte (word, ...).}
+ 2: (Words: array[0..3] of Word);
+ 3: (Bytes: array[0..7] of Byte);
+ end;
+ PInt64Rec = ^TInt64Rec;
+ TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec;
+ PInt64RecArray = ^TInt64RecArray;
+
+ TFloatHelper = record
+ Data1: Int64;
+ Data2: Int64;
+ end;
+ PFloatHelper = ^TFloatHelper;
+
+ TChar2 = array[0..1] of AnsiChar;
+ TChar3 = array[0..2] of AnsiChar;
+ TChar4 = array[0..3] of AnsiChar;
+ TChar8 = array[0..7] of AnsiChar;
+ TChar16 = array[0..15] of AnsiChar;
+
+ { Options for BuildFileList function:
+ flFullNames - file names in result will have full path names
+ (ExtractFileDir(Path) + FileName)
+ flRelNames - file names in result will have names relative to
+ ExtractFileDir(Path) dir
+ flRecursive - adds files in subdirectories found in Path.}
+ TFileListOption = (flFullNames, flRelNames, flRecursive);
+ TFileListOptions = set of TFileListOption;
+
+
+{ Frees class instance and sets its reference to nil.}
+procedure FreeAndNil(var Obj);
+{ Frees pointer and sets it to nil.}
+procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Replacement of standard System.FreeMem procedure which checks if P is nil
+ (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).}
+procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns current exception object. Do not call outside exception handler.}
+function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns time value with microsecond resolution.}
+function GetTimeMicroseconds: Int64;
+{ Returns time value with milisecond resolution.}
+function GetTimeMilliseconds: Int64;
+
+{ Returns file extension (without "." dot)}
+function GetFileExt(const FileName: string): string;
+{ Returns file name of application's executable.}
+function GetAppExe: string;
+{ Returns directory where application's exceutable is located without
+ path delimiter at the end.}
+function GetAppDir: string;
+{ Returns True if FileName matches given Mask with optional case sensitivity.
+ Mask can contain ? and * special characters: ? matches
+ one character, * matches zero or more characters.}
+function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
+{ This function fills Files string list with names of files found
+ with FindFirst/FindNext functions (See details on Path/Atrr here).
+ - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
+ list of all files (only name.ext - no path) on C drive
+ - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns
+ list of all directories (d:\dirxxx) in root of D drive.}
+function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
+ Options: TFileListOptions = []): Boolean;
+{ Similar to RTL's Pos function but with optional Offset where search will start.
+ This function is in the RTL StrUtils unit but }
+function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
+{ Same as PosEx but without case sensitivity.}
+function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns a sub-string from S which is followed by
+ Sep separator and deletes the sub-string from S including the separator.}
+function StrToken(var S: string; Sep: Char): string;
+{ Same as StrToken but searches from the end of S string.}
+function StrTokenEnd(var S: string; Sep: Char): string;
+{ Fills instance of TStrings with tokens from string S where tokens are separated by
+ one of Seps characters.}
+procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
+{ Returns string representation of integer number (with digit grouping).}
+function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns string representation of float number (with digit grouping).}
+function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Clamps integer value to range <Min, Max>}
+function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Clamps float value to range <Min, Max>}
+function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Clamps integer value to Byte boundaries.}
+function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Clamps integer value to Word boundaries.}
+function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns True if Num is power of 2.}
+function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns next power of 2 greater than or equal to Num
+ (if Num itself is power of 2 then it retuns Num).}
+function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Raises 2 to the given integer power (in range [0, 30]).}
+function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Raises Base to any power.}
+function Power(const Base, Exponent: Single): Single;
+{ Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.}
+function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns log base 2 of X.}
+function Log2(X: Single): Single;
+{ Returns largest integer <= Val (for 5.9 returns 5).}
+function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns smallest integer >= Val (for 5.1 returns 6).}
+function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns lesser of two integer numbers.}
+function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns lesser of two float numbers.}
+function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns greater of two integer numbers.}
+function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns greater of two float numbers.}
+function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns result from multiplying Number by Numerator and then dividing by Denominator.
+ Denominator must be greater than 0.}
+function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Switches Boolean value.}
+procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ If Condition is True then TruePart is retured, otherwise
+ FalsePart is returned.}
+function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Swaps two Byte values}
+procedure SwapValues(var A, B: Byte); overload;
+{ Swaps two Word values}
+procedure SwapValues(var A, B: Word); overload;
+{ Swaps two LongInt values}
+procedure SwapValues(var A, B: LongInt); overload;
+{ Swaps two Single values}
+procedure SwapValues(var A, B: Single); overload;
+{ Swaps two LongInt values if necessary to ensure that Min <= Max.}
+procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ This function returns True if running on little endian machine.}
+function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Swaps byte order of Word value.}
+function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Swaps byte order of multiple Word values.}
+procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
+{ Swaps byte order of LongWord value.}
+function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Swaps byte order of multiple LongWord values.}
+procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
+
+{ Calculates CRC32 for the given data.}
+procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
+{ Fills given memory with given Byte value. Size is size of buffer in bytes.}
+procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
+{ Fills given memory with given Word value. Size is size of buffer in bytes.}
+procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
+{ Fills given memory with given LongWord value. Size is size of buffer in bytes.}
+procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
+
+{ Returns how many mipmap levels can be created for image of given size.}
+function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
+{ Returns total number of levels of volume texture with given depth and
+ mipmap count (this is not depth * mipmaps!).}
+function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
+{ Returns rectangle (X, Y, X + Width, Y + Height).}
+function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).}
+function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).}
+function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Clips given bounds to Clip rectangle.}
+procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
+{ Clips given source bounds and dest position. It is used by various CopyRect
+ functions that copy rect from one image to another. It handles clipping the same way
+ as Win32 BitBlt function. }
+procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt;
+ SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
+{ Clips given source bounds and dest bounds. It is used by various StretchRect
+ functions that stretch rectangle of pixels from one image to another.
+ It handles clipping the same way as Win32 StretchBlt function. }
+procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
+ DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
+{ Scales one rectangle to fit into another. Proportions are preserved so
+ it could be used for 'Stretch To Fit Window' image drawing for instance.}
+function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
+{ Returns True if R1 fits into R2.}
+function RectInRect(const R1, R2: TRect): Boolean;
+{ Returns True if R1 and R2 intersects.}
+function RectIntersects(const R1, R2: TRect): Boolean;
+
+{ Formats given message for usage in Exception.Create(..). Use only
+ in except block - returned message contains message of last raised exception.}
+function FormatExceptMsg(const Msg: string; const Args: array of const): string;
+{ Outputs debug message - shows message dialog in Windows and writes to console
+ in Linux/Unix.}
+procedure DebugMsg(const Msg: string; const Args: array of const);
+
+implementation
+
+uses
+{$IFDEF MSWINDOWS}
+ Windows;
+{$ENDIF}
+{$IFDEF UNIX}
+ {$IFDEF KYLIX}
+ Libc;
+ {$ELSE}
+ Dos, BaseUnix, Unix;
+ {$ENDIF}
+{$ENDIF}
+
+procedure FreeAndNil(var Obj);
+var
+ Temp: TObject;
+begin
+ Temp := TObject(Obj);
+ Pointer(Obj) := nil;
+ Temp.Free;
+end;
+
+procedure FreeMemNil(var P);
+begin
+ FreeMem(Pointer(P));
+ Pointer(P) := nil;
+end;
+
+procedure FreeMem(P: Pointer);
+begin
+ if P <> nil then
+ System.FreeMem(P);
+end;
+
+function GetExceptObject: Exception;
+begin
+ Result := Exception(ExceptObject);
+end;
+
+{$IFDEF MSWINDOWS}
+var
+ PerfFrequency: Int64;
+ InvPerfFrequency: Single;
+
+function GetTimeMicroseconds: Int64;
+var
+ Time: Int64;
+begin
+ QueryPerformanceCounter(Time);
+ Result := Round(1000000 * InvPerfFrequency * Time);
+end;
+{$ENDIF}
+
+{$IFDEF UNIX}
+function GetTimeMicroseconds: Int64;
+var
+ TimeVal: TTimeVal;
+begin
+ {$IFDEF KYLIX}
+ GetTimeOfDay(TimeVal, nil);
+ {$ELSE}
+ fpGetTimeOfDay(@TimeVal, nil);
+ {$ENDIF}
+ Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
+end;
+{$ENDIF}
+
+{$IFDEF MSDOS}
+function GetTimeMicroseconds: Int64;
+asm
+ XOR EAX, EAX
+ CLI
+ OUT $43, AL
+ MOV EDX, FS:[$46C]
+ IN AL, $40
+ DB $EB, 0, $EB, 0, $EB, 0
+ MOV AH, AL
+ IN AL, $40
+ DB $EB, 0, $EB, 0, $EB, 0
+ XCHG AL, AH
+ NEG AX
+ MOVZX EDI, AX
+ STI
+ MOV EBX, $10000
+ MOV EAX, EDX
+ XOR EDX, EDX
+ MUL EBX
+ ADD EAX, EDI
+ ADC EDX, 0
+ PUSH EDX
+ PUSH EAX
+ MOV ECX, $82BF1000
+ MOVZX EAX, WORD PTR FS:[$470]
+ MUL ECX
+ MOV ECX, EAX
+ POP EAX
+ POP EDX
+ ADD EAX, ECX
+ ADC EDX, 0
+end;
+{$ENDIF}
+
+function GetTimeMilliseconds: Int64;
+begin
+ Result := GetTimeMicroseconds div 1000;
+end;
+
+function GetFileExt(const FileName: string): string;
+begin
+ Result := ExtractFileExt(FileName);
+ if Length(Result) > 1 then
+ Delete(Result, 1, 1);
+end;
+
+function GetAppExe: string;
+{$IFDEF MSWINDOWS}
+var
+ FileName: array[0..MAX_PATH] of Char;
+begin
+ SetString(Result, FileName,
+ Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
+{$ENDIF}
+{$IFDEF UNIX}
+ {$IFDEF KYLIX}
+var
+ FileName: array[0..FILENAME_MAX] of Char;
+begin
+ SetString(Result, FileName,
+ System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
+ {$ELSE}
+begin
+ Result := FExpand(ParamStr(0));
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF MSDOS}
+begin
+ Result := ParamStr(0);
+{$ENDIF}
+end;
+
+function GetAppDir: string;
+begin
+ Result := ExtractFileDir(GetAppExe);
+end;
+
+function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
+var
+ MaskLen, KeyLen : LongInt;
+
+ function CharMatch(A, B: Char): Boolean;
+ begin
+ if CaseSensitive then
+ Result := A = B
+ else
+ Result := AnsiUpperCase (A) = AnsiUpperCase (B);
+ end;
+
+ function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
+ begin
+ while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do
+ begin
+ case Mask[MaskPos] of
+ '?' :
+ begin
+ Inc(MaskPos);
+ Inc(KeyPos);
+ end;
+ '*' :
+ begin
+ while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do
+ Inc(MaskPos);
+ if MaskPos > MaskLen then
+ begin
+ Result := True;
+ Exit;
+ end;
+ repeat
+ if MatchAt(MaskPos, KeyPos) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Inc(KeyPos);
+ until KeyPos > KeyLen;
+ Result := False;
+ Exit;
+ end;
+ else
+ if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
+ begin
+ Result := False;
+ Exit;
+ end
+ else
+ begin
+ Inc(MaskPos);
+ Inc(KeyPos);
+ end;
+ end;
+ end;
+
+ while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
+ Inc(MaskPos);
+ if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ Result := True;
+ end;
+
+begin
+ MaskLen := Length(Mask);
+ KeyLen := Length(FileName);
+ if MaskLen = 0 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Result := MatchAt(1, 1);
+end;
+
+function BuildFileList(Path: string; Attr: LongInt;
+ Files: TStrings; Options: TFileListOptions): Boolean;
+var
+ FileMask: string;
+ RootDir: string;
+ Folders: TStringList;
+ CurrentItem: LongInt;
+ Counter: LongInt;
+ LocAttr: LongInt;
+
+ procedure BuildFolderList;
+ var
+ FindInfo: TSearchRec;
+ Rslt: LongInt;
+ begin
+ Counter := Folders.Count - 1;
+ CurrentItem := 0;
+ while CurrentItem <= Counter do
+ begin
+ // Searching for subfolders
+ Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo);
+ try
+ while Rslt = 0 do
+ begin
+ if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and
+ (FindInfo.Attr and faDirectory = faDirectory) then
+ Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim);
+ Rslt := SysUtils.FindNext(FindInfo);
+ end;
+ finally
+ SysUtils.FindClose(FindInfo);
+ end;
+ Counter := Folders.Count - 1;
+ Inc(CurrentItem);
+ end;
+ end;
+
+ procedure FillFileList(CurrentCounter: LongInt);
+ var
+ FindInfo: TSearchRec;
+ Res: LongInt;
+ CurrentFolder: string;
+ begin
+ CurrentFolder := Folders[CurrentCounter];
+ Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo);
+ if flRelNames in Options then
+ CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder);
+ try
+ while Res = 0 do
+ begin
+ if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then
+ begin
+ if (flFullNames in Options) or (flRelNames in Options) then
+ Files.Add(CurrentFolder + FindInfo.Name)
+ else
+ Files.Add(FindInfo.Name);
+ end;
+ Res := SysUtils.FindNext(FindInfo);
+ end;
+ finally
+ SysUtils.FindClose(FindInfo);
+ end;
+ end;
+
+begin
+ FileMask := ExtractFileName(Path);
+ RootDir := ExtractFilePath(Path);
+ Folders := TStringList.Create;
+ Folders.Add(RootDir);
+ Files.Clear;
+{$IFDEF DCC}
+ {$WARN SYMBOL_PLATFORM OFF}
+{$ENDIF}
+ if Attr = faAnyFile then
+ LocAttr := faSysFile or faHidden or faArchive or faReadOnly
+ else
+ LocAttr := Attr;
+{$IFDEF DCC}
+ {$WARN SYMBOL_PLATFORM ON}
+{$ENDIF}
+ // Here's the recursive search for nested folders
+ if flRecursive in Options then
+ BuildFolderList;
+ if Attr <> faDirectory then
+ for Counter := 0 to Folders.Count - 1 do
+ FillFileList(Counter)
+ else
+ Files.AddStrings(Folders);
+ Folders.Free;
+ Result := True;
+end;
+
+function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
+var
+ I, X: LongInt;
+ Len, LenSubStr: LongInt;
+begin
+ I := Offset;
+ LenSubStr := Length(SubStr);
+ Len := Length(S) - LenSubStr + 1;
+ while I <= Len do
+ begin
+ if S[I] = SubStr[1] then
+ begin
+ X := 1;
+ while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
+ Inc(X);
+ if (X = LenSubStr) then
+ begin
+ Result := I;
+ Exit;
+ end;
+ end;
+ Inc(I);
+ end;
+ Result := 0;
+end;
+
+function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
+begin
+ Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
+end;
+
+function StrToken(var S: string; Sep: Char): string;
+var
+ I: LongInt;
+begin
+ I := Pos(Sep, S);
+ if I <> 0 then
+ begin
+ Result := Copy(S, 1, I - 1);
+ Delete(S, 1, I);
+ end
+ else
+ begin
+ Result := S;
+ S := '';
+ end;
+end;
+
+function StrTokenEnd(var S: string; Sep: Char): string;
+var
+ I, J: LongInt;
+begin
+ J := 0;
+ I := Pos(Sep, S);
+ while I <> 0 do
+ begin
+ J := I;
+ I := PosEx(Sep, S, J + 1);
+ end;
+ if J <> 0 then
+ begin
+ Result := Copy(S, J + 1, MaxInt);
+ Delete(S, J, MaxInt);
+ end
+ else
+ begin
+ Result := S;
+ S := '';
+ end;
+end;
+
+procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
+var
+ Token, Str: string;
+begin
+ Tokens.Clear;
+ Str := S;
+ while Str <> '' do
+ begin
+ Token := StrToken(Str, Sep);
+ Tokens.Add(Token);
+ end;
+end;
+
+function IntToStrFmt(const I: Int64): string;
+begin
+ Result := Format('%.0n', [I * 1.0]);
+end;
+
+function FloatToStrFmt(const F: Double; Precision: Integer): string;
+begin
+ Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
+end;
+
+function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
+begin
+ Result := Number;
+ if Result < Min then
+ Result := Min
+ else if Result > Max then
+ Result := Max;
+end;
+
+function ClampFloat(Number: Single; Min, Max: Single): Single;
+begin
+ Result := Number;
+ if Result < Min then
+ Result := Min
+ else if Result > Max then
+ Result := Max;
+end;
+
+function ClampToByte(Value: LongInt): LongInt;
+begin
+ Result := Value;
+ if Result > 255 then
+ Result := 255
+ else if Result < 0 then
+ Result := 0;
+end;
+
+function ClampToWord(Value: LongInt): LongInt;
+begin
+ Result := Value;
+ if Result > 65535 then
+ Result := 65535
+ else if Result < 0 then
+ Result := 0;
+end;
+
+function IsPow2(Num: LongInt): Boolean;
+begin
+ Result := (Num and -Num) = Num;
+end;
+
+function NextPow2(Num: LongInt): LongInt;
+begin
+ Result := Num and -Num;
+ while Result < Num do
+ Result := Result shl 1;
+end;
+
+function Pow2Int(Exponent: LongInt): LongInt;
+begin
+ Result := 1 shl Exponent;
+end;
+
+function Power(const Base, Exponent: Single): Single;
+begin
+ if Exponent = 0.0 then
+ Result := 1.0
+ else if (Base = 0.0) and (Exponent > 0.0) then
+ Result := 0.0
+ else
+ Result := Exp(Exponent * Ln(Base));
+end;
+
+function Log2Int(X: LongInt): LongInt;
+begin
+ case X of
+ 1: Result := 0;
+ 2: Result := 1;
+ 4: Result := 2;
+ 8: Result := 3;
+ 16: Result := 4;
+ 32: Result := 5;
+ 64: Result := 6;
+ 128: Result := 7;
+ 256: Result := 8;
+ 512: Result := 9;
+ 1024: Result := 10;
+ 2048: Result := 11;
+ 4096: Result := 12;
+ 8192: Result := 13;
+ 16384: Result := 14;
+ 32768: Result := 15;
+ 65536: Result := 16;
+ 131072: Result := 17;
+ 262144: Result := 18;
+ 524288: Result := 19;
+ 1048576: Result := 20;
+ 2097152: Result := 21;
+ 4194304: Result := 22;
+ 8388608: Result := 23;
+ 16777216: Result := 24;
+ 33554432: Result := 25;
+ 67108864: Result := 26;
+ 134217728: Result := 27;
+ 268435456: Result := 28;
+ 536870912: Result := 29;
+ 1073741824: Result := 30;
+ else
+ Result := -1;
+ end;
+end;
+
+function Log2(X: Single): Single;
+const
+ Ln2: Single = 0.6931471;
+begin
+ Result := Ln(X) / Ln2;
+end;
+
+function Floor(Value: Single): LongInt;
+begin
+ Result := Trunc(Value);
+ if Frac(Value) < 0.0 then
+ Dec(Result);
+end;
+
+function Ceil(Value: Single): LongInt;
+begin
+ Result := Trunc(Value);
+ if Frac(Value) > 0.0 then
+ Inc(Result);
+end;
+
+procedure Switch(var Value: Boolean);
+begin
+ Value := not Value;
+end;
+
+function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function Iff(Condition, TruePart, FalsePart: Boolean): Boolean;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function Iff(Condition: Boolean; const TruePart, FalsePart: string): string;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single;
+begin
+ if Condition then
+ Result := TruePart
+ else
+ Result := FalsePart;
+end;
+
+procedure SwapValues(var A, B: Byte);
+var
+ Tmp: Byte;
+begin
+ Tmp := A;
+ A := B;
+ B := Tmp;
+end;
+
+procedure SwapValues(var A, B: Word);
+var
+ Tmp: Word;
+begin
+ Tmp := A;
+ A := B;
+ B := Tmp;
+end;
+
+procedure SwapValues(var A, B: LongInt);
+var
+ Tmp: LongInt;
+begin
+ Tmp := A;
+ A := B;
+ B := Tmp;
+end;
+
+procedure SwapValues(var A, B: Single);
+var
+ Tmp: Single;
+begin
+ Tmp := A;
+ A := B;
+ B := Tmp;
+end;
+
+procedure SwapMin(var Min, Max: LongInt);
+var
+ Tmp: LongInt;
+begin
+ if Min > Max then
+ begin
+ Tmp := Min;
+ Min := Max;
+ Max := Tmp;
+ end;
+end;
+
+function Min(A, B: LongInt): LongInt;
+begin
+ if A < B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MinFloat(A, B: Single): Single;
+begin
+ if A < B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function Max(A, B: LongInt): LongInt;
+begin
+ if A > B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MaxFloat(A, B: Single): Single;
+begin
+ if A > B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MulDiv(Number, Numerator, Denominator: Word): Word;
+{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
+asm
+ MUL DX
+ DIV CX
+end;
+{$ELSE}
+begin
+ Result := Number * Numerator div Denominator;
+end;
+{$IFEND}
+
+function IsLittleEndian: Boolean;
+var
+ W: Word;
+begin
+ W := $00FF;
+ Result := PByte(@W)^ = $FF;
+end;
+
+function SwapEndianWord(Value: Word): Word;
+{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
+asm
+ XCHG AH, AL
+end;
+{$ELSE}
+begin
+ TWordRec(Result).Low := TWordRec(Value).High;
+ TWordRec(Result).High := TWordRec(Value).Low;
+end;
+{$IFEND}
+
+procedure SwapEndianWord(P: PWordArray; Count: LongInt);
+{$IFDEF USE_ASM}
+asm
+@Loop:
+ MOV CX, [EAX]
+ XCHG CH, CL
+ MOV [EAX], CX
+ ADD EAX, 2
+ DEC EDX
+ JNZ @Loop
+end;
+{$ELSE}
+var
+ I: LongInt;
+ Temp: Word;
+begin
+ for I := 0 to Count - 1 do
+ begin
+ Temp := P[I];
+ TWordRec(P[I]).Low := TWordRec(Temp).High;
+ TWordRec(P[I]).High := TWordRec(Temp).Low;
+ end;
+end;
+{$ENDIF}
+
+function SwapEndianLongWord(Value: LongWord): LongWord;
+{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
+asm
+ BSWAP EAX
+end;
+{$ELSE}
+begin
+ TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
+ TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
+ TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
+ TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
+end;
+{$IFEND}
+
+procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
+{$IFDEF USE_ASM}
+asm
+@Loop:
+ MOV ECX, [EAX]
+ BSWAP ECX
+ MOV [EAX], ECX
+ ADD EAX, 4
+ DEC EDX
+ JNZ @Loop
+end;
+{$ELSE}
+var
+ I: LongInt;
+ Temp: LongWord;
+begin
+ for I := 0 to Count - 1 do
+ begin
+ Temp := PLongWordArray(P)[I];
+ TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
+ TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
+ TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
+ TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
+ end;
+end;
+{$ENDIF}
+
+type
+ TCrcTable = array[Byte] of LongWord;
+var
+ CrcTable: TCrcTable;
+
+procedure InitCrcTable;
+const
+ Polynom = $EDB88320;
+var
+ I, J: LongInt;
+ C: LongWord;
+begin
+ for I := 0 to 255 do
+ begin
+ C := I;
+ for J := 0 to 7 do
+ begin
+ if (C and $01) <> 0 then
+ C := Polynom xor (C shr 1)
+ else
+ C := C shr 1;
+ end;
+ CrcTable[I] := C;
+ end;
+end;
+
+procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
+var
+ I: LongInt;
+ B: PByte;
+begin
+ B := Data;
+ for I := 0 to Size - 1 do
+ begin
+ Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)];
+ Inc(B);
+ end
+end;
+
+procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
+{$IFDEF USE_ASM}
+asm
+ PUSH EDI
+ MOV EDI, EAX
+ MOV EAX, ECX
+ MOV AH, AL
+ MOV CX, AX
+ SHL EAX, 16
+ MOV AX, CX
+ MOV ECX, EDX
+ SAR ECX, 2
+ JS @Exit
+ REP STOSD
+ MOV ECX, EDX
+ AND ECX, 3
+ REP STOSB
+ POP EDI
+@Exit:
+end;
+{$ELSE}
+begin
+ FillChar(Data^, Size, Value);
+end;
+{$ENDIF}
+
+procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
+{$IFDEF USE_ASM}
+asm
+ PUSH EDI
+ PUSH EBX
+ MOV EBX, EDX
+ MOV EDI, EAX
+ MOV EAX, ECX
+ MOV CX, AX
+ SHL EAX, 16
+ MOV AX, CX
+ MOV ECX, EDX
+ SHR ECX, 2
+ JZ @Word
+ REP STOSD
+@Word:
+ MOV ECX, EBX
+ AND ECX, 2
+ JZ @Byte
+ MOV [EDI], AX
+ ADD EDI, 2
+@Byte:
+ MOV ECX, EBX
+ AND ECX, 1
+ JZ @Exit
+ MOV [EDI], AL
+@Exit:
+ POP EBX
+ POP EDI
+end;
+{$ELSE}
+var
+ I, V: LongWord;
+begin
+ V := Value * $10000 + Value;
+ for I := 0 to Size div 4 - 1 do
+ PLongWordArray(Data)[I] := V;
+ case Size mod 4 of
+ 1: PByteArray(Data)[Size - 1] := Lo(Value);
+ 2: PWordArray(Data)[Size div 2] := Value;
+ 3:
+ begin
+ PWordArray(Data)[Size div 2 - 1] := Value;
+ PByteArray(Data)[Size - 1] := Lo(Value);
+ end;
+ end;
+end;
+{$ENDIF}
+
+procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
+{$IFDEF USE_ASM}
+asm
+ PUSH EDI
+ PUSH EBX
+ MOV EBX, EDX
+ MOV EDI, EAX
+ MOV EAX, ECX
+ MOV ECX, EDX
+ SHR ECX, 2
+ JZ @Word
+ REP STOSD
+@Word:
+ MOV ECX, EBX
+ AND ECX, 2
+ JZ @Byte
+ MOV [EDI], AX
+ ADD EDI, 2
+@Byte:
+ MOV ECX, EBX
+ AND ECX, 1
+ JZ @Exit
+ MOV [EDI], AL
+@Exit:
+ POP EBX
+ POP EDI
+end;
+{$ELSE}
+var
+ I: LongInt;
+begin
+ for I := 0 to Size div 4 - 1 do
+ PLongWordArray(Data)[I] := Value;
+ case Size mod 4 of
+ 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
+ 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
+ 3:
+ begin
+ PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
+ PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
+ end;
+ end;
+end;
+{$ENDIF}
+
+function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
+begin
+ Result := 0;
+ if (Width > 0) and (Height > 0) then
+ begin
+ Result := 1;
+ while (Width <> 1) or (Height <> 1) do
+ begin
+ Width := Width div 2;
+ Height := Height div 2;
+ if Width < 1 then Width := 1;
+ if Height < 1 then Height := 1;
+ Inc(Result);
+ end;
+ end;
+end;
+
+function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
+var
+ I: LongInt;
+begin
+ Result := Depth;
+ for I := 1 to MipMaps - 1 do
+ Inc(Result, ClampInt(Depth shr I, 1, Depth));
+end;
+
+function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
+begin
+ Result.Left := X;
+ Result.Top := Y;
+ Result.Right := X + Width;
+ Result.Bottom := Y + Height;
+end;
+
+function BoundsToRect(const R: TRect): TRect;
+begin
+ Result.Left := R.Left;
+ Result.Top := R.Top;
+ Result.Right := R.Left + R.Right;
+ Result.Bottom := R.Top + R.Bottom;
+end;
+
+function RectToBounds(const R: TRect): TRect;
+begin
+ Result.Left := R.Left;
+ Result.Top := R.Top;
+ Result.Right := R.Right - R.Left;
+ Result.Bottom := R.Bottom - R.Top;
+end;
+
+procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
+
+ procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt);
+ begin
+ if AStart < ClipMin then
+ begin
+ ALength := ALength - (ClipMin - AStart);
+ AStart := ClipMin;
+ end;
+ if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart);
+ end;
+
+begin
+ ClipDim(X, Width, Clip.Left, Clip.Right);
+ ClipDim(Y, Height, Clip.Top, Clip.Bottom);
+end;
+
+procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
+
+ procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax,
+ DstClipMin, DstClipMax: LongInt);
+ var
+ OldDstPos: LongInt;
+ Diff: LongInt;
+ begin
+ OldDstPos := Iff(DstPos < 0, DstPos, 0);
+ if DstPos < DstClipMin then
+ begin
+ Diff := DstClipMin - DstPos;
+ Size := Size - Diff;
+ SrcPos := SrcPos + Diff;
+ DstPos := DstClipMin;
+ end;
+ if SrcPos < 0 then
+ begin
+ Size := Size + SrcPos - OldDstPos;
+ DstPos := DstPos - SrcPos + OldDstPos;
+ SrcPos := 0;
+ end;
+ if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos;
+ if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos;
+ end;
+
+begin
+ ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right);
+ ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom);
+end;
+
+procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
+ DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
+
+ procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax,
+ DstClipMin, DstClipMax: LongInt);
+ var
+ OldSize: LongInt;
+ Diff: LongInt;
+ Scale: Single;
+ begin
+ Scale := DstSize / SrcSize;
+ if DstPos < DstClipMin then
+ begin
+ Diff := DstClipMin - DstPos;
+ DstSize := DstSize - Diff;
+ SrcPos := SrcPos + Round(Diff / Scale);
+ SrcSize := SrcSize - Round(Diff / Scale);
+ DstPos := DstClipMin;
+ end;
+ if SrcPos < 0 then
+ begin
+ SrcSize := SrcSize + SrcPos;
+ DstPos := DstPos - Round(SrcPos * Scale);
+ DstSize := DstSize + Round(SrcPos * Scale);
+ SrcPos := 0;
+ end;
+ if SrcPos + SrcSize > SrcClipMax then
+ begin
+ OldSize := SrcSize;
+ SrcSize := SrcClipMax - SrcPos;
+ DstSize := Round(DstSize * (SrcSize / OldSize));
+ end;
+ if DstPos + DstSize > DstClipMax then
+ begin
+ OldSize := DstSize;
+ DstSize := DstClipMax - DstPos;
+ SrcSize := Round(SrcSize * (DstSize / OldSize));
+ end;
+ end;
+
+begin
+ ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right);
+ ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom);
+end;
+
+function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
+var
+ SourceWidth: LongInt;
+ SourceHeight: LongInt;
+ TargetWidth: LongInt;
+ TargetHeight: LongInt;
+ ScaledWidth: LongInt;
+ ScaledHeight: LongInt;
+begin
+ SourceWidth := SourceRect.Right - SourceRect.Left;
+ SourceHeight := SourceRect.Bottom - SourceRect.Top;
+ TargetWidth := TargetRect.Right - TargetRect.Left;
+ TargetHeight := TargetRect.Bottom - TargetRect.Top;
+
+ if SourceWidth * TargetHeight < SourceHeight * TargetWidth then
+ begin
+ ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight;
+ Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2),
+ TargetRect.Top, ScaledWidth, TargetHeight);
+ end
+ else
+ begin
+ ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth;
+ Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2),
+ TargetWidth, ScaledHeight);
+ end;
+end;
+
+function RectInRect(const R1, R2: TRect): Boolean;
+begin
+ Result:=
+ (R1.Left >= R2.Left) and
+ (R1.Top >= R2.Top) and
+ (R1.Right <= R2.Right) and
+ (R1.Bottom <= R2.Bottom);
+end;
+
+function RectIntersects(const R1, R2: TRect): Boolean;
+begin
+ Result :=
+ not (R1.Left > R2.Right) and
+ not (R1.Top > R2.Bottom) and
+ not (R1.Right < R2.Left) and
+ not (R1.Bottom < R2.Top);
+end;
+
+function FormatExceptMsg(const Msg: string; const Args: array of const): string;
+begin
+ Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
+end;
+
+procedure DebugMsg(const Msg: string; const Args: array of const);
+var
+ FmtMsg: string;
+begin
+ FmtMsg := Format(Msg, Args);
+{$IFDEF MSWINDOWS}
+ if IsConsole then
+ WriteLn('DebugMsg: ' + FmtMsg)
+ else
+ MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK);
+{$ENDIF}
+{$IFDEF UNIX}
+ WriteLn('DebugMsg: ' + FmtMsg);
+{$ENDIF}
+{$IFDEF MSDOS}
+ WriteLn('DebugMsg: ' + FmtMsg);
+{$ENDIF}
+end;
+
+initialization
+ InitCrcTable;
+{$IFDEF MSWINDOWS}
+ QueryPerformanceFrequency(PerfFrequency);
+ InvPerfFrequency := 1.0 / PerfFrequency;
+{$ENDIF}
+{$IFDEF MSDOS}
+ // reset PIT
+ asm
+ MOV EAX, $34
+ OUT $43, AL
+ XOR EAX, EAX
+ OUT $40, AL
+ OUT $40, AL
+ end;
+{$ENDIF}
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.1 Changes/Bug Fixes -----------------------------------
+ - Some formatting changes.
+ - Changed some string functions to work with localized strings.
+ - ASM version of PosEx had bugs, removed it.
+ - Added StrTokensToList function.
+
+ -- 0.25.0 Changes/Bug Fixes -----------------------------------
+ - Fixed error in ClipCopyBounds which was causing ... bad clipping!
+
+ -- 0.24.3 Changes/Bug Fixes -----------------------------------
+ - Added GetTimeMilliseconds function.
+ - Added IntToStrFmt and FloatToStrFmt helper functions.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added RectInRect and RectIntersects functions
+ - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.
+ - Moved BuildFileList here from DemoUtils.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Moved GetVolumeLevelCount from ImagingDds here.
+ - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder.
+ - Added Iff function for Char, Pointer, and Int64 types.
+ - Added IsLittleEndian function.
+ - Added array types for TWordRec, TLongWordRec, and TInt64Rec.
+ - Added MatchFileNameMask function.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added ScaleRectToRect (thanks to Paul Michell)
+ - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions
+ - added MulDiv function
+ - FreeAndNil is not inline anymore - caused AV in one program
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+
+ - GetAppExe didn't return absolute path in FreeBSD, fixed
+ - added debug message output
+ - fixed Unix compatibility issues (thanks to Ales Katona).
+ Imaging now compiles in FreeBSD and maybe in other Unixes as well.
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - added some new utility functions
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - added many new utility functions
+ - minor change in SwapEndian to avoid range check error
+
+}
+end.
diff --git a/src/lib/vampimg/ImagingXpm.pas b/src/lib/vampimg/ImagingXpm.pas
--- /dev/null
@@ -0,0 +1,583 @@
+{
+ $Id: ImagingXpm.pas 171 2009-09-02 01:34:19Z 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 for X Window Pixmap images. }
+unit ImagingXpm;
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Classes, Contnrs, ImagingTypes, Imaging, ImagingUtility,
+ ImagingFormats, ImagingIO, ImagingCanvases;
+
+type
+ { Class for loading X Window Pixmap images known as XPM.
+ It is ASCII-text-based format, basicaly a fragment of C code
+ declaring static array. Loaded image is in ifA8R8G8B8 data format.
+ Loading as well as saving is supported now. }
+ TXPMFileFormat = class(TImageFileFormat)
+ 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
+ SXPMFormatName = 'X Window Pixmap';
+ SXPMMasks = '*.xpm';
+ XPMSupportedFormats: TImageFormats = [ifA8R8G8B8];
+
+const
+ SXPMId = '/* XPM */';
+ WhiteSpaces = [#9, #10, #13, #32];
+
+const
+ BucketCount = 257;
+
+type
+ TColorHolder = class
+ public
+ Color: TColor32;
+ end;
+
+ TBucketItem = record
+ Key: TColor32;
+ Data: string[8];
+ end;
+
+ TBucketItemArray = array of TBucketItem;
+
+ TBucket = record
+ Count: Integer;
+ ItemIdxStart: Integer;
+ Items: TBucketItemArray;
+ end;
+
+ TBucketArray = array of TBucket;
+
+ { Simple color-string hash table for faster than linear searches
+ during XPM saving. }
+ TSimpleBucketList = class
+ private
+ FBuckets: TBucketArray;
+ FItemCount: Integer;
+ FABucket, FAIndex: Integer;
+ function GetData(AKey: TColor32): string;
+ procedure SetData(AKey: TColor32; const AData: string);
+ function FindItem(AKey: TColor32; out ABucket, AIndex: Integer): Boolean;
+ public
+ constructor Create;
+ procedure Add(AKey: TColor32; const AData: string);
+ function Exists(AKey: TColor32): Boolean;
+ function EnumNext(out AData: string): TColor32;
+ property Data[AKey: TColor32]: string read GetData write SetData; default;
+ property ItemCount: Integer read FItemCount;
+ end;
+
+ { TSimpleBucketList }
+
+constructor TSimpleBucketList.Create;
+begin
+ SetLength(FBuckets, BucketCount);
+end;
+
+function TSimpleBucketList.GetData(AKey: TColor32): string;
+var
+ Bucket, Index: Integer;
+begin
+ Result := '';
+ if FindItem(AKey, Bucket, Index) then
+ Result := FBuckets[Bucket].Items[Index].Data;
+end;
+
+procedure TSimpleBucketList.SetData(AKey: TColor32; const AData: string);
+var
+ Bucket, Index: Integer;
+begin
+ if FindItem(AKey, Bucket, Index) then
+ FBuckets[Bucket].Items[Index].Data := AData;
+end;
+
+function TSimpleBucketList.EnumNext(out AData: string): TColor32;
+begin
+ // Skip empty buckets
+ while FAIndex >= FBuckets[FABucket].Count do
+ begin
+ Inc(FABucket);
+ if FABucket >= Length(FBuckets) then
+ FABucket := 0;
+ FAIndex := 0;
+ end;
+
+ Result := FBuckets[FABucket].Items[FAIndex].Key;
+ AData := FBuckets[FABucket].Items[FAIndex].Data;
+ Inc(FAIndex);
+end;
+
+function TSimpleBucketList.FindItem(AKey: TColor32; out ABucket,
+ AIndex: Integer): Boolean;
+var
+ I: Integer;
+ Col: TColor32Rec;
+begin
+ Result := False;
+ Col := TColor32Rec(AKey);
+ ABucket := (Col.A + 11 * Col.B + 59 * Col.R + 119 * Col.G) mod BucketCount;
+ with FBuckets[ABucket] do
+ for I := 0 to Count - 1 do
+ if Items[I].Key = AKey then
+ begin
+ AIndex := I;
+ Result := True;
+ Break;
+ end;
+end;
+
+procedure TSimpleBucketList.Add(AKey: TColor32; const AData: string);
+var
+ Bucket, Index, Delta, Size: Integer;
+begin
+ if not FindItem(AKey, Bucket, Index) then
+ with FBuckets[Bucket] do
+ begin
+ Size := Length(Items);
+ if Count = Size then
+ begin
+ if Size > 64 then
+ Delta := Size div 4
+ else
+ Delta := 16;
+ SetLength(Items, Size + Delta);
+ end;
+
+ with Items[Count] do
+ begin
+ Key := AKey;
+ Data := AData;
+ end;
+ Inc(Count);
+ Inc(FItemCount);
+ end;
+end;
+
+function TSimpleBucketList.Exists(AKey: TColor32): Boolean;
+var
+ Bucket, Index: Integer;
+begin
+ Result := FindItem(AKey, Bucket, Index);
+end;
+
+{
+ TXPMFileFormat implementation
+}
+
+constructor TXPMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SXPMFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSupportedFormats := XPMSupportedFormats;
+
+ AddMasks(SXPMMasks);
+end;
+
+function TXPMFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Contents, PalLookup: TStringList;
+ S: AnsiString;
+ I, J, NumColors, Cpp, Line: Integer;
+
+ procedure SkipWhiteSpace(var Line: string);
+ begin
+ while (Length(Line) > 0) and (Line[1] in WhiteSpaces) do
+ Delete(Line, 1, 1);
+ end;
+
+ function ReadString(var Line: string): string;
+ begin
+ Result := '';
+ SkipWhiteSpace(Line);
+ while (Length(Line) > 0) and not(Line[1] in WhiteSpaces) do
+ begin
+ SetLength(Result, Length(Result) + 1);
+ Result[Length(Result)] := Line[1];
+ Delete(Line, 1, 1);
+ end;
+ end;
+
+ function ReadInt(var Line: string): Integer;
+ begin
+ Result := StrToInt(ReadString(Line));
+ end;
+
+ function ParseHeader: Boolean;
+ var
+ S: string;
+ begin
+ S := Contents[0];
+ try
+ Images[0].Width := ReadInt(S);
+ Images[0].Height := ReadInt(S);
+ NumColors := ReadInt(S);
+ Cpp := ReadInt(S);
+ Line := 1;
+ Result := True;
+ except
+ Result := False;
+ end;
+ end;
+
+ function NamedToColor(const ColStr: string): TColor32;
+ var
+ S: string;
+ begin
+ S := LowerCase(ColStr);
+ if (S = 'transparent') or (S = 'none') then
+ Result := pcClear
+ else if S = 'black' then
+ Result := pcBlack
+ else if S = 'blue' then
+ Result := pcBlue
+ else if S = 'green' then
+ Result := pcGreen
+ else if S = 'cyan' then
+ Result := pcAqua
+ else if S = 'red' then
+ Result := pcRed
+ else if S = 'magenta' then
+ Result := pcFuchsia
+ else if S = 'yellow' then
+ Result := pcYellow
+ else if S = 'white' then
+ Result := pcWhite
+ else if S = 'gray' then
+ Result := pcLtGray
+ else if S = 'dkblue' then
+ Result := pcNavy
+ else if S = 'dkgreen' then
+ Result := pcGreen
+ else if S = 'dkcyan' then
+ Result := pcTeal
+ else if S = 'dkred' then
+ Result := pcMaroon
+ else if S = 'dkmagenta' then
+ Result := pcPurple
+ else if S = 'dkyellow' then
+ Result := pcOlive
+ else if S = 'maroon' then
+ Result := pcMaroon
+ else if S = 'olive' then
+ Result := pcOlive
+ else if S = 'navy' then
+ Result := pcNavy
+ else if S = 'purple' then
+ Result := pcPurple
+ else if S = 'teal' then
+ Result := pcTeal
+ else if S = 'silver' then
+ Result := pcSilver
+ else if S = 'lime' then
+ Result := pcLime
+ else if S = 'fuchsia' then
+ Result := pcFuchsia
+ else if S = 'aqua' then
+ Result := pcAqua
+ else
+ Result := pcClear;
+ end;
+
+ procedure ParsePalette;
+ var
+ I: Integer;
+ S, ColType, ColStr, Code: string;
+ Color: TColor32;
+ Holder: TColorHolder;
+ begin
+ for I := 0 to NumColors - 1 do
+ begin
+ Holder := TColorHolder.Create;
+ // Parse pixel code and color
+ S := Contents[Line + I];
+ Code := Copy(S, 1, Cpp);
+ Delete(S, 1, Cpp);
+ ColType := ReadString(S);
+ ColStr := ReadString(S);
+ // Convert color from hex number or named constant
+ if ColStr[1] = '#' then
+ begin
+ Delete(ColStr, 1, 1);
+ Color := LongWord(StrToInt('$' + Trim(ColStr))) or $FF000000;
+ end
+ else
+ Color := NamedToColor(ColStr);
+ // Store code and color in table for later lookup
+ Holder.Color := Color;
+ PalLookup.AddObject(Code, Holder);
+ end;
+ Inc(Line, NumColors);
+ end;
+
+ procedure ParsePixels;
+ var
+ X, Y, Idx: Integer;
+ S, Code: string;
+ Pix: PColor32;
+ begin
+ Pix := Images[0].Bits;
+ for Y := 0 to Images[0].Height - 1 do
+ begin
+ S := Contents[Line + Y];
+ for X := 0 to Images[0].Width - 1 do
+ begin
+ // Read code and look up color in the palette
+ Code := Copy(S, X * Cpp + 1, Cpp);
+ if PalLookup.Find(Code, Idx) then
+ Pix^ := TColorHolder(PalLookup.Objects[Idx]).Color
+ else
+ Pix^ := pcClear;
+ Inc(Pix);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ begin
+ // Look up table for XPM palette entries
+ PalLookup := TStringList.Create;
+ PalLookup.Sorted := True;
+ PalLookup.CaseSensitive := True;
+ // Read whole file and assign it to string list
+ Contents := TStringList.Create;
+ SetLength(S, GetInputSize(GetIO, Handle));
+ Read(Handle, @S[1], Length(S));
+ Contents.Text := S;
+ // Remove quotes and other stuff
+ for I := Contents.Count - 1 downto 0 do
+ begin
+ J := Pos('"', Contents[I]);
+ if J > 0 then
+ Contents[I] := Copy(Contents[I], J + 1, LastDelimiter('"', Contents[I]) - J - 1)
+ else
+ Contents.Delete(I);
+ end;
+ // Parse header and create new image
+ if not ParseHeader then
+ Exit;
+ NewImage(Width, Height, ifA8R8G8B8, Images[0]);
+ // Read palette entries and assign colors to pixels
+ ParsePalette;
+ ParsePixels;
+
+ Contents.Free;
+ for I := 0 to PalLookup.Count - 1 do
+ PalLookup.Objects[I].Free;
+ PalLookup.Free;
+ Result := True;
+ end;
+end;
+
+function TXPMFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+const
+ ColorCharsCount = 92;
+ ColorChars = ' .XoO+@#$%&*=-;:>,<1234567890qwertyuipasdfghjklzxcvbnmMNBVCZASDFGHJKLPIUYTREWQ!~^/()_`''][{}|';
+var
+ X, Y: Integer;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ StrFile: TStringList;
+ ColTable: TSimpleBucketList;
+ Stream: TMemoryStream;
+ Line, Id: string;
+ CharsPerPixel: Integer;
+ Ptr: PColor32Rec;
+ ColRec: TColor32Rec;
+
+ procedure BuildColorTables(const Img: TImageData);
+ var
+ I: Integer;
+ begin
+ Ptr := Img.Bits;
+ for I := 0 to Img.Width * Img.Height - 1 do
+ begin
+ if not ColTable.Exists(Ptr.Color) then
+ ColTable.Add(Ptr.Color, '');
+ Inc(Ptr);
+ end;
+ end;
+
+ procedure MakeStrIdsForColors;
+ var
+ I, J, K: Integer;
+ Id, Data: string;
+ begin
+ SetLength(Id, CharsPerPixel);
+ for I := 0 to ColTable.ItemCount - 1 do
+ begin
+ ColRec.Color := ColTable.EnumNext(Data);
+ K := I;
+ for J := 0 to CharsPerPixel - 1 do
+ begin
+ Id[J + 1] := ColorChars[K mod ColorCharsCount + 1];
+ K := K div ColorCharsCount;
+ end;
+ ColTable.Data[ColRec.Color] := Id;
+ end;
+ end;
+
+begin
+ Result := False;
+
+ StrFile := TStringList.Create;
+ ColTable := TSimpleBucketList.Create;
+ Stream := TMemoryStream.Create;
+
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ try
+ // Put all unique colors of image to table
+ BuildColorTables(ImageToSave);
+ // Compute the character per pixel
+ CharsPerPixel := 1;
+ X := ColorCharsCount;
+ while ColTable.ItemCount > X do
+ begin
+ X := X * ColorCharsCount;
+ Inc(CharsPerPixel);
+ end;
+ // Assign char id to each color
+ MakeStrIdsForColors;
+
+ // Start writing XPM file
+ StrFile.Add(SXPMId);
+ StrFile.Add('static char *graphic[] = {');
+ StrFile.Add('/* width height num_colors chars_per_pixel */');
+ StrFile.Add(SysUtils.Format('"%d %d %d %d", ', [ImageToSave.Width,
+ ImageToSave.Height, ColTable.ItemCount, CharsPerPixel]));
+ StrFile.Add('/* colors */');
+
+ // Write 'colors' part of XPM file
+ for X := 0 to ColTable.ItemCount - 1 do
+ begin
+ ColRec.Color := ColTable.EnumNext(Id);
+ if ColRec.A >= 128 then
+ StrFile.Add(Format('"%s c #%.2x%.2x%.2x",', [Id, ColRec.R, ColRec.G, ColRec.B]))
+ else
+ StrFile.Add(Format('"%s c None",', [Id]));
+ end;
+
+ StrFile.Add('/* pixels */');
+
+ // Write pixels - for aech pixel of image find its char id
+ // and append it to line
+ Ptr := ImageToSave.Bits;
+ for Y := 0 to ImageToSave.Height - 1 do
+ begin
+ Line := '';
+ for X := 0 to ImageToSave.Width - 1 do
+ begin
+ Line := Line + ColTable.Data[Ptr.Color];
+ Inc(Ptr);
+ end;
+ Line := '"' + Line + '"';
+ if Y < ImageToSave.Height - 1 then
+ Line := Line + ',';
+ StrFile.Add(Line);
+ end;
+
+ StrFile.Add('};');
+
+ // Finally save strings to stream and write stream's data to output
+ // (we could directly write lines from list to output, but stream method
+ // takes care of D2009+ Unicode strings).
+ StrFile.SaveToStream(Stream);
+ GetIO.Write(Handle, Stream.Memory, Stream.Size);
+
+ Result := True;
+ finally
+ StrFile.Free;
+ ColTable.Free;
+ Stream.Free;
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+procedure TXPMFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+ ConvertImage(Image, ifA8R8G8B8)
+end;
+
+function TXPMFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Id: array[0 .. 8] of AnsiChar;
+ ReadCount: Integer;
+begin
+ Result := False;
+ if Handle <> nil then
+ begin
+ ReadCount := GetIO.Read(Handle, @Id, SizeOf(Id));
+ GetIO.Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (Id = SXPMId) and (ReadCount = SizeOf(Id));
+ end;
+end;
+
+initialization
+
+RegisterImageFileFormat(TXPMFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes -----------------------------------
+ - Added XPM saving.
+
+ -- 0.25.0 Changes/Bug Fixes -----------------------------------
+ - Added XPM loading.
+ - Unit created.
+}
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjcapimin.pas b/src/lib/vampimg/JpegLib/imjcapimin.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcapistd.pas b/src/lib/vampimg/JpegLib/imjcapistd.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjccoefct.pas b/src/lib/vampimg/JpegLib/imjccoefct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjccolor.pas b/src/lib/vampimg/JpegLib/imjccolor.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcdctmgr.pas b/src/lib/vampimg/JpegLib/imjcdctmgr.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjchuff.pas b/src/lib/vampimg/JpegLib/imjchuff.pas
--- /dev/null
@@ -0,0 +1,1116 @@
+unit imjchuff;
+
+{ This file contains Huffman entropy encoding routines.
+
+ Much of the complexity here has to do with supporting output suspension.
+ If the data destination module demands suspension, we want to be able to
+ back up to the start of the current MCU. To do this, we copy state
+ variables into local working storage, and update them back to the
+ permanent JPEG objects only upon successful completion of an MCU. }
+
+{ Original: jchuff.c; Copyright (C) 1991-1997, Thomas G. Lane. }
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg, { longptr definition missing }
+ imjpeglib,
+ imjdeferr,
+ imjerror,
+ imjutils,
+ imjinclude,
+ imjcomapi;
+
+{ The legal range of a DCT coefficient is
+ -1024 .. +1023 for 8-bit data;
+ -16384 .. +16383 for 12-bit data.
+ Hence the magnitude should always fit in 10 or 14 bits respectively. }
+
+
+{$ifdef BITS_IN_JSAMPLE_IS_8}
+const
+ MAX_COEF_BITS = 10;
+{$else}
+const
+ MAX_COEF_BITS = 14;
+{$endif}
+
+{ Derived data constructed for each Huffman table }
+{ Declarations shared with jcphuff.c }
+type
+ c_derived_tbl_ptr = ^c_derived_tbl;
+ c_derived_tbl = record
+ ehufco : array[0..256-1] of uInt; { code for each symbol }
+ ehufsi : array[0..256-1] of byte; { length of code for each symbol }
+ { If no code has been allocated for a symbol S, ehufsi[S] contains 0 }
+ end;
+{ for JCHUFF und JCPHUFF }
+type
+ TLongTable = array[0..256] of long;
+ TLongTablePtr = ^TLongTable;
+
+{ Compute the derived values for a Huffman table.
+ Note this is also used by jcphuff.c. }
+
+{GLOBAL}
+procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr;
+ isDC : boolean;
+ tblno : int;
+ var pdtbl : c_derived_tbl_ptr);
+
+{ Generate the optimal coding for the given counts, fill htbl.
+ Note this is also used by jcphuff.c. }
+
+{GLOBAL}
+procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr;
+ htbl : JHUFF_TBL_PTR;
+ var freq : TLongTable); { Nomssi }
+
+{ Module initialization routine for Huffman entropy encoding. }
+
+{GLOBAL}
+procedure jinit_huff_encoder (cinfo : j_compress_ptr);
+
+implementation
+
+{ Expanded entropy encoder object for Huffman encoding.
+
+ The savable_state subrecord contains fields that change within an MCU,
+ but must not be updated permanently until we complete the MCU. }
+
+type
+ savable_state = record
+ put_buffer : INT32; { current bit-accumulation buffer }
+ put_bits : int; { # of bits now in it }
+ last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int;
+ { last DC coef for each component }
+ end;
+
+
+type
+ huff_entropy_ptr = ^huff_entropy_encoder;
+ huff_entropy_encoder = record
+ pub : jpeg_entropy_encoder; { public fields }
+
+ saved : savable_state; { Bit buffer & DC state at start of MCU }
+
+ { These fields are NOT loaded into local working state. }
+ 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) }
+ dc_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr;
+ ac_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr;
+
+ {$ifdef ENTROPY_OPT_SUPPORTED} { Statistics tables for optimization }
+ dc_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr;
+ ac_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr;
+ {$endif}
+ end;
+
+
+
+{ Working state while writing an MCU.
+ This struct contains all the fields that are needed by subroutines. }
+
+type
+ working_state = record
+ next_output_byte : JOCTETptr; { => next byte to write in buffer }
+ free_in_buffer : size_t; { # of byte spaces remaining in buffer }
+ cur : savable_state; { Current bit buffer & DC state }
+ cinfo : j_compress_ptr; { dump_buffer needs access to this }
+ end;
+
+
+{ Forward declarations }
+{METHODDEF}
+function encode_mcu_huff (cinfo : j_compress_ptr;
+ const MCU_data : array of JBLOCKROW) : boolean;
+ forward;
+{METHODDEF}
+procedure finish_pass_huff (cinfo : j_compress_ptr); forward;
+{$ifdef ENTROPY_OPT_SUPPORTED}
+{METHODDEF}
+function encode_mcu_gather (cinfo : j_compress_ptr;
+ const MCU_data: array of JBLOCKROW) : boolean;
+ forward;
+
+{METHODDEF}
+procedure finish_pass_gather (cinfo : j_compress_ptr); forward;
+{$endif}
+
+
+{ Initialize for a Huffman-compressed scan.
+ If gather_statistics is TRUE, we do not output anything during the scan,
+ just count the Huffman symbols used and generate Huffman code tables. }
+
+{METHODDEF}
+procedure start_pass_huff (cinfo : j_compress_ptr;
+ gather_statistics : boolean);
+var
+ entropy : huff_entropy_ptr;
+ ci, dctbl, actbl : int;
+ compptr : jpeg_component_info_ptr;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ if (gather_statistics) then
+ begin
+{$ifdef ENTROPY_OPT_SUPPORTED}
+ entropy^.pub.encode_mcu := encode_mcu_gather;
+ entropy^.pub.finish_pass := finish_pass_gather;
+{$else}
+ ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
+{$endif}
+ end
+ else
+ begin
+ entropy^.pub.encode_mcu := encode_mcu_huff;
+ entropy^.pub.finish_pass := finish_pass_huff;
+ end;
+
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ begin
+ compptr := cinfo^.cur_comp_info[ci];
+ dctbl := compptr^.dc_tbl_no;
+ actbl := compptr^.ac_tbl_no;
+ if (gather_statistics) then
+ begin
+{$ifdef ENTROPY_OPT_SUPPORTED}
+ { Check for invalid table indexes }
+ { (make_c_derived_tbl does this in the other path) }
+ if (dctbl < 0) or (dctbl >= NUM_HUFF_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, dctbl);
+ if (actbl < 0) or (actbl >= NUM_HUFF_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, actbl);
+ { Allocate and zero the statistics tables }
+ { Note that jpeg_gen_optimal_table expects 257 entries in each table! }
+ if (entropy^.dc_count_ptrs[dctbl] = NIL) then
+ entropy^.dc_count_ptrs[dctbl] := TLongTablePtr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ 257 * SIZEOF(long)) );
+ MEMZERO(entropy^.dc_count_ptrs[dctbl], 257 * SIZEOF(long));
+ if (entropy^.ac_count_ptrs[actbl] = NIL) then
+ entropy^.ac_count_ptrs[actbl] := TLongTablePtr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ 257 * SIZEOF(long)) );
+ MEMZERO(entropy^.ac_count_ptrs[actbl], 257 * SIZEOF(long));
+{$endif}
+ end
+ else
+ begin
+ { Compute derived values for Huffman tables }
+ { We may do this more than once for a table, but it's not expensive }
+ jpeg_make_c_derived_tbl(cinfo, TRUE, dctbl,
+ entropy^.dc_derived_tbls[dctbl]);
+ jpeg_make_c_derived_tbl(cinfo, FALSE, actbl,
+ entropy^.ac_derived_tbls[actbl]);
+ end;
+ { Initialize DC predictions to 0 }
+ entropy^.saved.last_dc_val[ci] := 0;
+ end;
+
+ { Initialize bit buffer to empty }
+ entropy^.saved.put_buffer := 0;
+ entropy^.saved.put_bits := 0;
+
+ { Initialize restart stuff }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+ entropy^.next_restart_num := 0;
+end;
+
+
+{ Compute the derived values for a Huffman table.
+ This routine also performs some validation checks on the table.
+
+ Note this is also used by jcphuff.c. }
+
+{GLOBAL}
+procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr;
+ isDC : boolean;
+ tblno : int;
+ var pdtbl : c_derived_tbl_ptr);
+var
+ htbl : JHUFF_TBL_PTR;
+ dtbl : c_derived_tbl_ptr;
+ p, i, l, lastp, si, maxsymbol : int;
+ huffsize : array[0..257-1] of byte;
+ huffcode : array[0..257-1] of uInt;
+ code : uInt;
+begin
+ { Note that huffsize[] and huffcode[] are filled in code-length order,
+ paralleling the order of the symbols themselves in htbl->huffval[]. }
+
+ { Find the input Huffman table }
+ if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno);
+ if isDC then
+ htbl := cinfo^.dc_huff_tbl_ptrs[tblno]
+ else
+ htbl := cinfo^.ac_huff_tbl_ptrs[tblno];
+ if (htbl = NIL) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno);
+
+ { Allocate a workspace if we haven't already done so. }
+ if (pdtbl = NIL) then
+ pdtbl := c_derived_tbl_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(c_derived_tbl)) );
+ dtbl := pdtbl;
+
+ { Figure C.1: make table of Huffman code length for each symbol }
+
+ p := 0;
+ for l := 1 to 16 do
+ begin
+ i := int(htbl^.bits[l]);
+ if (i < 0) and (p + i > 256) then { protect against table overrun }
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+ while (i > 0) do
+ begin
+ huffsize[p] := byte(l);
+ Inc(p);
+ Dec(i);
+ end;
+ end;
+ huffsize[p] := 0;
+ lastp := p;
+
+ { Figure C.2: generate the codes themselves }
+ { We also validate that the counts represent a legal Huffman code tree. }
+
+ code := 0;
+ si := huffsize[0];
+ p := 0;
+ while (huffsize[p] <> 0) do
+ begin
+ while (( int(huffsize[p]) ) = si) do
+ begin
+ huffcode[p] := code;
+ Inc(p);
+ Inc(code);
+ end;
+ { code is now 1 more than the last code used for codelength si; but
+ it must still fit in si bits, since no code is allowed to be all ones. }
+
+ if (INT32(code) >= (INT32(1) shl si)) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+ code := code shl 1;
+ Inc(si);
+ end;
+
+ { Figure C.3: generate encoding tables }
+ { These are code and size indexed by symbol value }
+
+ { Set all codeless symbols to have code length 0;
+ this lets us detect duplicate VAL entries here, and later
+ allows emit_bits to detect any attempt to emit such symbols. }
+
+ MEMZERO(@dtbl^.ehufsi, SIZEOF(dtbl^.ehufsi));
+
+ { This is also a convenient place to check for out-of-range
+ and duplicated VAL entries. We allow 0..255 for AC symbols
+ but only 0..15 for DC. (We could constrain them further
+ based on data depth and mode, but this seems enough.) }
+
+ if isDC then
+ maxsymbol := 15
+ else
+ maxsymbol := 255;
+
+ for p := 0 to pred(lastp) do
+ begin
+ i := htbl^.huffval[p];
+ if (i < 0) or (i > maxsymbol) or (dtbl^.ehufsi[i] <> 0) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+ dtbl^.ehufco[i] := huffcode[p];
+ dtbl^.ehufsi[i] := huffsize[p];
+ end;
+end;
+
+
+{ Outputting bytes to the file }
+
+
+{LOCAL}
+function dump_buffer (var state : working_state) : boolean;
+{ Empty the output buffer; return TRUE if successful, FALSE if must suspend }
+var
+ dest : jpeg_destination_mgr_ptr;
+begin
+ dest := state.cinfo^.dest;
+
+ if (not dest^.empty_output_buffer (state.cinfo)) then
+ begin
+ dump_buffer := FALSE;
+ exit;
+ end;
+ { After a successful buffer dump, must reset buffer pointers }
+ state.next_output_byte := dest^.next_output_byte;
+ state.free_in_buffer := dest^.free_in_buffer;
+ dump_buffer := TRUE;
+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}
+function emit_bits (var state : working_state;
+ code : uInt;
+ size : int) : boolean; {INLINE}
+{ Emit some bits; return TRUE if successful, FALSE if must suspend }
+var
+ { This routine is heavily used, so it's worth coding tightly. }
+ {register} put_buffer : INT32;
+ {register} put_bits : int;
+var
+ c : int;
+begin
+ put_buffer := INT32 (code);
+ put_bits := state.cur.put_bits;
+
+ { if size is 0, caller used an invalid Huffman table entry }
+ if (size = 0) then
+ ERREXIT(j_common_ptr(state.cinfo), JERR_HUFF_MISSING_CODE);
+
+ put_buffer := put_buffer and pred(INT32(1) shl size);
+ { 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 state.cur.put_buffer;
+ { and merge with old buffer contents }
+ while (put_bits >= 8) do
+ begin
+ c := int ((put_buffer shr 16) and $FF);
+
+ {emit_byte(state, c, return FALSE);}
+ { Emit a byte, return FALSE if must suspend. }
+ state.next_output_byte^ := JOCTET (c);
+ Inc(state.next_output_byte);
+ Dec(state.free_in_buffer);
+ if (state.free_in_buffer = 0) then
+ if not dump_buffer(state) then
+ begin
+ emit_bits := FALSE;
+ exit;
+ end;
+
+ if (c = $FF) then { need to stuff a zero byte? }
+ begin
+ {emit_byte(state, 0, return FALSE);}
+ state.next_output_byte^ := JOCTET (0);
+ Inc(state.next_output_byte);
+ Dec(state.free_in_buffer);
+ if (state.free_in_buffer = 0) then
+ if not dump_buffer(state) then
+ begin
+ emit_bits := FALSE;
+ exit;
+ end;
+
+ end;
+ put_buffer := put_buffer shl 8;
+ Dec(put_bits, 8);
+ end;
+
+ state.cur.put_buffer := put_buffer; { update state variables }
+ state.cur.put_bits := put_bits;
+
+ emit_bits := TRUE;
+end;
+
+
+{LOCAL}
+function flush_bits (var state : working_state) : boolean;
+begin
+ if (not emit_bits(state, $7F, 7)) then { fill any partial byte with ones }
+ begin
+ flush_bits := FALSE;
+ exit;
+ end;
+ state.cur.put_buffer := 0; { and reset bit-buffer to empty }
+ state.cur.put_bits := 0;
+ flush_bits := TRUE;
+end;
+
+
+{ Encode a single block's worth of coefficients }
+
+{LOCAL}
+function encode_one_block (var state : working_state;
+ const block : JBLOCK;
+ last_dc_val : int;
+ dctbl : c_derived_tbl_ptr;
+ actbl : c_derived_tbl_ptr) : boolean;
+var
+ {register} temp, temp2 : int;
+ {register} nbits : int;
+ {register} k, r, i : int;
+begin
+ { Encode the DC coefficient difference per section F.1.2.1 }
+
+ temp2 := block[0] - last_dc_val;
+ temp := temp2;
+
+ 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(state.cinfo), JERR_BAD_DCT_COEF);
+
+ { Emit the Huffman-coded symbol for the number of bits }
+ if not emit_bits(state, dctbl^.ehufco[nbits], dctbl^.ehufsi[nbits]) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+
+ { 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 }
+ if not emit_bits(state, uInt(temp2), nbits) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+
+ { Encode the AC coefficients per section F.1.2.2 }
+
+ r := 0; { r := run length of zeros }
+
+ for k := 1 to pred(DCTSIZE2) do
+ begin
+ temp := block[jpeg_natural_order[k]];
+ if (temp = 0) then
+ begin
+ Inc(r);
+ end
+ else
+ begin
+ { if run length > 15, must emit special run-length-16 codes ($F0) }
+ while (r > 15) do
+ begin
+ if not emit_bits(state, actbl^.ehufco[$F0], actbl^.ehufsi[$F0]) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+ Dec(r, 16);
+ end;
+
+ temp2 := temp;
+ if (temp < 0) then
+ begin
+ temp := -temp; { temp is abs value of 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; { 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(state.cinfo), JERR_BAD_DCT_COEF);
+
+ { Emit Huffman symbol for run length / number of bits }
+ i := (r shl 4) + nbits;
+ if not emit_bits(state, actbl^.ehufco[i], actbl^.ehufsi[i]) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+
+ { Emit that number of bits of the value, if positive, }
+ { or the complement of its magnitude, if negative. }
+ if not emit_bits(state, uInt(temp2), nbits) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+
+ r := 0;
+ end;
+ end;
+
+ { If the last coef(s) were zero, emit an end-of-block code }
+ if (r > 0) then
+ if not emit_bits(state, actbl^.ehufco[0], actbl^.ehufsi[0]) then
+ begin
+ encode_one_block := FALSE;
+ exit;
+ end;
+
+ encode_one_block := TRUE;
+end;
+
+
+{ Emit a restart marker & resynchronize predictions. }
+
+{LOCAL}
+function emit_restart (var state : working_state;
+ restart_num : int) : boolean;
+var
+ ci : int;
+begin
+ if (not flush_bits(state)) then
+ begin
+ emit_restart := FALSE;
+ exit;
+ end;
+
+ {emit_byte(state, $FF, return FALSE);}
+ { Emit a byte, return FALSE if must suspend. }
+ state.next_output_byte^ := JOCTET ($FF);
+ Inc(state.next_output_byte);
+ Dec(state.free_in_buffer);
+ if (state.free_in_buffer = 0) then
+ if not dump_buffer(state) then
+ begin
+ emit_restart := FALSE;
+ exit;
+ end;
+
+ {emit_byte(state, JPEG_RST0 + restart_num, return FALSE);}
+ { Emit a byte, return FALSE if must suspend. }
+ state.next_output_byte^ := JOCTET (JPEG_RST0 + restart_num);
+ Inc(state.next_output_byte);
+ Dec(state.free_in_buffer);
+ if (state.free_in_buffer = 0) then
+ if not dump_buffer(state) then
+ begin
+ emit_restart := FALSE;
+ exit;
+ end;
+
+ { Re-initialize DC predictions to 0 }
+ for ci := 0 to pred(state.cinfo^.comps_in_scan) do
+ state.cur.last_dc_val[ci] := 0;
+
+ { The restart counter is not updated until we successfully write the MCU. }
+
+ emit_restart := TRUE;
+end;
+
+
+{ Encode and output one MCU's worth of Huffman-compressed coefficients. }
+
+{METHODDEF}
+function encode_mcu_huff (cinfo : j_compress_ptr;
+ const MCU_data: array of JBLOCKROW) : boolean;
+var
+ entropy : huff_entropy_ptr;
+ state : working_state;
+ blkn, ci : int;
+ compptr : jpeg_component_info_ptr;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+ { Load up working state }
+ state.next_output_byte := cinfo^.dest^.next_output_byte;
+ state.free_in_buffer := cinfo^.dest^.free_in_buffer;
+ {ASSIGN_STATE(state.cur, entropy^.saved);}
+ state.cur := entropy^.saved;
+ state.cinfo := cinfo;
+
+ { Emit restart marker if needed }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if not emit_restart(state, entropy^.next_restart_num) then
+ begin
+ encode_mcu_huff := FALSE;
+ exit;
+ end;
+ end;
+
+ { Encode the MCU data blocks }
+ for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
+ begin
+ ci := cinfo^.MCU_membership[blkn];
+ compptr := cinfo^.cur_comp_info[ci];
+ if not encode_one_block(state,
+ MCU_data[blkn]^[0],
+ state.cur.last_dc_val[ci],
+ entropy^.dc_derived_tbls[compptr^.dc_tbl_no],
+ entropy^.ac_derived_tbls[compptr^.ac_tbl_no]) then
+ begin
+ encode_mcu_huff := FALSE;
+ exit;
+ end;
+ { Update last_dc_val }
+ state.cur.last_dc_val[ci] := MCU_data[blkn]^[0][0];
+ end;
+
+ { Completed MCU, so update state }
+ cinfo^.dest^.next_output_byte := state.next_output_byte;
+ cinfo^.dest^.free_in_buffer := state.free_in_buffer;
+ {ASSIGN_STATE(entropy^.saved, state.cur);}
+ entropy^.saved := state.cur;
+
+ { 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_huff := TRUE;
+end;
+
+
+{ Finish up at the end of a Huffman-compressed scan. }
+
+{METHODDEF}
+procedure finish_pass_huff (cinfo : j_compress_ptr);
+var
+ entropy : huff_entropy_ptr;
+ state : working_state;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ { Load up working state ... flush_bits needs it }
+ state.next_output_byte := cinfo^.dest^.next_output_byte;
+ state.free_in_buffer := cinfo^.dest^.free_in_buffer;
+ {ASSIGN_STATE(state.cur, entropy^.saved);}
+ state.cur := entropy^.saved;
+ state.cinfo := cinfo;
+
+ { Flush out the last data }
+ if not flush_bits(state) then
+ ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
+
+ { Update state }
+ cinfo^.dest^.next_output_byte := state.next_output_byte;
+ cinfo^.dest^.free_in_buffer := state.free_in_buffer;
+ {ASSIGN_STATE(entropy^.saved, state.cur);}
+ entropy^.saved := state.cur;
+end;
+
+
+{ Huffman coding optimization.
+
+ We first scan the supplied data and count the number of uses of each symbol
+ that is to be Huffman-coded. (This process MUST agree with the code above.)
+ Then we build a Huffman coding tree for the observed counts.
+ Symbols which are not needed at all for the particular image are not
+ assigned any code, which saves space in the DHT marker as well as in
+ the compressed data. }
+
+{$ifdef ENTROPY_OPT_SUPPORTED}
+
+
+{ Process a single block's worth of coefficients }
+
+{LOCAL}
+procedure htest_one_block (cinfo : j_compress_ptr;
+ const block : JBLOCK;
+ last_dc_val : int;
+ dc_counts : TLongTablePtr;
+ ac_counts : TLongTablePtr);
+
+var
+ {register} temp : int;
+ {register} nbits : int;
+ {register} k, r : int;
+begin
+ { Encode the DC coefficient difference per section F.1.2.1 }
+ temp := block[0] - last_dc_val;
+ if (temp < 0) then
+ temp := -temp;
+
+ { 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 the Huffman symbol for the number of bits }
+ Inc(dc_counts^[nbits]);
+
+ { Encode the AC coefficients per section F.1.2.2 }
+
+ r := 0; { r := run length of zeros }
+
+ for k := 1 to pred(DCTSIZE2) do
+ begin
+ temp := block[jpeg_natural_order[k]];
+ if (temp = 0) then
+ begin
+ Inc(r);
+ end
+ else
+ begin
+ { if run length > 15, must emit special run-length-16 codes ($F0) }
+ while (r > 15) do
+ begin
+ Inc(ac_counts^[$F0]);
+ Dec(r, 16);
+ end;
+
+ { Find the number of bits needed for the magnitude of the coefficient }
+ if (temp < 0) then
+ temp := -temp;
+
+ { 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);
+
+
+ { Count Huffman symbol for run length / number of bits }
+ Inc(ac_counts^[(r shl 4) + nbits]);
+
+ r := 0;
+ end;
+ end;
+
+ { If the last coef(s) were zero, emit an end-of-block code }
+ if (r > 0) then
+ Inc(ac_counts^[0]);
+end;
+
+
+{ Trial-encode one MCU's worth of Huffman-compressed coefficients.
+ No data is actually output, so no suspension return is possible. }
+
+{METHODDEF}
+function encode_mcu_gather (cinfo : j_compress_ptr;
+ const MCU_data: array of JBLOCKROW) : boolean;
+var
+ entropy : huff_entropy_ptr;
+ blkn, ci : int;
+ compptr : jpeg_component_info_ptr;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+ { Take care of restart intervals if needed }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ begin
+ { Re-initialize DC predictions to 0 }
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ entropy^.saved.last_dc_val[ci] := 0;
+ { Update restart state }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+ end;
+ Dec(entropy^.restarts_to_go);
+ end;
+
+ for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
+ begin
+ ci := cinfo^.MCU_membership[blkn];
+ compptr := cinfo^.cur_comp_info[ci];
+ htest_one_block(cinfo, MCU_data[blkn]^[0],
+ entropy^.saved.last_dc_val[ci],
+ entropy^.dc_count_ptrs[compptr^.dc_tbl_no],
+ entropy^.ac_count_ptrs[compptr^.ac_tbl_no]);
+ entropy^.saved.last_dc_val[ci] := MCU_data[blkn]^[0][0];
+ end;
+
+ encode_mcu_gather := TRUE;
+end;
+
+
+{ Generate the best Huffman code table for the given counts, fill htbl.
+ Note this is also used by jcphuff.c.
+
+ The JPEG standard requires that no symbol be assigned a codeword of all
+ one bits (so that padding bits added at the end of a compressed segment
+ can't look like a valid code). Because of the canonical ordering of
+ codewords, this just means that there must be an unused slot in the
+ longest codeword length category. Section K.2 of the JPEG spec suggests
+ reserving such a slot by pretending that symbol 256 is a valid symbol
+ with count 1. In theory that's not optimal; giving it count zero but
+ including it in the symbol set anyway should give a better Huffman code.
+ But the theoretically better code actually seems to come out worse in
+ practice, because it produces more all-ones bytes (which incur stuffed
+ zero bytes in the final file). In any case the difference is tiny.
+
+ The JPEG standard requires Huffman codes to be no more than 16 bits long.
+ If some symbols have a very small but nonzero probability, the Huffman tree
+ must be adjusted to meet the code length restriction. We currently use
+ the adjustment method suggested in JPEG section K.2. This method is *not*
+ optimal; it may not choose the best possible limited-length code. But
+ typically only very-low-frequency symbols will be given less-than-optimal
+ lengths, so the code is almost optimal. Experimental comparisons against
+ an optimal limited-length-code algorithm indicate that the difference is
+ microscopic --- usually less than a hundredth of a percent of total size.
+ So the extra complexity of an optimal algorithm doesn't seem worthwhile. }
+
+
+{GLOBAL}
+procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr;
+ htbl : JHUFF_TBL_PTR;
+ var freq : TLongTable);
+const
+ MAX_CLEN = 32; { assumed maximum initial code length }
+var
+ bits : array[0..MAX_CLEN+1-1] of UINT8; { bits[k] := # of symbols with code length k }
+ codesize : array[0..257-1] of int; { codesize[k] := code length of symbol k }
+ others : array[0..257-1] of int; { next symbol in current branch of tree }
+ c1, c2 : int;
+ p, i, j : int;
+ v : long;
+begin
+ { This algorithm is explained in section K.2 of the JPEG standard }
+
+ MEMZERO(@bits, SIZEOF(bits));
+ MEMZERO(@codesize, SIZEOF(codesize));
+ for i := 0 to 256 do
+ others[i] := -1; { init links to empty }
+
+ freq[256] := 1; { make sure 256 has a nonzero count }
+ { Including the pseudo-symbol 256 in the Huffman procedure guarantees
+ that no real symbol is given code-value of all ones, because 256
+ will be placed last in the largest codeword category. }
+
+ { Huffman's basic algorithm to assign optimal code lengths to symbols }
+
+ while TRUE do
+ begin
+ { Find the smallest nonzero frequency, set c1 := its symbol }
+ { In case of ties, take the larger symbol number }
+ c1 := -1;
+ v := long(1000000000);
+ for i := 0 to 256 do
+ begin
+ if (freq[i] <> 0) and (freq[i] <= v) then
+ begin
+ v := freq[i];
+ c1 := i;
+ end;
+ end;
+
+ { Find the next smallest nonzero frequency, set c2 := its symbol }
+ { In case of ties, take the larger symbol number }
+ c2 := -1;
+ v := long(1000000000);
+ for i := 0 to 256 do
+ begin
+ if (freq[i] <> 0) and (freq[i] <= v) and (i <> c1) then
+ begin
+ v := freq[i];
+ c2 := i;
+ end;
+ end;
+
+ { Done if we've merged everything into one frequency }
+ if (c2 < 0) then
+ break;
+
+ { Else merge the two counts/trees }
+ Inc(freq[c1], freq[c2]);
+ freq[c2] := 0;
+
+ { Increment the codesize of everything in c1's tree branch }
+ Inc(codesize[c1]);
+ while (others[c1] >= 0) do
+ begin
+ c1 := others[c1];
+ Inc(codesize[c1]);
+ end;
+
+ others[c1] := c2; { chain c2 onto c1's tree branch }
+
+ { Increment the codesize of everything in c2's tree branch }
+ Inc(codesize[c2]);
+ while (others[c2] >= 0) do
+ begin
+ c2 := others[c2];
+ Inc(codesize[c2]);
+ end;
+ end;
+
+ { Now count the number of symbols of each code length }
+ for i := 0 to 256 do
+ begin
+ if (codesize[i]<>0) then
+ begin
+ { The JPEG standard seems to think that this can't happen, }
+ { but I'm paranoid... }
+ if (codesize[i] > MAX_CLEN) then
+ ERREXIT(j_common_ptr(cinfo), JERR_HUFF_CLEN_OVERFLOW);
+
+ Inc(bits[codesize[i]]);
+ end;
+ end;
+
+ { JPEG doesn't allow symbols with code lengths over 16 bits, so if the pure
+ Huffman procedure assigned any such lengths, we must adjust the coding.
+ Here is what the JPEG spec says about how this next bit works:
+ Since symbols are paired for the longest Huffman code, the symbols are
+ removed from this length category two at a time. The prefix for the pair
+ (which is one bit shorter) is allocated to one of the pair; then,
+ skipping the BITS entry for that prefix length, a code word from the next
+ shortest nonzero BITS entry is converted into a prefix for two code words
+ one bit longer. }
+
+ for i := MAX_CLEN downto 17 do
+ begin
+ while (bits[i] > 0) do
+ begin
+ j := i - 2; { find length of new prefix to be used }
+ while (bits[j] = 0) do
+ Dec(j);
+
+ Dec(bits[i], 2); { remove two symbols }
+ Inc(bits[i-1]); { one goes in this length }
+ Inc(bits[j+1], 2); { two new symbols in this length }
+ Dec(bits[j]); { symbol of this length is now a prefix }
+ end;
+ end;
+
+ { Delphi 2: FOR-loop variable 'i' may be undefined after loop }
+ i := 16; { Nomssi: work around }
+
+ { Remove the count for the pseudo-symbol 256 from the largest codelength }
+ while (bits[i] = 0) do { find largest codelength still in use }
+ Dec(i);
+ Dec(bits[i]);
+
+ { Return final symbol counts (only for lengths 0..16) }
+ MEMCOPY(@htbl^.bits, @bits, SIZEOF(htbl^.bits));
+
+ { Return a list of the symbols sorted by code length }
+ { It's not real clear to me why we don't need to consider the codelength
+ changes made above, but the JPEG spec seems to think this works. }
+
+ p := 0;
+ for i := 1 to MAX_CLEN do
+ begin
+ for j := 0 to 255 do
+ begin
+ if (codesize[j] = i) then
+ begin
+ htbl^.huffval[p] := UINT8 (j);
+ Inc(p);
+ end;
+ end;
+ end;
+
+ { Set sent_table FALSE so updated table will be written to JPEG file. }
+ htbl^.sent_table := FALSE;
+end;
+
+
+{ Finish up a statistics-gathering pass and create the new Huffman tables. }
+
+{METHODDEF}
+procedure finish_pass_gather (cinfo : j_compress_ptr);
+var
+ entropy : huff_entropy_ptr;
+ ci, dctbl, actbl : int;
+ compptr : jpeg_component_info_ptr;
+ htblptr : ^JHUFF_TBL_PTR;
+ did_dc : array[0..NUM_HUFF_TBLS-1] of boolean;
+ did_ac : array[0..NUM_HUFF_TBLS-1] of boolean;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ { It's important not to apply jpeg_gen_optimal_table more than once
+ per table, because it clobbers the input frequency counts! }
+
+ MEMZERO(@did_dc, SIZEOF(did_dc));
+ MEMZERO(@did_ac, SIZEOF(did_ac));
+
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ begin
+ compptr := cinfo^.cur_comp_info[ci];
+ dctbl := compptr^.dc_tbl_no;
+ actbl := compptr^.ac_tbl_no;
+ if (not did_dc[dctbl]) then
+ begin
+ htblptr := @(cinfo^.dc_huff_tbl_ptrs[dctbl]);
+ if ( htblptr^ = NIL) then
+ htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo));
+ jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.dc_count_ptrs[dctbl]^);
+ did_dc[dctbl] := TRUE;
+ end;
+ if (not did_ac[actbl]) then
+ begin
+ htblptr := @(cinfo^.ac_huff_tbl_ptrs[actbl]);
+ if ( htblptr^ = NIL) then
+ htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo));
+ jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.ac_count_ptrs[actbl]^);
+ did_ac[actbl] := TRUE;
+ end;
+ end;
+end;
+
+{$endif} { ENTROPY_OPT_SUPPORTED }
+
+
+{ Module initialization routine for Huffman entropy encoding. }
+
+{GLOBAL}
+procedure jinit_huff_encoder (cinfo : j_compress_ptr);
+var
+ entropy : huff_entropy_ptr;
+ i : int;
+begin
+ entropy := huff_entropy_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(huff_entropy_encoder)) );
+ cinfo^.entropy := jpeg_entropy_encoder_ptr (entropy);
+ entropy^.pub.start_pass := start_pass_huff;
+
+ { Mark tables unallocated }
+ for i := 0 to pred(NUM_HUFF_TBLS) do
+ begin
+ entropy^.ac_derived_tbls[i] := NIL;
+ entropy^.dc_derived_tbls[i] := NIL;
+{$ifdef ENTROPY_OPT_SUPPORTED}
+ entropy^.ac_count_ptrs[i] := NIL;
+ entropy^.dc_count_ptrs[i] := NIL;
+{$endif}
+ end;
+end;
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjcinit.pas b/src/lib/vampimg/JpegLib/imjcinit.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcmainct.pas b/src/lib/vampimg/JpegLib/imjcmainct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcmarker.pas b/src/lib/vampimg/JpegLib/imjcmarker.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcmaster.pas b/src/lib/vampimg/JpegLib/imjcmaster.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcomapi.pas b/src/lib/vampimg/JpegLib/imjcomapi.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjconfig.inc b/src/lib/vampimg/JpegLib/imjconfig.inc
--- /dev/null
@@ -0,0 +1,123 @@
+{ ----------------------- 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-}
diff --git a/src/lib/vampimg/JpegLib/imjcparam.pas b/src/lib/vampimg/JpegLib/imjcparam.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcphuff.pas b/src/lib/vampimg/JpegLib/imjcphuff.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcprepct.pas b/src/lib/vampimg/JpegLib/imjcprepct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjcsample.pas b/src/lib/vampimg/JpegLib/imjcsample.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdapimin.pas b/src/lib/vampimg/JpegLib/imjdapimin.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdapistd.pas b/src/lib/vampimg/JpegLib/imjdapistd.pas
--- /dev/null
@@ -0,0 +1,376 @@
+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.
diff --git a/src/lib/vampimg/JpegLib/imjdcoefct.pas b/src/lib/vampimg/JpegLib/imjdcoefct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdcolor.pas b/src/lib/vampimg/JpegLib/imjdcolor.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdct.pas b/src/lib/vampimg/JpegLib/imjdct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjddctmgr.pas b/src/lib/vampimg/JpegLib/imjddctmgr.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdeferr.pas b/src/lib/vampimg/JpegLib/imjdeferr.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdhuff.pas b/src/lib/vampimg/JpegLib/imjdhuff.pas
--- /dev/null
@@ -0,0 +1,1204 @@
+unit imjdhuff;
+
+{ This file contains declarations for Huffman entropy decoding routines
+ that are shared between the sequential decoder (jdhuff.c) and the
+ progressive decoder (jdphuff.c). No other modules need to see these. }
+
+{ This file contains Huffman entropy decoding routines.
+
+ Much of the complexity here has to do with supporting input suspension.
+ If the data source module demands suspension, we want to be able to back
+ up to the start of the current MCU. To do this, we copy state variables
+ into local working storage, and update them back to the permanent
+ storage only upon successful completion of an MCU. }
+
+{ Original: jdhuff.h+jdhuff.c; Copyright (C) 1991-1997, Thomas G. Lane. }
+
+
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg,
+ imjinclude,
+ imjdeferr,
+ imjerror,
+ imjutils,
+ imjpeglib;
+
+
+{ Declarations shared with jdphuff.c }
+
+
+
+{ Derived data constructed for each Huffman table }
+
+const
+ HUFF_LOOKAHEAD = 8; { # of bits of lookahead }
+
+type
+ d_derived_tbl_ptr = ^d_derived_tbl;
+ d_derived_tbl = record
+ { Basic tables: (element [0] of each array is unused) }
+ maxcode : array[0..18-1] of INT32; { largest code of length k (-1 if none) }
+ { (maxcode[17] is a sentinel to ensure jpeg_huff_decode terminates) }
+ valoffset : array[0..17-1] of INT32; { huffval[] offset for codes of length k }
+ { valoffset[k] = huffval[] index of 1st symbol of code length k, less
+ the smallest code of length k; so given a code of length k, the
+ corresponding symbol is huffval[code + valoffset[k]] }
+
+ { Link to public Huffman table (needed only in jpeg_huff_decode) }
+ pub : JHUFF_TBL_PTR;
+
+ { Lookahead tables: indexed by the next HUFF_LOOKAHEAD bits of
+ the input data stream. If the next Huffman code is no more
+ than HUFF_LOOKAHEAD bits long, we can obtain its length and
+ the corresponding symbol directly from these tables. }
+
+ look_nbits : array[0..(1 shl HUFF_LOOKAHEAD)-1] of int;
+ { # bits, or 0 if too long }
+ look_sym : array[0..(1 shl HUFF_LOOKAHEAD)-1] of UINT8;
+ { symbol, or unused }
+ end;
+
+{ Fetching the next N bits from the input stream is a time-critical operation
+ for the Huffman decoders. We implement it with a combination of inline
+ macros and out-of-line subroutines. Note that N (the number of bits
+ demanded at one time) never exceeds 15 for JPEG use.
+
+ We read source bytes into get_buffer and dole out bits as needed.
+ If get_buffer already contains enough bits, they are fetched in-line
+ by the macros CHECK_BIT_BUFFER and GET_BITS. When there aren't enough
+ bits, jpeg_fill_bit_buffer is called; it will attempt to fill get_buffer
+ as full as possible (not just to the number of bits needed; this
+ prefetching reduces the overhead cost of calling jpeg_fill_bit_buffer).
+ Note that jpeg_fill_bit_buffer may return FALSE to indicate suspension.
+ On TRUE return, jpeg_fill_bit_buffer guarantees that get_buffer contains
+ at least the requested number of bits --- dummy zeroes are inserted if
+ necessary. }
+
+
+type
+ bit_buf_type = INT32 ; { type of bit-extraction buffer }
+const
+ BIT_BUF_SIZE = 32; { size of buffer in bits }
+
+{ If long is > 32 bits on your machine, and shifting/masking longs is
+ reasonably fast, making bit_buf_type be long and setting BIT_BUF_SIZE
+ appropriately should be a win. Unfortunately we can't define the size
+ with something like #define BIT_BUF_SIZE (sizeof(bit_buf_type)*8)
+ because not all machines measure sizeof in 8-bit bytes. }
+
+type
+ bitread_perm_state = record { Bitreading state saved across MCUs }
+ get_buffer : bit_buf_type; { current bit-extraction buffer }
+ bits_left : int; { # of unused bits in it }
+ end;
+
+type
+ bitread_working_state = record
+ { Bitreading working state within an MCU }
+ { current data source location }
+ { We need a copy, rather than munging the original, in case of suspension }
+ next_input_byte : JOCTETptr; { => next byte to read from source }
+ bytes_in_buffer : size_t; { # of bytes remaining in source buffer }
+ { Bit input buffer --- note these values are kept in register variables,
+ not in this struct, inside the inner loops. }
+
+ get_buffer : bit_buf_type; { current bit-extraction buffer }
+ bits_left : int; { # of unused bits in it }
+ { Pointer needed by jpeg_fill_bit_buffer }
+ cinfo : j_decompress_ptr; { back link to decompress master record }
+ end;
+
+{ Module initialization routine for Huffman entropy decoding. }
+
+{GLOBAL}
+procedure jinit_huff_decoder (cinfo : j_decompress_ptr);
+
+{GLOBAL}
+function jpeg_huff_decode(var state : bitread_working_state;
+ get_buffer : bit_buf_type; {register}
+ bits_left : int; {register}
+ htbl : d_derived_tbl_ptr;
+ min_bits : int) : int;
+
+{ Compute the derived values for a Huffman table.
+ Note this is also used by jdphuff.c. }
+
+{GLOBAL}
+procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr;
+ isDC : boolean;
+ tblno : int;
+ var pdtbl : d_derived_tbl_ptr);
+
+{ Load up the bit buffer to a depth of at least nbits }
+
+function jpeg_fill_bit_buffer (var state : bitread_working_state;
+ get_buffer : bit_buf_type; {register}
+ bits_left : int; {register}
+ nbits : int) : boolean;
+
+implementation
+
+{$IFDEF MACRO}
+
+{ Macros to declare and load/save bitread local variables. }
+{$define BITREAD_STATE_VARS}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+
+{$define BITREAD_LOAD_STATE(cinfop,permstate)}
+ br_state.cinfo := cinfop;
+ br_state.next_input_byte := cinfop^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfop^.src^.bytes_in_buffer;
+ get_buffer := permstate.get_buffer;
+ bits_left := permstate.bits_left;
+
+{$define BITREAD_SAVE_STATE(cinfop,permstate) }
+ cinfop^.src^.next_input_byte := br_state.next_input_byte;
+ cinfop^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ permstate.get_buffer := get_buffer;
+ permstate.bits_left := bits_left;
+
+
+{ These macros provide the in-line portion of bit fetching.
+ Use CHECK_BIT_BUFFER to ensure there are N bits in get_buffer
+ before using GET_BITS, PEEK_BITS, or DROP_BITS.
+ The variables get_buffer and bits_left are assumed to be locals,
+ but the state struct might not be (jpeg_huff_decode needs this).
+ CHECK_BIT_BUFFER(state,n,action);
+ Ensure there are N bits in get_buffer; if suspend, take action.
+ val = GET_BITS(n);
+ Fetch next N bits.
+ val = PEEK_BITS(n);
+ Fetch next N bits without removing them from the buffer.
+ DROP_BITS(n);
+ Discard next N bits.
+ The value N should be a simple variable, not an expression, because it
+ is evaluated multiple times. }
+
+
+{$define CHECK_BIT_BUFFER(state,nbits,action)}
+ if (bits_left < (nbits)) then
+ begin
+ if (not jpeg_fill_bit_buffer(&(state),get_buffer,bits_left,nbits)) then
+ begin
+ action;
+ exit;
+ end;
+ get_buffer := state.get_buffer;
+ bits_left := state.bits_left;
+ end;
+
+
+{$define GET_BITS(nbits)}
+ Dec(bits_left, (nbits));
+ ( (int(get_buffer shr bits_left)) and ( pred(1 shl (nbits)) ) )
+
+{$define PEEK_BITS(nbits)}
+ int(get_buffer shr (bits_left - (nbits))) and pred(1 shl (nbits))
+
+{$define DROP_BITS(nbits)}
+ Dec(bits_left, nbits);
+
+
+
+
+{ Code for extracting next Huffman-coded symbol from input bit stream.
+ Again, this is time-critical and we make the main paths be macros.
+
+ We use a lookahead table to process codes of up to HUFF_LOOKAHEAD bits
+ without looping. Usually, more than 95% of the Huffman codes will be 8
+ or fewer bits long. The few overlength codes are handled with a loop,
+ which need not be inline code.
+
+ Notes about the HUFF_DECODE macro:
+ 1. Near the end of the data segment, we may fail to get enough bits
+ for a lookahead. In that case, we do it the hard way.
+ 2. If the lookahead table contains no entry, the next code must be
+ more than HUFF_LOOKAHEAD bits long.
+ 3. jpeg_huff_decode returns -1 if forced to suspend. }
+
+
+
+
+macro HUFF_DECODE(s,br_state,htbl,return FALSE,slowlabel);
+label showlabel;
+var
+ nb, look : int; {register}
+begin
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto slowlabel;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := htbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := htbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+slowlabel:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,htbl,nb));
+ if (s < 0) then
+ begin
+ result := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+end;
+
+
+{$ENDIF} {MACRO}
+
+{ Expanded entropy decoder object for Huffman decoding.
+
+ The savable_state subrecord contains fields that change within an MCU,
+ but must not be updated permanently until we complete the MCU. }
+
+type
+ savable_state = record
+ last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; { last DC coef for each component }
+ end;
+
+
+type
+ huff_entropy_ptr = ^huff_entropy_decoder;
+ huff_entropy_decoder = record
+ pub : jpeg_entropy_decoder; { public fields }
+
+ { These fields are loaded into local variables at start of each MCU.
+ In case of suspension, we exit WITHOUT updating them. }
+
+ bitstate : bitread_perm_state; { Bit buffer at start of MCU }
+ saved : savable_state; { Other state at start of MCU }
+
+ { These fields are NOT loaded into local working state. }
+ restarts_to_go : uInt; { MCUs left in this restart interval }
+
+ { Pointers to derived tables (these workspaces have image lifespan) }
+ dc_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr;
+ ac_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr;
+
+ { Precalculated info set up by start_pass for use in decode_mcu: }
+
+ { Pointers to derived tables to be used for each block within an MCU }
+ dc_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr;
+ ac_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr;
+ { Whether we care about the DC and AC coefficient values for each block }
+ dc_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean;
+ ac_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean;
+ end;
+
+
+
+{ Initialize for a Huffman-compressed scan. }
+
+{METHODDEF}
+procedure start_pass_huff_decoder (cinfo : j_decompress_ptr);
+var
+ entropy : huff_entropy_ptr;
+ ci, blkn, dctbl, actbl : int;
+ compptr : jpeg_component_info_ptr;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ { Check that the scan parameters Ss, Se, Ah/Al are OK for sequential JPEG.
+ This ought to be an error condition, but we make it a warning because
+ there are some baseline files out there with all zeroes in these bytes. }
+
+ if (cinfo^.Ss <> 0) or (cinfo^.Se <> DCTSIZE2-1) or
+ (cinfo^.Ah <> 0) or (cinfo^.Al <> 0) then
+ WARNMS(j_common_ptr(cinfo), JWRN_NOT_SEQUENTIAL);
+
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ begin
+ compptr := cinfo^.cur_comp_info[ci];
+ dctbl := compptr^.dc_tbl_no;
+ actbl := compptr^.ac_tbl_no;
+ { Compute derived values for Huffman tables }
+ { We may do this more than once for a table, but it's not expensive }
+ jpeg_make_d_derived_tbl(cinfo, TRUE, dctbl,
+ entropy^.dc_derived_tbls[dctbl]);
+ jpeg_make_d_derived_tbl(cinfo, FALSE, actbl,
+ entropy^.ac_derived_tbls[actbl]);
+ { Initialize DC predictions to 0 }
+ entropy^.saved.last_dc_val[ci] := 0;
+ end;
+
+ { Precalculate decoding info for each block in an MCU of this scan }
+ for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
+ begin
+ ci := cinfo^.MCU_membership[blkn];
+ compptr := cinfo^.cur_comp_info[ci];
+ { Precalculate which table to use for each block }
+ entropy^.dc_cur_tbls[blkn] := entropy^.dc_derived_tbls[compptr^.dc_tbl_no];
+ entropy^.ac_cur_tbls[blkn] := entropy^.ac_derived_tbls[compptr^.ac_tbl_no];
+ { Decide whether we really care about the coefficient values }
+ if (compptr^.component_needed) then
+ begin
+ entropy^.dc_needed[blkn] := TRUE;
+ { we don't need the ACs if producing a 1/8th-size image }
+ entropy^.ac_needed[blkn] := (compptr^.DCT_scaled_size > 1);
+ end
+ else
+ begin
+ entropy^.ac_needed[blkn] := FALSE;
+ entropy^.dc_needed[blkn] := FALSE;
+ end;
+ end;
+
+ { Initialize bitread state variables }
+ entropy^.bitstate.bits_left := 0;
+ entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet }
+ entropy^.pub.insufficient_data := FALSE;
+
+ { Initialize restart counter }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+end;
+
+
+{ Compute the derived values for a Huffman table.
+ This routine also performs some validation checks on the table.
+
+ Note this is also used by jdphuff.c. }
+
+{GLOBAL}
+procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr;
+ isDC : boolean;
+ tblno : int;
+ var pdtbl : d_derived_tbl_ptr);
+var
+ htbl : JHUFF_TBL_PTR;
+ dtbl : d_derived_tbl_ptr;
+ p, i, l, si, numsymbols : int;
+ lookbits, ctr : int;
+ huffsize : array[0..257-1] of byte;
+ huffcode : array[0..257-1] of uInt;
+ code : uInt;
+var
+ sym : int;
+begin
+ { Note that huffsize[] and huffcode[] are filled in code-length order,
+ paralleling the order of the symbols themselves in htbl^.huffval[]. }
+
+ { Find the input Huffman table }
+ if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno);
+ if isDC then
+ htbl := cinfo^.dc_huff_tbl_ptrs[tblno]
+ else
+ htbl := cinfo^.ac_huff_tbl_ptrs[tblno];
+ if (htbl = NIL) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno);
+
+ { Allocate a workspace if we haven't already done so. }
+ if (pdtbl = NIL) then
+ pdtbl := d_derived_tbl_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(d_derived_tbl)) );
+ dtbl := pdtbl;
+ dtbl^.pub := htbl; { fill in back link }
+
+ { Figure C.1: make table of Huffman code length for each symbol }
+
+ p := 0;
+ for l := 1 to 16 do
+ begin
+ i := int(htbl^.bits[l]);
+ if (i < 0) or (p + i > 256) then { protect against table overrun }
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+ while (i > 0) do
+ begin
+ huffsize[p] := byte(l);
+ Inc(p);
+ Dec(i);
+ end;
+ end;
+ huffsize[p] := 0;
+ numsymbols := p;
+
+ { Figure C.2: generate the codes themselves }
+ { We also validate that the counts represent a legal Huffman code tree. }
+
+ code := 0;
+ si := huffsize[0];
+ p := 0;
+ while (huffsize[p] <> 0) do
+ begin
+ while (( int (huffsize[p]) ) = si) do
+ begin
+ huffcode[p] := code;
+ Inc(p);
+ Inc(code);
+ end;
+ { code is now 1 more than the last code used for codelength si; but
+ it must still fit in si bits, since no code is allowed to be all ones. }
+
+ if (INT32(code) >= (INT32(1) shl si)) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+
+ code := code shl 1;
+ Inc(si);
+ end;
+
+ { Figure F.15: generate decoding tables for bit-sequential decoding }
+
+ p := 0;
+ for l := 1 to 16 do
+ begin
+ if (htbl^.bits[l] <> 0) then
+ begin
+ { valoffset[l] = huffval[] index of 1st symbol of code length l,
+ minus the minimum code of length l }
+
+ dtbl^.valoffset[l] := INT32(p) - INT32(huffcode[p]);
+ Inc(p, htbl^.bits[l]);
+ dtbl^.maxcode[l] := huffcode[p-1]; { maximum code of length l }
+ end
+ else
+ begin
+ dtbl^.maxcode[l] := -1; { -1 if no codes of this length }
+ end;
+ end;
+ dtbl^.maxcode[17] := long($FFFFF); { ensures jpeg_huff_decode terminates }
+
+ { Compute lookahead tables to speed up decoding.
+ First we set all the table entries to 0, indicating "too long";
+ then we iterate through the Huffman codes that are short enough and
+ fill in all the entries that correspond to bit sequences starting
+ with that code. }
+
+ MEMZERO(@dtbl^.look_nbits, SIZEOF(dtbl^.look_nbits));
+
+ p := 0;
+ for l := 1 to HUFF_LOOKAHEAD do
+ begin
+ for i := 1 to int (htbl^.bits[l]) do
+ begin
+ { l := current code's length, p := its index in huffcode[] & huffval[]. }
+ { Generate left-justified code followed by all possible bit sequences }
+ lookbits := huffcode[p] shl (HUFF_LOOKAHEAD-l);
+ for ctr := pred(1 shl (HUFF_LOOKAHEAD-l)) downto 0 do
+ begin
+ dtbl^.look_nbits[lookbits] := l;
+ dtbl^.look_sym[lookbits] := htbl^.huffval[p];
+ Inc(lookbits);
+ end;
+ Inc(p);
+ end;
+ end;
+
+ { Validate symbols as being reasonable.
+ For AC tables, we make no check, but accept all byte values 0..255.
+ For DC tables, we require the symbols to be in range 0..15.
+ (Tighter bounds could be applied depending on the data depth and mode,
+ but this is sufficient to ensure safe decoding.) }
+
+ if (isDC) then
+ begin
+ for i := 0 to pred(numsymbols) do
+ begin
+ sym := htbl^.huffval[i];
+ if (sym < 0) or (sym > 15) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+ end;
+ end;
+end;
+
+
+{ Out-of-line code for bit fetching (shared with jdphuff.c).
+ See jdhuff.h for info about usage.
+ Note: current values of get_buffer and bits_left are passed as parameters,
+ but are returned in the corresponding fields of the state struct.
+
+ On most machines MIN_GET_BITS should be 25 to allow the full 32-bit width
+ of get_buffer to be used. (On machines with wider words, an even larger
+ buffer could be used.) However, on some machines 32-bit shifts are
+ quite slow and take time proportional to the number of places shifted.
+ (This is true with most PC compilers, for instance.) In this case it may
+ be a win to set MIN_GET_BITS to the minimum value of 15. This reduces the
+ average shift distance at the cost of more calls to jpeg_fill_bit_buffer. }
+
+{$ifdef SLOW_SHIFT_32}
+const
+ MIN_GET_BITS = 15; { minimum allowable value }
+{$else}
+const
+ MIN_GET_BITS = (BIT_BUF_SIZE-7);
+{$endif}
+
+
+{GLOBAL}
+function jpeg_fill_bit_buffer (var state : bitread_working_state;
+ {register} get_buffer : bit_buf_type;
+ {register} bits_left : int;
+ nbits : int) : boolean;
+label
+ no_more_bytes;
+{ Load up the bit buffer to a depth of at least nbits }
+var
+ { Copy heavily used state fields into locals (hopefully registers) }
+ {register} next_input_byte : {const} JOCTETptr;
+ {register} bytes_in_buffer : size_t;
+var
+ {register} c : int;
+var
+ cinfo : j_decompress_ptr;
+begin
+ next_input_byte := state.next_input_byte;
+ bytes_in_buffer := state.bytes_in_buffer;
+ cinfo := state.cinfo;
+
+ { Attempt to load at least MIN_GET_BITS bits into get_buffer. }
+ { (It is assumed that no request will be for more than that many bits.) }
+ { We fail to do so only if we hit a marker or are forced to suspend. }
+
+ if (cinfo^.unread_marker = 0) then { cannot advance past a marker }
+ begin
+ while (bits_left < MIN_GET_BITS) do
+ begin
+ { Attempt to read a byte }
+ if (bytes_in_buffer = 0) then
+ begin
+ if not cinfo^.src^.fill_input_buffer(cinfo) then
+ begin
+ jpeg_fill_bit_buffer := FALSE;
+ exit;
+ end;
+ next_input_byte := cinfo^.src^.next_input_byte;
+ bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ end;
+ Dec(bytes_in_buffer);
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+
+ { If it's $FF, check and discard stuffed zero byte }
+ if (c = $FF) then
+ begin
+ { Loop here to discard any padding FF's on terminating marker,
+ so that we can save a valid unread_marker value. NOTE: we will
+ accept multiple FF's followed by a 0 as meaning a single FF data
+ byte. This data pattern is not valid according to the standard. }
+
+ repeat
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not state.cinfo^.src^.fill_input_buffer (state.cinfo)) then
+ begin
+ jpeg_fill_bit_buffer := FALSE;
+ exit;
+ end;
+ next_input_byte := state.cinfo^.src^.next_input_byte;
+ bytes_in_buffer := state.cinfo^.src^.bytes_in_buffer;
+ end;
+ Dec(bytes_in_buffer);
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ Until (c <> $FF);
+
+ if (c = 0) then
+ begin
+ { Found FF/00, which represents an FF data byte }
+ c := $FF;
+ end
+ else
+ begin
+ { Oops, it's actually a marker indicating end of compressed data.
+ Save the marker code for later use.
+ Fine point: it might appear that we should save the marker into
+ bitread working state, not straight into permanent state. But
+ once we have hit a marker, we cannot need to suspend within the
+ current MCU, because we will read no more bytes from the data
+ source. So it is OK to update permanent state right away. }
+
+ cinfo^.unread_marker := c;
+ { See if we need to insert some fake zero bits. }
+ goto no_more_bytes;
+ end;
+ end;
+
+ { OK, load c into get_buffer }
+ get_buffer := (get_buffer shl 8) or c;
+ Inc(bits_left, 8);
+ end { end while }
+ end
+ else
+ begin
+ no_more_bytes:
+ { We get here if we've read the marker that terminates the compressed
+ data segment. There should be enough bits in the buffer register
+ to satisfy the request; if so, no problem. }
+
+ if (nbits > bits_left) then
+ begin
+ { Uh-oh. Report corrupted data to user and stuff zeroes into
+ the data stream, so that we can produce some kind of image.
+ We use a nonvolatile flag to ensure that only one warning message
+ appears per data segment. }
+
+ if not cinfo^.entropy^.insufficient_data then
+ begin
+ WARNMS(j_common_ptr(cinfo), JWRN_HIT_MARKER);
+ cinfo^.entropy^.insufficient_data := TRUE;
+ end;
+ { Fill the buffer with zero bits }
+ get_buffer := get_buffer shl (MIN_GET_BITS - bits_left);
+ bits_left := MIN_GET_BITS;
+ end;
+ end;
+
+ { Unload the local registers }
+ state.next_input_byte := next_input_byte;
+ state.bytes_in_buffer := bytes_in_buffer;
+ state.get_buffer := get_buffer;
+ state.bits_left := bits_left;
+
+ jpeg_fill_bit_buffer := TRUE;
+end;
+
+
+{ Out-of-line code for Huffman code decoding.
+ See jdhuff.h for info about usage. }
+
+{GLOBAL}
+function jpeg_huff_decode (var state : bitread_working_state;
+ {register} get_buffer : bit_buf_type;
+ {register} bits_left : int;
+ htbl : d_derived_tbl_ptr;
+ min_bits : int) : int;
+var
+ {register} l : int;
+ {register} code : INT32;
+begin
+ l := min_bits;
+
+ { HUFF_DECODE has determined that the code is at least min_bits }
+ { bits long, so fetch that many bits in one swoop. }
+
+ {CHECK_BIT_BUFFER(state, l, return -1);}
+ if (bits_left < l) then
+ begin
+ if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, l)) then
+ begin
+ jpeg_huff_decode := -1;
+ exit;
+ end;
+ get_buffer := state.get_buffer;
+ bits_left := state.bits_left;
+ end;
+
+ {code := GET_BITS(l);}
+ Dec(bits_left, l);
+ code := (int(get_buffer shr bits_left)) and ( pred(1 shl l) );
+
+ { Collect the rest of the Huffman code one bit at a time. }
+ { This is per Figure F.16 in the JPEG spec. }
+
+ while (code > htbl^.maxcode[l]) do
+ begin
+ code := code shl 1;
+ {CHECK_BIT_BUFFER(state, 1, return -1);}
+ if (bits_left < 1) then
+ begin
+ if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, 1)) then
+ begin
+ jpeg_huff_decode := -1;
+ exit;
+ end;
+ get_buffer := state.get_buffer;
+ bits_left := state.bits_left;
+ end;
+
+ {code := code or GET_BITS(1);}
+ Dec(bits_left);
+ code := code or ( (int(get_buffer shr bits_left)) and pred(1 shl 1) );
+
+ Inc(l);
+ end;
+
+ { Unload the local registers }
+ state.get_buffer := get_buffer;
+ state.bits_left := bits_left;
+
+ { With garbage input we may reach the sentinel value l := 17. }
+
+ if (l > 16) then
+ begin
+ WARNMS(j_common_ptr(state.cinfo), JWRN_HUFF_BAD_CODE);
+ jpeg_huff_decode := 0; { fake a zero as the safest result }
+ exit;
+ end;
+
+ jpeg_huff_decode := htbl^.pub^.huffval[ int (code + htbl^.valoffset[l]) ];
+end;
+
+
+{ Figure F.12: extend sign bit.
+ On some machines, a shift and add will be faster than a table lookup. }
+
+{$ifdef AVOID_TABLES}
+
+#define HUFF_EXTEND(x,s) ((x) < (1<<((s)-1)) ? (x) + (((-1)<<(s)) + 1) : (x))
+
+{$else}
+
+{$define HUFF_EXTEND(x,s)
+ if (x < extend_test[s]) then
+ := x + extend_offset[s]
+ else
+ x;}
+
+const
+ extend_test : array[0..16-1] of int = { entry n is 2**(n-1) }
+ ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040,
+ $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000);
+
+const
+ extend_offset : array[0..16-1] of int = { entry n is (-1 << n) + 1 }
+(0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1,
+ ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1,
+ ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1,((-1) shl 12) + 1,
+ ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1);
+
+{$endif} { AVOID_TABLES }
+
+
+{ Check for a restart marker & resynchronize decoder.
+ Returns FALSE if must suspend. }
+
+{LOCAL}
+function process_restart (cinfo : j_decompress_ptr) : boolean;
+var
+ entropy : huff_entropy_ptr;
+ ci : int;
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ { Throw away any unused bits remaining in bit buffer; }
+ { include any full bytes in next_marker's count of discarded bytes }
+ Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8);
+ entropy^.bitstate.bits_left := 0;
+
+ { Advance past the RSTn marker }
+ if (not cinfo^.marker^.read_restart_marker (cinfo)) then
+ begin
+ process_restart := FALSE;
+ exit;
+ end;
+
+ { Re-initialize DC predictions to 0 }
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ entropy^.saved.last_dc_val[ci] := 0;
+
+ { Reset restart counter }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+
+ { Reset out-of-data flag, unless read_restart_marker left us smack up
+ against a marker. In that case we will end up treating the next data
+ segment as empty, and we can avoid producing bogus output pixels by
+ leaving the flag set. }
+
+ if (cinfo^.unread_marker = 0) then
+ entropy^.pub.insufficient_data := FALSE;
+
+ process_restart := TRUE;
+end;
+
+
+{ Decode and return one MCU's worth of Huffman-compressed coefficients.
+ The coefficients are reordered from zigzag order into natural array order,
+ but are not dequantized.
+
+ The i'th block of the MCU is stored into the block pointed to by
+ MCU_data[i]. WE ASSUME THIS AREA HAS BEEN ZEROED BY THE CALLER.
+ (Wholesale zeroing is usually a little faster than retail...)
+
+ Returns FALSE if data source requested suspension. In that case no
+ changes have been made to permanent state. (Exception: some output
+ coefficients may already have been assigned. This is harmless for
+ this module, since we'll just re-assign them on the next call.) }
+
+{METHODDEF}
+function decode_mcu (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+label
+ label1, label2, label3;
+var
+ entropy : huff_entropy_ptr;
+ {register} s, k, r : int;
+ blkn, ci : int;
+ block : JBLOCK_PTR;
+ {BITREAD_STATE_VARS}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+
+ state : savable_state;
+ dctbl : d_derived_tbl_ptr;
+ actbl : d_derived_tbl_ptr;
+var
+ nb, look : int; {register}
+begin
+ entropy := huff_entropy_ptr (cinfo^.entropy);
+
+ { Process restart marker if needed; may have to suspend }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if (not process_restart(cinfo)) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ end;
+
+ { If we've run out of data, just leave the MCU set to zeroes.
+ This way, we return uniform gray for the remainder of the segment. }
+
+ if not entropy^.pub.insufficient_data then
+ begin
+
+ { Load up working state }
+ {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);}
+ br_state.cinfo := cinfo;
+ br_state.next_input_byte := cinfo^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ get_buffer := entropy^.bitstate.get_buffer;
+ bits_left := entropy^.bitstate.bits_left;
+
+ {ASSIGN_STATE(state, entropy^.saved);}
+ state := entropy^.saved;
+
+ { Outer loop handles each block in the MCU }
+
+ for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
+ begin
+ block := JBLOCK_PTR(MCU_data[blkn]);
+ dctbl := entropy^.dc_cur_tbls[blkn];
+ actbl := entropy^.ac_cur_tbls[blkn];
+
+ { Decode a single block's worth of coefficients }
+
+ { Section F.2.2.1: decode the DC coefficient difference }
+ {HUFF_DECODE(s, br_state, dctbl, return FALSE, label1);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu := False;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label1;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := dctbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := dctbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label1:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,dctbl,nb);
+ if (s < 0) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ if (s <> 0) then
+ begin
+ {CHECK_BIT_BUFFER(br_state, s, return FALSE);}
+ if (bits_left < s) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(s);}
+ Dec(bits_left, s);
+ r := ( int(get_buffer shr bits_left)) and ( pred(1 shl s) );
+
+ {s := HUFF_EXTEND(r, s);}
+ if (r < extend_test[s]) then
+ s := r + extend_offset[s]
+ else
+ s := r;
+ end;
+
+ if (entropy^.dc_needed[blkn]) then
+ begin
+ { Convert DC difference to actual value, update last_dc_val }
+ ci := cinfo^.MCU_membership[blkn];
+ Inc(s, state.last_dc_val[ci]);
+ state.last_dc_val[ci] := s;
+ { Output the DC coefficient (assumes jpeg_natural_order[0] := 0) }
+ block^[0] := JCOEF (s);
+ end;
+
+ if (entropy^.ac_needed[blkn]) then
+ begin
+
+ { Section F.2.2.2: decode the AC coefficients }
+ { Since zeroes are skipped, output area must be cleared beforehand }
+ k := 1;
+ while (k < DCTSIZE2) do { Nomssi: k is incr. in the loop }
+ begin
+ {HUFF_DECODE(s, br_state, actbl, return FALSE, label2);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu := False;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label2;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := actbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := actbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label2:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb);
+ if (s < 0) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ r := s shr 4;
+ s := s and 15;
+
+ if (s <> 0) then
+ begin
+ Inc(k, r);
+ {CHECK_BIT_BUFFER(br_state, s, return FALSE);}
+ if (bits_left < s) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(s);}
+ Dec(bits_left, s);
+ r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) );
+
+ {s := HUFF_EXTEND(r, s);}
+ if (r < extend_test[s]) then
+ s := r + extend_offset[s]
+ else
+ s := r;
+ { Output coefficient in natural (dezigzagged) order.
+ Note: the extra entries in jpeg_natural_order[] will save us
+ if k >= DCTSIZE2, which could happen if the data is corrupted. }
+
+ block^[jpeg_natural_order[k]] := JCOEF (s);
+ end
+ else
+ begin
+ if (r <> 15) then
+ break;
+ Inc(k, 15);
+ end;
+ Inc(k);
+ end;
+ end
+ else
+ begin
+
+ { Section F.2.2.2: decode the AC coefficients }
+ { In this path we just discard the values }
+ k := 1;
+ while (k < DCTSIZE2) do
+ begin
+ {HUFF_DECODE(s, br_state, actbl, return FALSE, label3);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu := False;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label3;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := actbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := actbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label3:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb);
+ if (s < 0) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ r := s shr 4;
+ s := s and 15;
+
+ if (s <> 0) then
+ begin
+ Inc(k, r);
+ {CHECK_BIT_BUFFER(br_state, s, return FALSE);}
+ if (bits_left < s) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then
+ begin
+ decode_mcu := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {DROP_BITS(s);}
+ Dec(bits_left, s);
+ end
+ else
+ begin
+ if (r <> 15) then
+ break;
+ Inc(k, 15);
+ end;
+ Inc(k);
+ end;
+
+ end;
+ end;
+
+ { Completed MCU, so update state }
+ {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);}
+ cinfo^.src^.next_input_byte := br_state.next_input_byte;
+ cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ entropy^.bitstate.get_buffer := get_buffer;
+ entropy^.bitstate.bits_left := bits_left;
+
+ {ASSIGN_STATE(entropy^.saved, state);}
+ entropy^.saved := state;
+
+ end;
+
+ { Account for restart interval (no-op if not using restarts) }
+ Dec(entropy^.restarts_to_go);
+
+ decode_mcu := TRUE;
+end;
+
+
+{ Module initialization routine for Huffman entropy decoding. }
+
+{GLOBAL}
+procedure jinit_huff_decoder (cinfo : j_decompress_ptr);
+var
+ entropy : huff_entropy_ptr;
+ i : int;
+begin
+ entropy := huff_entropy_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(huff_entropy_decoder)) );
+ cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy);
+ entropy^.pub.start_pass := start_pass_huff_decoder;
+ entropy^.pub.decode_mcu := decode_mcu;
+
+ { Mark tables unallocated }
+ for i := 0 to pred(NUM_HUFF_TBLS) do
+ begin
+ entropy^.dc_derived_tbls[i] := NIL;
+ entropy^.ac_derived_tbls[i] := NIL;
+ end;
+end;
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjdinput.pas b/src/lib/vampimg/JpegLib/imjdinput.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdmainct.pas b/src/lib/vampimg/JpegLib/imjdmainct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdmarker.pas b/src/lib/vampimg/JpegLib/imjdmarker.pas
--- /dev/null
@@ -0,0 +1,2644 @@
+unit imjdmarker;
+
+{ This file contains routines to decode JPEG datastream markers.
+ Most of the complexity arises from our desire to support input
+ suspension: if not all of the data for a marker is available;
+ we must exit back to the application. On resumption; we reprocess
+ the marker. }
+
+{ Original: jdmarker.c; Copyright (C) 1991-1998; Thomas G. Lane. }
+{ History
+ 9.7.96 Conversion to pascal started jnn
+ 22.3.98 updated to 6b jnn }
+
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg,
+ imjinclude,
+ imjdeferr,
+ imjerror,
+ imjcomapi,
+ imjpeglib;
+
+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 = uint; { JPEG marker codes }
+
+{ Private state }
+
+type
+ my_marker_ptr = ^my_marker_reader;
+ my_marker_reader = record
+ pub : jpeg_marker_reader; { public fields }
+
+ { Application-overridable marker processing methods }
+ process_COM : jpeg_marker_parser_method;
+ process_APPn : array[0..16-1] of jpeg_marker_parser_method;
+
+ { Limit on marker data length to save for each marker type }
+ length_limit_COM : uint;
+ length_limit_APPn : array[0..16-1] of uint;
+
+ { Status of COM/APPn marker saving }
+ cur_marker : jpeg_saved_marker_ptr; { NIL if not processing a marker }
+ bytes_read : uint; { data bytes read so far in marker }
+ { Note: cur_marker is not linked into marker_list until it's all read. }
+ end;
+
+{GLOBAL}
+function jpeg_resync_to_restart(cinfo : j_decompress_ptr;
+ desired : int) : boolean;
+{GLOBAL}
+procedure jinit_marker_reader (cinfo : j_decompress_ptr);
+
+{$ifdef SAVE_MARKERS_SUPPORTED}
+
+{GLOBAL}
+procedure jpeg_save_markers (cinfo : j_decompress_ptr;
+ marker_code : int;
+ length_limit : uint);
+{$ENDIF}
+
+{GLOBAL}
+procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr;
+ marker_code : int;
+ routine : jpeg_marker_parser_method);
+
+implementation
+
+uses
+ imjutils;
+
+{ At all times, cinfo1.src.next_input_byte and .bytes_in_buffer reflect
+ the current restart point; we update them only when we have reached a
+ suitable place to restart if a suspension occurs. }
+
+
+{ Routines to process JPEG markers.
+
+ Entry condition: JPEG marker itself has been read and its code saved
+ in cinfo^.unread_marker; input restart point is just after the marker.
+
+ Exit: if return TRUE, have read and processed any parameters, and have
+ updated the restart point to point after the parameters.
+ If return FALSE, was forced to suspend before reaching end of
+ marker parameters; restart point has not been moved. Same routine
+ will be called again after application supplies more input data.
+
+ This approach to suspension assumes that all of a marker's parameters
+ can fit into a single input bufferload. This should hold for "normal"
+ markers. Some COM/APPn markers might have large parameter segments
+ that might not fit. If we are simply dropping such a marker, we use
+ skip_input_data to get past it, and thereby put the problem on the
+ source manager's shoulders. If we are saving the marker's contents
+ into memory, we use a slightly different convention: when forced to
+ suspend, the marker processor updates the restart point to the end of
+ what it's consumed (ie, the end of the buffer) before returning FALSE.
+ On resumption, cinfo->unread_marker still contains the marker code,
+ but the data source will point to the next chunk of marker data.
+ The marker processor must retain internal state to deal with this.
+
+ Note that we don't bother to avoid duplicate trace messages if a
+ suspension occurs within marker parameters. Other side effects
+ require more care. }
+
+{LOCAL}
+function get_soi (cinfo : j_decompress_ptr) : boolean;
+{ Process an SOI marker }
+var
+ i : int;
+begin
+ {$IFDEF DEBUG}
+ TRACEMS(j_common_ptr(cinfo), 1, JTRC_SOI);
+ {$ENDIF}
+
+ if (cinfo^.marker^.saw_SOI) then
+ ERREXIT(j_common_ptr(cinfo), JERR_SOI_DUPLICATE);
+
+ { Reset all parameters that are defined to be reset by SOI }
+
+ for i := 0 to Pred(NUM_ARITH_TBLS) do
+ with cinfo^ do
+ begin
+ arith_dc_L[i] := 0;
+ arith_dc_U[i] := 1;
+ arith_ac_K[i] := 5;
+ end;
+ cinfo^.restart_interval := 0;
+
+ { Set initial assumptions for colorspace etc }
+
+ with cinfo^ do
+ begin
+ jpeg_color_space := JCS_UNKNOWN;
+ CCIR601_sampling := FALSE; { Assume non-CCIR sampling??? }
+
+ saw_JFIF_marker := FALSE;
+ JFIF_major_version := 1; { set default JFIF APP0 values }
+ JFIF_minor_version := 1;
+ density_unit := 0;
+ X_density := 1;
+ Y_density := 1;
+ saw_Adobe_marker := FALSE;
+ Adobe_transform := 0;
+
+ marker^.saw_SOI := TRUE;
+ end;
+ get_soi := TRUE;
+end; { get_soi }
+
+
+{LOCAL}
+function get_sof(cinfo : j_decompress_ptr;
+ is_prog : boolean;
+ is_arith : boolean) : boolean;
+{ Process a SOFn marker }
+var
+ length : INT32;
+ c, ci : int;
+ compptr : jpeg_component_info_ptr;
+{ Declare and initialize local copies of input pointer/count }
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+{}
+ cinfo^.progressive_mode := is_prog;
+ cinfo^.arith_code := is_arith;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+
+ { Read a byte into variable cinfo^.data_precision.
+ If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ cinfo^.data_precision := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ cinfo^.image_height should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ cinfo^.image_height := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( cinfo^.image_height, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ cinfo^.image_width should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ cinfo^.image_width := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( cinfo^.image_width, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ { Read a byte into variable cinfo^.num_components.
+ If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ cinfo^.num_components := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ Dec(length, 8);
+
+ {$IFDEF DEBUG}
+ TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF, cinfo^.unread_marker,
+ int(cinfo^.image_width), int(cinfo^.image_height),
+ cinfo^.num_components);
+ {$ENDIF}
+
+ if (cinfo^.marker^.saw_SOF) then
+ ERREXIT(j_common_ptr(cinfo), JERR_SOF_DUPLICATE);
+
+ { We don't support files in which the image height is initially specified }
+ { as 0 and is later redefined by DNL. As long as we have to check that, }
+ { might as well have a general sanity check. }
+ if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0)
+ or (cinfo^.num_components <= 0) then
+ ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE);
+
+ if (length <> (cinfo^.num_components * 3)) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+ if (cinfo^.comp_info = NIL) then { do only once, even if suspend }
+ cinfo^.comp_info := jpeg_component_info_list_ptr(
+ cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE,
+ cinfo^.num_components * SIZEOF(jpeg_component_info)));
+
+ compptr := jpeg_component_info_ptr(cinfo^.comp_info);
+ for ci := 0 to pred(cinfo^.num_components) do
+ begin
+ compptr^.component_index := ci;
+
+ { Read a byte into variable compptr^.component_id.
+ If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ compptr^.component_id := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ compptr^.h_samp_factor := (c shr 4) and 15;
+ compptr^.v_samp_factor := (c ) and 15;
+
+ { Read a byte into variable compptr^.quant_tbl_no.
+ If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sof := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ compptr^.quant_tbl_no := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ {$IFDEF DEBUG}
+ TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF_COMPONENT,
+ compptr^.component_id, compptr^.h_samp_factor,
+ compptr^.v_samp_factor, compptr^.quant_tbl_no);
+ {$ENDIF}
+
+ Inc(compptr);
+ end;
+
+ cinfo^.marker^.saw_SOF := TRUE;
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_sof := TRUE;
+end; { get_sof }
+
+
+{LOCAL}
+function get_sos (cinfo : j_decompress_ptr) : boolean;
+{ Process a SOS marker }
+label
+ id_found;
+var
+ length : INT32;
+ i, ci, n, c, cc : int;
+ compptr : jpeg_component_info_ptr;
+{ Declare and initialize local copies of input pointer/count }
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr; { Array[] of JOCTET; }
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{}
+
+ if not cinfo^.marker^.saw_SOF then
+ ERREXIT(j_common_ptr(cinfo), JERR_SOS_NO_SOF);
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+
+ { Read a byte into variable n (Number of components).
+ If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ n := GETJOCTET(next_input_byte^); { Number of components }
+ Inc(next_input_byte);
+
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_SOS, n);
+ {$ENDIF}
+
+ if ((length <> (n * 2 + 6)) or (n < 1) or (n > MAX_COMPS_IN_SCAN)) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+ cinfo^.comps_in_scan := n;
+
+ { Collect the component-spec parameters }
+
+ for i := 0 to Pred(n) do
+ begin
+ { Read a byte into variable cc. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ cc := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ compptr := jpeg_component_info_ptr(cinfo^.comp_info);
+ for ci := 0 to Pred(cinfo^.num_components) do
+ begin
+ if (cc = compptr^.component_id) then
+ goto id_found;
+ Inc(compptr);
+ end;
+
+ ERREXIT1(j_common_ptr(cinfo), JERR_BAD_COMPONENT_ID, cc);
+
+ id_found:
+
+ cinfo^.cur_comp_info[i] := compptr;
+ compptr^.dc_tbl_no := (c shr 4) and 15;
+ compptr^.ac_tbl_no := (c ) and 15;
+
+ {$IFDEF DEBUG}
+ TRACEMS3(j_common_ptr(cinfo), 1, JTRC_SOS_COMPONENT, cc,
+ compptr^.dc_tbl_no, compptr^.ac_tbl_no);
+ {$ENDIF}
+ end;
+
+ { Collect the additional scan parameters Ss, Se, Ah/Al. }
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ cinfo^.Ss := c;
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ cinfo^.Se := c;
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_sos := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ cinfo^.Ah := (c shr 4) and 15;
+ cinfo^.Al := (c ) and 15;
+
+ {$IFDEF DEBUG}
+ TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOS_PARAMS, cinfo^.Ss, cinfo^.Se,
+ cinfo^.Ah, cinfo^.Al);
+ {$ENDIF}
+
+ { Prepare to scan data & restart markers }
+ cinfo^.marker^.next_restart_num := 0;
+
+ { Count another SOS marker }
+ Inc( cinfo^.input_scan_number );
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_sos := TRUE;
+end; { get_sos }
+
+
+{METHODDEF}
+function skip_variable (cinfo : j_decompress_ptr) : boolean;
+{ Skip over an unknown or uninteresting variable-length marker }
+var
+ length : INT32;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr; { Array[] of JOCTET; }
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ skip_variable := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := uint(GETJOCTET(next_input_byte^)) shl 8;
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ skip_variable := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET(next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec(length, 2);
+
+ {$IFDEF DEBUG}
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER,
+ cinfo^.unread_marker, int(length));
+ {$ENDIF}
+
+ { Unload the local copies --- do this only at a restart boundary }
+ { do before skip_input_data }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ if (length > 0) then
+ cinfo^.src^.skip_input_data(cinfo, long(length));
+
+ skip_variable := TRUE;
+end; { skip_variable }
+
+
+{$IFDEF D_ARITH_CODING_SUPPORTED}
+
+{LOCAL}
+function get_dac (cinfo : j_decompress_ptr) : boolean;
+{ Process a DAC marker }
+var
+ length : INT32;
+ index, val : int;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dac := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dac := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec(length, 2);
+
+ while (length > 0) do
+ begin
+ { Read a byte into variable index. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dac := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ index := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ { Read a byte into variable val. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dac := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ val := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ Dec( length, 2);
+
+ {$IFDEF DEBUG}
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DAC, index, val);
+ {$ENDIF}
+
+ if (index < 0) or (index >= (2*NUM_ARITH_TBLS)) then
+ ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_INDEX, index);
+
+ if (index >= NUM_ARITH_TBLS) then
+ begin { define AC table }
+ cinfo^.arith_ac_K[index-NUM_ARITH_TBLS] := UINT8(val);
+ end
+ else
+ begin { define DC table }
+ cinfo^.arith_dc_L[index] := UINT8(val and $0F);
+ cinfo^.arith_dc_U[index] := UINT8(val shr 4);
+ if (cinfo^.arith_dc_L[index] > cinfo^.arith_dc_U[index]) then
+ ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_VALUE, val);
+ end;
+ end;
+
+ if (length <> 0) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_dac := TRUE;
+end; { get_dac }
+
+{$ELSE}
+
+{LOCAL}
+function get_dac (cinfo : j_decompress_ptr) : boolean;
+begin
+ get_dac := skip_variable(cinfo);
+end;
+
+{$ENDIF}
+
+{LOCAL}
+function get_dht (cinfo : j_decompress_ptr) : boolean;
+{ Process a DHT marker }
+var
+ length : INT32;
+ bits : Array[0..17-1] of UINT8;
+ huffval : Array[0..256-1] of UINT8;
+ i, index, count : int;
+ htblptr : ^JHUFF_TBL_PTR;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dht := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dht := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec(length, 2);
+
+ while (length > 16) do
+ begin
+ { Read a byte into variable index. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dht := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ index := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DHT, index);
+ {$ENDIF}
+
+ bits[0] := 0;
+ count := 0;
+ for i := 1 to 16 do
+ begin
+ { Read a byte into variable bits[i]. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dht := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ bits[i] := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ Inc( count, bits[i] );
+ end;
+
+ Dec( length, (1 + 16) );
+
+ {$IFDEF DEBUG}
+ TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS,
+ bits[1], bits[2], bits[3], bits[4],
+ bits[5], bits[6], bits[7], bits[8]);
+ TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS,
+ bits[9], bits[10], bits[11], bits[12],
+ bits[13], bits[14], bits[15], bits[16]);
+ {$ENDIF}
+
+ { Here we just do minimal validation of the counts to avoid walking
+ off the end of our table space. jdhuff.c will check more carefully. }
+
+ if (count > 256) or (INT32(count) > length) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
+
+ for i := 0 to Pred(count) do
+ begin
+ { Read a byte into variable huffval[i]. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dht := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ huffval[i] := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ end;
+
+ Dec( length, count );
+
+ if (index and $10)<>0 then
+ begin { AC table definition }
+ Dec( index, $10 );
+ htblptr := @cinfo^.ac_huff_tbl_ptrs[index];
+ end
+ else
+ begin { DC table definition }
+ htblptr := @cinfo^.dc_huff_tbl_ptrs[index];
+ end;
+
+ if (index < 0) or (index >= NUM_HUFF_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_DHT_INDEX, index);
+
+ if (htblptr^ = NIL) then
+ htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo));
+
+ MEMCOPY(@(htblptr^)^.bits, @bits, SIZEOF((htblptr^)^.bits));
+ MEMCOPY(@(htblptr^)^.huffval, @huffval, SIZEOF((htblptr^)^.huffval));
+ end;
+
+ if (length <> 0) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_dht := TRUE;
+end; { get_dht }
+
+
+{LOCAL}
+function get_dqt (cinfo : j_decompress_ptr) : boolean;
+{ Process a DQT marker }
+var
+ length : INT32;
+ n, i, prec : int;
+ tmp : uint;
+ quant_ptr : JQUANT_TBL_PTR;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec( length, 2 );
+
+ while (length > 0) do
+ begin
+ { Read a byte into variable n. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ n := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ prec := n shr 4;
+ n := n and $0F;
+
+ {$IFDEF DEBUG}
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DQT, n, prec);
+ {$ENDIF}
+
+ if (n >= NUM_QUANT_TBLS) then
+ ERREXIT1(j_common_ptr(cinfo) , JERR_DQT_INDEX, n);
+
+ if (cinfo^.quant_tbl_ptrs[n] = NIL) then
+ cinfo^.quant_tbl_ptrs[n] := jpeg_alloc_quant_table(j_common_ptr(cinfo));
+ quant_ptr := cinfo^.quant_tbl_ptrs[n];
+
+ for i := 0 to Pred(DCTSIZE2) do
+ begin
+ if (prec <> 0) then
+ begin
+ { Read two bytes interpreted as an unsigned 16-bit integer.
+ tmp should be declared unsigned int or perhaps INT32. }
+
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ tmp := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( tmp, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ end
+ else
+ begin
+ { Read a byte into variable tmp. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dqt := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ tmp := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ end;
+
+ { We convert the zigzag-order table to natural array order. }
+ quant_ptr^.quantval[jpeg_natural_order[i]] := UINT16(tmp);
+ end;
+
+ if (cinfo^.err^.trace_level >= 2) then
+ begin
+ i := 0;
+ while i < Pred(DCTSIZE2) do
+ begin
+ {$IFDEF DEBUG}
+ TRACEMS8(j_common_ptr(cinfo), 2, JTRC_QUANTVALS,
+ quant_ptr^.quantval[i], quant_ptr^.quantval[i+1],
+ quant_ptr^.quantval[i+2], quant_ptr^.quantval[i+3],
+ quant_ptr^.quantval[i+4], quant_ptr^.quantval[i+5],
+ quant_ptr^.quantval[i+6], quant_ptr^.quantval[i+7]);
+ {$ENDIF}
+ Inc(i, 8);
+ end;
+ end;
+
+ Dec( length, DCTSIZE2+1 );
+ if (prec <> 0) then
+ Dec( length, DCTSIZE2 );
+ end;
+
+ if (length <> 0) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_dqt := TRUE;
+end; { get_dqt }
+
+
+{LOCAL}
+function get_dri (cinfo : j_decompress_ptr) : boolean;
+{ Process a DRI marker }
+var
+ length : INT32;
+ tmp : uint;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dri := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dri := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ if (length <> 4) then
+ ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH);
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ tmp should be declared unsigned int or perhaps INT32. }
+
+{ make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dri := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ tmp := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_dri := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( tmp, GETJOCTET( next_input_byte^));
+ Inc( next_input_byte );
+
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DRI, tmp);
+ {$ENDIF}
+
+ cinfo^.restart_interval := tmp;
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ get_dri := TRUE;
+end; { get_dri }
+
+
+{ Routines for processing APPn and COM markers.
+ These are either saved in memory or discarded, per application request.
+ APP0 and APP14 are specially checked to see if they are
+ JFIF and Adobe markers, respectively. }
+
+const
+ APP0_DATA_LEN = 14; { Length of interesting data in APP0 }
+ APP14_DATA_LEN = 12; { Length of interesting data in APP14 }
+ APPN_DATA_LEN = 14; { Must be the largest of the above!! }
+
+
+{LOCAL}
+procedure examine_app0 (cinfo : j_decompress_ptr;
+ var data : array of JOCTET;
+ datalen : uint;
+ remaining : INT32);
+
+{ Examine first few bytes from an APP0.
+ Take appropriate action if it is a JFIF marker.
+ datalen is # of bytes at data[], remaining is length of rest of marker data.
+}
+{$IFDEF DEBUG}
+var
+ totallen : INT32;
+{$ENDIF}
+begin
+ {$IFDEF DEBUG}
+ totallen := INT32(datalen) + remaining;
+ {$ENDIF}
+ if (datalen >= APP0_DATA_LEN) and
+ (GETJOCTET(data[0]) = $4A) and
+ (GETJOCTET(data[1]) = $46) and
+ (GETJOCTET(data[2]) = $49) and
+ (GETJOCTET(data[3]) = $46) and
+ (GETJOCTET(data[4]) = 0) then
+ begin
+ { Found JFIF APP0 marker: save info }
+ cinfo^.saw_JFIF_marker := TRUE;
+ cinfo^.JFIF_major_version := GETJOCTET(data[5]);
+ cinfo^.JFIF_minor_version := GETJOCTET(data[6]);
+ cinfo^.density_unit := GETJOCTET(data[7]);
+ cinfo^.X_density := (GETJOCTET(data[8]) shl 8) + GETJOCTET(data[9]);
+ cinfo^.Y_density := (GETJOCTET(data[10]) shl 8) + GETJOCTET(data[11]);
+ { Check version.
+ Major version must be 1, anything else signals an incompatible change.
+ (We used to treat this as an error, but now it's a nonfatal warning,
+ because some bozo at Hijaak couldn't read the spec.)
+ Minor version should be 0..2, but process anyway if newer. }
+
+ if (cinfo^.JFIF_major_version <> 1) then
+ WARNMS2(j_common_ptr(cinfo), JWRN_JFIF_MAJOR,
+ cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version);
+ { Generate trace messages }
+ {$IFDEF DEBUG}
+ TRACEMS5(j_common_ptr(cinfo), 1, JTRC_JFIF,
+ cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version,
+ cinfo^.X_density, cinfo^.Y_density, cinfo^.density_unit);
+ { Validate thumbnail dimensions and issue appropriate messages }
+ if (GETJOCTET(data[12]) or GETJOCTET(data[13])) <> 0 then
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_THUMBNAIL,
+ GETJOCTET(data[12]), GETJOCTET(data[13]));
+ Dec(totallen, APP0_DATA_LEN);
+ if (totallen <>
+ ( INT32(GETJOCTET(data[12])) * INT32(GETJOCTET(data[13])) * INT32(3) )) then
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_JFIF_BADTHUMBNAILSIZE, int(totallen));
+ {$ENDIF}
+ end
+ else
+ if (datalen >= 6) and
+ (GETJOCTET(data[0]) = $4A) and
+ (GETJOCTET(data[1]) = $46) and
+ (GETJOCTET(data[2]) = $58) and
+ (GETJOCTET(data[3]) = $58) and
+ (GETJOCTET(data[4]) = 0) then
+ begin
+ { Found JFIF "JFXX" extension APP0 marker }
+ { The library doesn't actually do anything with these,
+ but we try to produce a helpful trace message. }
+ {$IFDEF DEBUG}
+ case (GETJOCTET(data[5])) of
+ $10:
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_JPEG, int(totallen));
+ $11:
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_PALETTE, int(totallen));
+ $13:
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_RGB, int(totallen));
+ else
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_EXTENSION,
+ GETJOCTET(data[5]), int(totallen));
+ end;
+ {$ENDIF}
+ end
+ else
+ begin
+ { Start of APP0 does not match "JFIF" or "JFXX", or too short }
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP0, int(totallen));
+ {$ENDIF}
+ end;
+end;
+
+
+{LOCAL}
+procedure examine_app14 (cinfo : j_decompress_ptr;
+ var data : array of JOCTET;
+ datalen : uint;
+ remaining : INT32);
+{ Examine first few bytes from an APP14.
+ Take appropriate action if it is an Adobe marker.
+ datalen is # of bytes at data[], remaining is length of rest of marker data.
+ }
+var
+ {$IFDEF DEBUG}
+ version, flags0, flags1,
+ {$ENDIF}
+ transform : uint;
+begin
+ if (datalen >= APP14_DATA_LEN) and
+ (GETJOCTET(data[0]) = $41) and
+ (GETJOCTET(data[1]) = $64) and
+ (GETJOCTET(data[2]) = $6F) and
+ (GETJOCTET(data[3]) = $62) and
+ (GETJOCTET(data[4]) = $65) then
+ begin
+ { Found Adobe APP14 marker }
+ {$IFDEF DEBUG}
+ version := (GETJOCTET(data[5]) shl 8) + GETJOCTET(data[6]);
+ flags0 := (GETJOCTET(data[7]) shl 8) + GETJOCTET(data[8]);
+ flags1 := (GETJOCTET(data[9]) shl 8) + GETJOCTET(data[10]);
+ {$ENDIF}
+ transform := GETJOCTET(data[11]);
+ {$IFDEF DEBUG}
+ TRACEMS4(j_common_ptr(cinfo), 1, JTRC_ADOBE, version, flags0, flags1, transform);
+ {$ENDIF}
+ cinfo^.saw_Adobe_marker := TRUE;
+ cinfo^.Adobe_transform := UINT8 (transform);
+ end
+ else
+ begin
+ { Start of APP14 does not match "Adobe", or too short }
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP14, int (datalen + remaining));
+ {$ENDIF}
+ end;
+end;
+
+
+{METHODDEF}
+function get_interesting_appn (cinfo : j_decompress_ptr) : boolean;
+{ Process an APP0 or APP14 marker without saving it }
+var
+ length : INT32;
+ b : array[0..APPN_DATA_LEN-1] of JOCTET;
+ i, numtoread : uint;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+{ Read two bytes interpreted as an unsigned 16-bit integer.
+ length should be declared unsigned int or perhaps INT32. }
+
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_interesting_appn := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_interesting_appn := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET(next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec(length, 2);
+
+ { get the interesting part of the marker data }
+ if (length >= APPN_DATA_LEN) then
+ numtoread := APPN_DATA_LEN
+ else
+ if (length > 0) then
+ numtoread := uint(length)
+ else
+ numtoread := 0;
+ for i := 0 to numtoread-1 do
+ begin
+ { Read a byte into b[i]. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_interesting_appn := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ b[i] := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ end;
+
+ Dec(length, numtoread);
+
+ { process it }
+ case (cinfo^.unread_marker) of
+ M_APP0:
+ examine_app0(cinfo, b, numtoread, length);
+ M_APP14:
+ examine_app14(cinfo, b, numtoread, length);
+ else
+ { can't get here unless jpeg_save_markers chooses wrong processor }
+ ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, cinfo^.unread_marker);
+ end;
+
+ { skip any remaining data -- could be lots }
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ if (length > 0) then
+ cinfo^.src^.skip_input_data(cinfo, long(length));
+
+ get_interesting_appn := TRUE;
+end;
+
+{$ifdef SAVE_MARKERS_SUPPORTED}
+
+{METHODDEF}
+function save_marker (cinfo : j_decompress_ptr) : boolean;
+{ Save an APPn or COM marker into the marker list }
+var
+ marker : my_marker_ptr;
+ cur_marker : jpeg_saved_marker_ptr;
+ bytes_read, data_length : uint;
+ data : JOCTET_FIELD_PTR;
+ length : INT32;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+var
+ limit : uint;
+var
+ prev : jpeg_saved_marker_ptr;
+begin
+ { local copies of input pointer/count }
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+ marker := my_marker_ptr(cinfo^.marker);
+ cur_marker := marker^.cur_marker;
+ length := 0;
+
+ if (cur_marker = NIL) then
+ begin
+ { begin reading a marker }
+ { Read two bytes interpreted as an unsigned 16-bit integer. }
+
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ save_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ length := (uint( GETJOCTET(next_input_byte^)) shl 8);
+ Inc( next_input_byte );
+
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ save_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ Inc( length, GETJOCTET(next_input_byte^));
+ Inc( next_input_byte );
+
+ Dec(length, 2);
+ if (length >= 0) then
+ begin { watch out for bogus length word }
+ { figure out how much we want to save }
+
+ if (cinfo^.unread_marker = int(M_COM)) then
+ limit := marker^.length_limit_COM
+ else
+ limit := marker^.length_limit_APPn[cinfo^.unread_marker - int(M_APP0)];
+ if (uint(length) < limit) then
+ limit := uint(length);
+ { allocate and initialize the marker item }
+ cur_marker := jpeg_saved_marker_ptr(
+ cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(jpeg_marker_struct) + limit) );
+ cur_marker^.next := NIL;
+ cur_marker^.marker := UINT8 (cinfo^.unread_marker);
+ cur_marker^.original_length := uint(length);
+ cur_marker^.data_length := limit;
+ { data area is just beyond the jpeg_marker_struct }
+ cur_marker^.data := JOCTET_FIELD_PTR(cur_marker);
+ Inc(jpeg_saved_marker_ptr(cur_marker^.data));
+ data := cur_marker^.data;
+
+ marker^.cur_marker := cur_marker;
+ marker^.bytes_read := 0;
+ bytes_read := 0;
+ data_length := limit;
+ end
+ else
+ begin
+ { deal with bogus length word }
+ data_length := 0;
+ bytes_read := 0;
+ data := NIL;
+ end
+ end
+ else
+ begin
+ { resume reading a marker }
+ bytes_read := marker^.bytes_read;
+ data_length := cur_marker^.data_length;
+ data := cur_marker^.data;
+ Inc(data, bytes_read);
+ end;
+
+ while (bytes_read < data_length) do
+ begin
+ { move the restart point to here }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ marker^.bytes_read := bytes_read;
+ { If there's not at least one byte in buffer, suspend }
+ if (bytes_in_buffer = 0) then
+ begin
+ if not datasrc^.fill_input_buffer (cinfo) then
+ begin
+ save_marker := FALSE;
+ exit;
+ end;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+
+ { Copy bytes with reasonable rapidity }
+ while (bytes_read < data_length) and (bytes_in_buffer > 0) do
+ begin
+ JOCTETPTR(data)^ := next_input_byte^;
+ Inc(JOCTETPTR(data));
+ Inc(next_input_byte);
+ Dec(bytes_in_buffer);
+ Inc(bytes_read);
+ end;
+ end;
+
+ { Done reading what we want to read }
+ if (cur_marker <> NIL) then
+ begin { will be NIL if bogus length word }
+ { Add new marker to end of list }
+ if (cinfo^.marker_list = NIL) then
+ begin
+ cinfo^.marker_list := cur_marker
+ end
+ else
+ begin
+ prev := cinfo^.marker_list;
+ while (prev^.next <> NIL) do
+ prev := prev^.next;
+ prev^.next := cur_marker;
+ end;
+ { Reset pointer & calc remaining data length }
+ data := cur_marker^.data;
+ length := cur_marker^.original_length - data_length;
+ end;
+ { Reset to initial state for next marker }
+ marker^.cur_marker := NIL;
+
+ { Process the marker if interesting; else just make a generic trace msg }
+ case (cinfo^.unread_marker) of
+ M_APP0:
+ examine_app0(cinfo, data^, data_length, length);
+ M_APP14:
+ examine_app14(cinfo, data^, data_length, length);
+ else
+ {$IFDEF DEBUG}
+ TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER, cinfo^.unread_marker,
+ int(data_length + length));
+ {$ENDIF}
+ end;
+
+ { skip any remaining data -- could be lots }
+ { do before skip_input_data }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ if (length > 0) then
+ cinfo^.src^.skip_input_data (cinfo, long(length) );
+
+ save_marker := TRUE;
+end;
+
+{$endif} { SAVE_MARKERS_SUPPORTED }
+
+
+{ Find the next JPEG marker, save it in cinfo^.unread_marker.
+ Returns FALSE if had to suspend before reaching a marker;
+ in that case cinfo^.unread_marker is unchanged.
+
+ Note that the result might not be a valid marker code,
+ but it will never be 0 or FF. }
+
+{LOCAL}
+function next_marker (cinfo : j_decompress_ptr) : boolean;
+var
+ c : int;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+ {while TRUE do}
+ repeat
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ next_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ { Skip any non-FF bytes.
+ This may look a bit inefficient, but it will not occur in a valid file.
+ We sync after each discarded byte so that a suspending data source
+ can discard the byte from its buffer. }
+
+ while (c <> $FF) do
+ begin
+ Inc(cinfo^.marker^.discarded_bytes);
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ next_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ end;
+ { This loop swallows any duplicate FF bytes. Extra FFs are legal as
+ pad bytes, so don't count them in discarded_bytes. We assume there
+ will not be so many consecutive FF bytes as to overflow a suspending
+ data source's input buffer. }
+
+ repeat
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ next_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ Until (c <> $FF);
+ if (c <> 0) then
+ break; { found a valid marker, exit loop }
+ { Reach here if we found a stuffed-zero data sequence (FF/00).
+ Discard it and loop back to try again. }
+
+ Inc(cinfo^.marker^.discarded_bytes, 2);
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+ Until False;
+
+ if (cinfo^.marker^.discarded_bytes <> 0) then
+ begin
+ WARNMS2(j_common_ptr(cinfo), JWRN_EXTRANEOUS_DATA,
+ cinfo^.marker^.discarded_bytes, c);
+ cinfo^.marker^.discarded_bytes := 0;
+ end;
+
+ cinfo^.unread_marker := c;
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ next_marker := TRUE;
+end; { next_marker }
+
+
+{LOCAL}
+function first_marker (cinfo : j_decompress_ptr) : boolean;
+{ Like next_marker, but used to obtain the initial SOI marker. }
+{ For this marker, we do not allow preceding garbage or fill; otherwise,
+ we might well scan an entire input file before realizing it ain't JPEG.
+ If an application wants to process non-JFIF files, it must seek to the
+ SOI before calling the JPEG library. }
+var
+ c, c2 : int;
+var
+ datasrc : jpeg_source_mgr_ptr;
+ next_input_byte : JOCTETptr;
+ bytes_in_buffer : size_t;
+begin
+ datasrc := cinfo^.src;
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+
+ { Read a byte into variable c. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ first_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ { Read a byte into variable c2. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
+ begin
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ first_marker := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
+ end;
+ Dec( bytes_in_buffer );
+
+ c2 := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+
+ if (c <> $FF) or (c2 <> int(M_SOI)) then
+ ERREXIT2(j_common_ptr(cinfo), JERR_NO_SOI, c, c2);
+
+ cinfo^.unread_marker := c2;
+
+ { Unload the local copies --- do this only at a restart boundary }
+ datasrc^.next_input_byte := next_input_byte;
+ datasrc^.bytes_in_buffer := bytes_in_buffer;
+
+ first_marker := TRUE;
+end; { first_marker }
+
+
+{ Read markers until SOS or EOI.
+
+ Returns same codes as are defined for jpeg_consume_input:
+ JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. }
+
+{METHODDEF}
+function read_markers (cinfo : j_decompress_ptr) : int;
+begin
+ { Outer loop repeats once for each marker. }
+ repeat
+ { Collect the marker proper, unless we already did. }
+ { NB: first_marker() enforces the requirement that SOI appear first. }
+ if (cinfo^.unread_marker = 0) then
+ begin
+ if not cinfo^.marker^.saw_SOI then
+ begin
+ if not first_marker(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+ end
+ else
+ begin
+ if not next_marker(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+ end;
+ end;
+ { At this point cinfo^.unread_marker contains the marker code and the
+ input point is just past the marker proper, but before any parameters.
+ A suspension will cause us to return with this state still true. }
+
+ case (cinfo^.unread_marker) of
+ M_SOI:
+ if not get_soi(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_SOF0, { Baseline }
+ M_SOF1: { Extended sequential, Huffman }
+ if not get_sof(cinfo, FALSE, FALSE) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+ M_SOF2: { Progressive, Huffman }
+ if not get_sof(cinfo, TRUE, FALSE) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_SOF9: { Extended sequential, arithmetic }
+ if not get_sof(cinfo, FALSE, TRUE) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_SOF10: { Progressive, arithmetic }
+ if not get_sof(cinfo, TRUE, TRUE) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ { Currently unsupported SOFn types }
+ M_SOF3, { Lossless, Huffman }
+ M_SOF5, { Differential sequential, Huffman }
+ M_SOF6, { Differential progressive, Huffman }
+ M_SOF7, { Differential lossless, Huffman }
+ M_JPG, { Reserved for JPEG extensions }
+ M_SOF11, { Lossless, arithmetic }
+ M_SOF13, { Differential sequential, arithmetic }
+ M_SOF14, { Differential progressive, arithmetic }
+ M_SOF15: { Differential lossless, arithmetic }
+ ERREXIT1(j_common_ptr(cinfo), JERR_SOF_UNSUPPORTED, cinfo^.unread_marker);
+
+ M_SOS:
+ begin
+ if not get_sos(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+ cinfo^.unread_marker := 0; { processed the marker }
+ read_markers := JPEG_REACHED_SOS;
+ exit;
+ end;
+
+ M_EOI:
+ begin
+ {$IFDEF DEBUG}
+ TRACEMS(j_common_ptr(cinfo), 1, JTRC_EOI);
+ {$ENDIF}
+ cinfo^.unread_marker := 0; { processed the marker }
+ read_markers := JPEG_REACHED_EOI;
+ exit;
+ end;
+
+ M_DAC:
+ if not get_dac(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_DHT:
+ if not get_dht(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_DQT:
+ if not get_dqt(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_DRI:
+ if not get_dri(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_APP0,
+ M_APP1,
+ M_APP2,
+ M_APP3,
+ M_APP4,
+ M_APP5,
+ M_APP6,
+ M_APP7,
+ M_APP8,
+ M_APP9,
+ M_APP10,
+ M_APP11,
+ M_APP12,
+ M_APP13,
+ M_APP14,
+ M_APP15:
+ if not my_marker_ptr(cinfo^.marker)^.
+ process_APPn[cinfo^.unread_marker - int(M_APP0)](cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_COM:
+ if not my_marker_ptr(cinfo^.marker)^.process_COM (cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ M_RST0, { these are all parameterless }
+ M_RST1,
+ M_RST2,
+ M_RST3,
+ M_RST4,
+ M_RST5,
+ M_RST6,
+ M_RST7,
+ M_TEM:
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_PARMLESS_MARKER,
+ cinfo^.unread_marker)
+ {$ENDIF}
+ ;
+
+ M_DNL: { Ignore DNL ... perhaps the wrong thing }
+ if not skip_variable(cinfo) then
+ begin
+ read_markers := JPEG_SUSPENDED;
+ exit;
+ end;
+
+ else { must be DHP, EXP, JPGn, or RESn }
+ { For now, we treat the reserved markers as fatal errors since they are
+ likely to be used to signal incompatible JPEG Part 3 extensions.
+ Once the JPEG 3 version-number marker is well defined, this code
+ ought to change! }
+ ERREXIT1(j_common_ptr(cinfo) , JERR_UNKNOWN_MARKER,
+ cinfo^.unread_marker);
+ end; { end of case }
+ { Successfully processed marker, so reset state variable }
+ cinfo^.unread_marker := 0;
+ Until false;
+end; { read_markers }
+
+
+{ Read a restart marker, which is expected to appear next in the datastream;
+ if the marker is not there, take appropriate recovery action.
+ Returns FALSE if suspension is required.
+
+ This is called by the entropy decoder after it has read an appropriate
+ number of MCUs. cinfo^.unread_marker may be nonzero if the entropy decoder
+ has already read a marker from the data source. Under normal conditions
+ cinfo^.unread_marker will be reset to 0 before returning; if not reset,
+ it holds a marker which the decoder will be unable to read past. }
+
+{METHODDEF}
+function read_restart_marker (cinfo : j_decompress_ptr) :boolean;
+begin
+ { Obtain a marker unless we already did. }
+ { Note that next_marker will complain if it skips any data. }
+ if (cinfo^.unread_marker = 0) then
+ begin
+ if not next_marker(cinfo) then
+ begin
+ read_restart_marker := FALSE;
+ exit;
+ end;
+ end;
+
+ if (cinfo^.unread_marker = (int(M_RST0) + cinfo^.marker^.next_restart_num)) then
+ begin
+ { Normal case --- swallow the marker and let entropy decoder continue }
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 3, JTRC_RST,
+ cinfo^.marker^.next_restart_num);
+ {$ENDIF}
+ cinfo^.unread_marker := 0;
+ end
+ else
+ begin
+ { Uh-oh, the restart markers have been messed up. }
+ { Let the data source manager determine how to resync. }
+ if not cinfo^.src^.resync_to_restart(cinfo,
+ cinfo^.marker^.next_restart_num) then
+ begin
+ read_restart_marker := FALSE;
+ exit;
+ end;
+ end;
+
+ { Update next-restart state }
+ with cinfo^.marker^ do
+ next_restart_num := (next_restart_num + 1) and 7;
+
+ read_restart_marker := TRUE;
+end; { read_restart_marker }
+
+
+{ This is the default resync_to_restart method for data source managers
+ to use if they don't have any better approach. Some data source managers
+ may be able to back up, or may have additional knowledge about the data
+ which permits a more intelligent recovery strategy; such managers would
+ presumably supply their own resync method.
+
+ read_restart_marker calls resync_to_restart if it finds a marker other than
+ the restart marker it was expecting. (This code is *not* used unless
+ a nonzero restart interval has been declared.) cinfo^.unread_marker is
+ the marker code actually found (might be anything, except 0 or FF).
+ The desired restart marker number (0..7) is passed as a parameter.
+ This routine is supposed to apply whatever error recovery strategy seems
+ appropriate in order to position the input stream to the next data segment.
+ Note that cinfo^.unread_marker is treated as a marker appearing before
+ the current data-source input point; usually it should be reset to zero
+ before returning.
+ Returns FALSE if suspension is required.
+
+ This implementation is substantially constrained by wanting to treat the
+ input as a data stream; this means we can't back up. Therefore, we have
+ only the following actions to work with:
+ 1. Simply discard the marker and let the entropy decoder resume at next
+ byte of file.
+ 2. Read forward until we find another marker, discarding intervening
+ data. (In theory we could look ahead within the current bufferload,
+ without having to discard data if we don't find the desired marker.
+ This idea is not implemented here, in part because it makes behavior
+ dependent on buffer size and chance buffer-boundary positions.)
+ 3. Leave the marker unread (by failing to zero cinfo^.unread_marker).
+ This will cause the entropy decoder to process an empty data segment,
+ inserting dummy zeroes, and then we will reprocess the marker.
+
+ #2 is appropriate if we think the desired marker lies ahead, while #3 is
+ appropriate if the found marker is a future restart marker (indicating
+ that we have missed the desired restart marker, probably because it got
+ corrupted).
+ We apply #2 or #3 if the found marker is a restart marker no more than
+ two counts behind or ahead of the expected one. We also apply #2 if the
+ found marker is not a legal JPEG marker code (it's certainly bogus data).
+ If the found marker is a restart marker more than 2 counts away, we do #1
+ (too much risk that the marker is erroneous; with luck we will be able to
+ resync at some future point).
+ For any valid non-restart JPEG marker, we apply #3. This keeps us from
+ overrunning the end of a scan. An implementation limited to single-scan
+ files might find it better to apply #2 for markers other than EOI, since
+ any other marker would have to be bogus data in that case. }
+
+
+{GLOBAL}
+function jpeg_resync_to_restart(cinfo : j_decompress_ptr;
+ desired : int) : boolean;
+var
+ marker : int;
+ action : int;
+begin
+ marker := cinfo^.unread_marker;
+ //action := 1; { never used }
+ { Always put up a warning. }
+ WARNMS2(j_common_ptr(cinfo), JWRN_MUST_RESYNC, marker, desired);
+
+ { Outer loop handles repeated decision after scanning forward. }
+ repeat
+ if (marker < int(M_SOF0)) then
+ action := 2 { invalid marker }
+ else
+ if (marker < int(M_RST0)) or (marker > int(M_RST7)) then
+ action := 3 { valid non-restart marker }
+ else
+ begin
+ if (marker = (int(M_RST0) + ((desired+1) and 7))) or
+ (marker = (int(M_RST0) + ((desired+2) and 7))) then
+ action := 3 { one of the next two expected restarts }
+ else
+ if (marker = (int(M_RST0) + ((desired-1) and 7))) or
+ (marker = (int(M_RST0) + ((desired-2) and 7))) then
+ action := 2 { a prior restart, so advance }
+ else
+ action := 1; { desired restart or too far away }
+ end;
+
+ {$IFDEF DEBUG}
+ TRACEMS2(j_common_ptr(cinfo), 4, JTRC_RECOVERY_ACTION, marker, action);
+ {$ENDIF}
+ case action of
+ 1:
+ { Discard marker and let entropy decoder resume processing. }
+ begin
+ cinfo^.unread_marker := 0;
+ jpeg_resync_to_restart := TRUE;
+ exit;
+ end;
+ 2:
+ { Scan to the next marker, and repeat the decision loop. }
+ begin
+ if not next_marker(cinfo) then
+ begin
+ jpeg_resync_to_restart := FALSE;
+ exit;
+ end;
+ marker := cinfo^.unread_marker;
+ end;
+ 3:
+ { Return without advancing past this marker. }
+ { Entropy decoder will be forced to process an empty segment. }
+ begin
+ jpeg_resync_to_restart := TRUE;
+ exit;
+ end;
+ end; { case }
+ Until false; { end loop }
+end; { jpeg_resync_to_restart }
+
+
+{ Reset marker processing state to begin a fresh datastream. }
+
+{METHODDEF}
+procedure reset_marker_reader (cinfo : j_decompress_ptr);
+var
+ marker : my_marker_ptr;
+begin
+ marker := my_marker_ptr (cinfo^.marker);
+ with cinfo^ do
+ begin
+ comp_info := NIL; { until allocated by get_sof }
+ input_scan_number := 0; { no SOS seen yet }
+ unread_marker := 0; { no pending marker }
+ end;
+ marker^.pub.saw_SOI := FALSE; { set internal state too }
+ marker^.pub.saw_SOF := FALSE;
+ marker^.pub.discarded_bytes := 0;
+ marker^.cur_marker := NIL;
+end; { reset_marker_reader }
+
+
+{ Initialize the marker reader module.
+ This is called only once, when the decompression object is created. }
+
+{GLOBAL}
+procedure jinit_marker_reader (cinfo : j_decompress_ptr);
+var
+ marker : my_marker_ptr;
+ i : int;
+begin
+ { Create subobject in permanent pool }
+ marker := my_marker_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
+ SIZEOF(my_marker_reader))
+ );
+ cinfo^.marker := jpeg_marker_reader_ptr(marker);
+ { Initialize method pointers }
+ marker^.pub.reset_marker_reader := reset_marker_reader;
+ marker^.pub.read_markers := read_markers;
+ marker^.pub.read_restart_marker := read_restart_marker;
+ { Initialize COM/APPn processing.
+ By default, we examine and then discard APP0 and APP14,
+ but simply discard COM and all other APPn. }
+
+ marker^.process_COM := skip_variable;
+ marker^.length_limit_COM := 0;
+ for i := 0 to 16-1 do
+ begin
+ marker^.process_APPn[i] := skip_variable;
+ marker^.length_limit_APPn[i] := 0;
+ end;
+ marker^.process_APPn[0] := get_interesting_appn;
+ marker^.process_APPn[14] := get_interesting_appn;
+ { Reset marker processing state }
+ reset_marker_reader(cinfo);
+end; { jinit_marker_reader }
+
+
+{ Control saving of COM and APPn markers into marker_list. }
+
+
+{$ifdef SAVE_MARKERS_SUPPORTED}
+
+{GLOBAL}
+procedure jpeg_save_markers (cinfo : j_decompress_ptr;
+ marker_code : int;
+ length_limit : uint);
+var
+ marker : my_marker_ptr;
+ maxlength : long;
+ processor : jpeg_marker_parser_method;
+begin
+ marker := my_marker_ptr (cinfo^.marker);
+
+ { Length limit mustn't be larger than what we can allocate
+ (should only be a concern in a 16-bit environment). }
+
+ maxlength := cinfo^.mem^.max_alloc_chunk - SIZEOF(jpeg_marker_struct);
+ if (long(length_limit) > maxlength) then
+ length_limit := uint(maxlength);
+
+ { Choose processor routine to use.
+ APP0/APP14 have special requirements. }
+
+ if (length_limit <> 0) then
+ begin
+ processor := save_marker;
+ { If saving APP0/APP14, save at least enough for our internal use. }
+ if (marker_code = int(M_APP0)) and (length_limit < APP0_DATA_LEN) then
+ length_limit := APP0_DATA_LEN
+ else
+ if (marker_code = int(M_APP14)) and (length_limit < APP14_DATA_LEN) then
+ length_limit := APP14_DATA_LEN;
+ end
+ else
+ begin
+ processor := skip_variable;
+ { If discarding APP0/APP14, use our regular on-the-fly processor. }
+ if (marker_code = int(M_APP0)) or (marker_code = int(M_APP14)) then
+ processor := get_interesting_appn;
+ end;
+
+ if (marker_code = int(M_COM)) then
+ begin
+ marker^.process_COM := processor;
+ marker^.length_limit_COM := length_limit;
+ end
+ else
+ if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then
+ begin
+ marker^.process_APPn[marker_code - int(M_APP0)] := processor;
+ marker^.length_limit_APPn[marker_code - int(M_APP0)] := length_limit;
+ end
+ else
+ ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code);
+end;
+
+{$endif} { SAVE_MARKERS_SUPPORTED }
+
+{ Install a special processing method for COM or APPn markers. }
+
+{GLOBAL}
+
+procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr;
+ marker_code : int;
+ routine : jpeg_marker_parser_method);
+var
+ marker : my_marker_ptr;
+begin
+ marker := my_marker_ptr (cinfo^.marker);
+ if (marker_code = int(M_COM)) then
+ marker^.process_COM := routine
+ else
+ if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then
+ marker^.process_APPn[marker_code - int(M_APP0)] := routine
+ else
+ ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code);
+end;
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjdmaster.pas b/src/lib/vampimg/JpegLib/imjdmaster.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdmerge.pas b/src/lib/vampimg/JpegLib/imjdmerge.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdphuff.pas b/src/lib/vampimg/JpegLib/imjdphuff.pas
--- /dev/null
@@ -0,0 +1,1061 @@
+unit imjdphuff;
+
+{ This file contains Huffman entropy decoding routines for progressive JPEG.
+
+ Much of the complexity here has to do with supporting input suspension.
+ If the data source module demands suspension, we want to be able to back
+ up to the start of the current MCU. To do this, we copy state variables
+ into local working storage, and update them back to the permanent
+ storage only upon successful completion of an MCU. }
+
+{ Original: jdphuff.c ; Copyright (C) 1995-1997, Thomas G. Lane. }
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg,
+ imjinclude,
+ imjpeglib,
+ imjdeferr,
+ imjerror,
+ imjutils,
+ imjdhuff; { Declarations shared with jdhuff.c }
+
+
+{GLOBAL}
+procedure jinit_phuff_decoder (cinfo : j_decompress_ptr);
+
+implementation
+
+{ Expanded entropy decoder object for progressive Huffman decoding.
+
+ The savable_state subrecord contains fields that change within an MCU,
+ but must not be updated permanently until we complete the MCU. }
+
+type
+ savable_state = record
+ EOBRUN : uInt; { remaining EOBs in EOBRUN }
+ last_dc_val : array[00..MAX_COMPS_IN_SCAN-1] of int;
+ { last DC coef for each component }
+ end;
+
+
+type
+ phuff_entropy_ptr = ^phuff_entropy_decoder;
+ phuff_entropy_decoder = record
+ pub : jpeg_entropy_decoder; { public fields }
+
+ { These fields are loaded into local variables at start of each MCU.
+ In case of suspension, we exit WITHOUT updating them. }
+
+ bitstate : bitread_perm_state; { Bit buffer at start of MCU }
+ saved : savable_state; { Other state at start of MCU }
+
+ { These fields are NOT loaded into local working state. }
+ restarts_to_go : uInt; { MCUs left in this restart interval }
+
+ { Pointers to derived tables (these workspaces have image lifespan) }
+ derived_tbls : array[0..NUM_HUFF_TBLS-1] of d_derived_tbl_ptr;
+
+ ac_derived_tbl : d_derived_tbl_ptr; { active table during an AC scan }
+ end;
+
+
+
+{ Forward declarations }
+{METHODDEF}
+function decode_mcu_DC_first (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+ forward;
+{METHODDEF}
+function decode_mcu_AC_first (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+ forward;
+{METHODDEF}
+function decode_mcu_DC_refine (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+ forward;
+{METHODDEF}
+function decode_mcu_AC_refine (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+ forward;
+
+{ Initialize for a Huffman-compressed scan. }
+
+{METHODDEF}
+procedure start_pass_phuff_decoder (cinfo : j_decompress_ptr);
+var
+ entropy : phuff_entropy_ptr;
+ is_DC_band, bad : boolean;
+ ci, coefi, tbl : int;
+ coef_bit_ptr : coef_bits_ptr;
+ compptr : jpeg_component_info_ptr;
+var
+ cindex : int;
+ expected : int;
+begin
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+
+ is_DC_band := (cinfo^.Ss = 0);
+
+ { Validate scan parameters }
+ bad := FALSE;
+ if (is_DC_band) then
+ begin
+ if (cinfo^.Se <> 0) then
+ bad := TRUE;
+ end
+ else
+ begin
+ { need not check Ss/Se < 0 since they came from unsigned bytes }
+ if (cinfo^.Ss > cinfo^.Se) or (cinfo^.Se >= DCTSIZE2) then
+ bad := TRUE;
+ { AC scans may have only one component }
+ if (cinfo^.comps_in_scan <> 1) then
+ bad := TRUE;
+ end;
+ if (cinfo^.Ah <> 0) then
+ begin
+ { Successive approximation refinement scan: must have Al = Ah-1. }
+ if (cinfo^.Al <> cinfo^.Ah-1) then
+ bad := TRUE;
+ end;
+ if (cinfo^.Al > 13) then { need not check for < 0 }
+ bad := TRUE;
+ { Arguably the maximum Al value should be less than 13 for 8-bit precision,
+ but the spec doesn't say so, and we try to be liberal about what we
+ accept. Note: large Al values could result in out-of-range DC
+ coefficients during early scans, leading to bizarre displays due to
+ overflows in the IDCT math. But we won't crash. }
+
+ if (bad) then
+ ERREXIT4(j_common_ptr(cinfo), JERR_BAD_PROGRESSION,
+ cinfo^.Ss, cinfo^.Se, cinfo^.Ah, cinfo^.Al);
+ { Update progression status, and verify that scan order is legal.
+ Note that inter-scan inconsistencies are treated as warnings
+ not fatal errors ... not clear if this is right way to behave. }
+
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ begin
+ cindex := cinfo^.cur_comp_info[ci]^.component_index;
+ coef_bit_ptr := coef_bits_ptr(@(cinfo^.coef_bits^[cindex])); {^[0] ???
+ Nomssi }
+ if (not is_DC_band) and (coef_bit_ptr^[0] < 0) then
+ { AC without prior DC scan }
+ WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, 0);
+ for coefi := cinfo^.Ss to cinfo^.Se do
+ begin
+ if (coef_bit_ptr^[coefi] < 0) then
+ expected := 0
+ else
+ expected := coef_bit_ptr^[coefi];
+ if (cinfo^.Ah <> expected) then
+ WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, coefi);
+ coef_bit_ptr^[coefi] := cinfo^.Al;
+ end;
+ end;
+
+ { Select MCU decoding routine }
+ if (cinfo^.Ah = 0) then
+ begin
+ if (is_DC_band) then
+ entropy^.pub.decode_mcu := decode_mcu_DC_first
+ else
+ entropy^.pub.decode_mcu := decode_mcu_AC_first;
+ end
+ else
+ begin
+ if (is_DC_band) then
+ entropy^.pub.decode_mcu := decode_mcu_DC_refine
+ else
+ entropy^.pub.decode_mcu := decode_mcu_AC_refine;
+ end;
+
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ begin
+ compptr := cinfo^.cur_comp_info[ci];
+ { Make sure requested tables are present, and compute derived tables.
+ We may build same derived table more than once, but it's not expensive. }
+
+ if (is_DC_band) then
+ begin
+ if (cinfo^.Ah = 0) then
+ begin { DC refinement needs no table }
+ tbl := compptr^.dc_tbl_no;
+ jpeg_make_d_derived_tbl(cinfo, TRUE, tbl,
+ entropy^.derived_tbls[tbl]);
+ end;
+ end
+ else
+ begin
+ tbl := compptr^.ac_tbl_no;
+ jpeg_make_d_derived_tbl(cinfo, FALSE, tbl,
+ entropy^.derived_tbls[tbl]);
+ { remember the single active table }
+ entropy^.ac_derived_tbl := entropy^.derived_tbls[tbl];
+ end;
+ { Initialize DC predictions to 0 }
+ entropy^.saved.last_dc_val[ci] := 0;
+ end;
+
+ { Initialize bitread state variables }
+ entropy^.bitstate.bits_left := 0;
+ entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet }
+ entropy^.pub.insufficient_data := FALSE;
+
+ { Initialize private state variables }
+ entropy^.saved.EOBRUN := 0;
+
+ { Initialize restart counter }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+end;
+
+
+{ Figure F.12: extend sign bit.
+ On some machines, a shift and add will be faster than a table lookup. }
+
+{$ifdef AVOID_TABLES}
+
+#define HUFF_EXTEND(x,s)
+ ((x) < (1shl((s)-1)) ? (x) + (((-1)shl(s)) + 1) : (x))
+
+{$else}
+
+{ #define HUFF_EXTEND(x,s)
+ if (x) < extend_test[s] then
+ (x) + extend_offset[s]
+ else
+ (x)}
+
+const
+ extend_test : Array[0..16-1] of int = { entry n is 2**(n-1) }
+ ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040,
+ $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000);
+
+const
+ extend_offset : array[0..16-1] of int = { entry n is (-1 shl n) + 1 }
+ ( 0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1,
+ ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1,
+ ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1, ((-1) shl 12) + 1,
+ ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1 );
+
+{$endif} { AVOID_TABLES }
+
+
+{ Check for a restart marker & resynchronize decoder.
+ return:=s FALSE if must suspend. }
+
+{LOCAL}
+function process_restart (cinfo : j_decompress_ptr) : boolean;
+var
+ entropy : phuff_entropy_ptr;
+ ci : int;
+begin
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+
+ { Throw away any unused bits remaining in bit buffer; }
+ { include any full bytes in next_marker's count of discarded bytes }
+ Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8);
+ entropy^.bitstate.bits_left := 0;
+
+ { Advance past the RSTn marker }
+ if (not cinfo^.marker^.read_restart_marker (cinfo)) then
+ begin
+ process_restart := FALSE;
+ exit;
+ end;
+
+ { Re-initialize DC predictions to 0 }
+ for ci := 0 to pred(cinfo^.comps_in_scan) do
+ entropy^.saved.last_dc_val[ci] := 0;
+ { Re-init EOB run count, too }
+ entropy^.saved.EOBRUN := 0;
+
+ { Reset restart counter }
+ entropy^.restarts_to_go := cinfo^.restart_interval;
+
+ { Reset out-of-data flag, unless read_restart_marker left us smack up
+ against a marker. In that case we will end up treating the next data
+ segment as empty, and we can avoid producing bogus output pixels by
+ leaving the flag set. }
+ if (cinfo^.unread_marker = 0) then
+ entropy^.pub.insufficient_data := FALSE;
+
+ process_restart := TRUE;
+end;
+
+
+{ Huffman MCU decoding.
+ Each of these routines decodes and returns one MCU's worth of
+ Huffman-compressed coefficients.
+ The coefficients are reordered from zigzag order into natural array order,
+ but are not dequantized.
+
+ The i'th block of the MCU is stored into the block pointed to by
+ MCU_data[i]. WE ASSUME THIS AREA IS INITIALLY ZEROED BY THE CALLER.
+
+ We return FALSE if data source requested suspension. In that case no
+ changes have been made to permanent state. (Exception: some output
+ coefficients may already have been assigned. This is harmless for
+ spectral selection, since we'll just re-assign them on the next call.
+ Successive approximation AC refinement has to be more careful, however.) }
+
+
+{ MCU decoding for DC initial scan (either spectral selection,
+ or first pass of successive approximation). }
+
+{METHODDEF}
+function decode_mcu_DC_first (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+label
+ label1;
+var
+ entropy : phuff_entropy_ptr;
+ Al : int;
+ {register} s, r : int;
+ blkn, ci : int;
+ block : JBLOCK_PTR;
+ {BITREAD_STATE_VARS;}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+
+ state : savable_state;
+ tbl : d_derived_tbl_ptr;
+ compptr : jpeg_component_info_ptr;
+var
+ nb, look : int; {register}
+begin
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+ Al := cinfo^.Al;
+
+ { Process restart marker if needed; may have to suspend }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if (not process_restart(cinfo)) then
+ begin
+ decode_mcu_DC_first := FALSE;
+ exit;
+ end;
+ end;
+
+ { If we've run out of data, just leave the MCU set to zeroes.
+ This way, we return uniform gray for the remainder of the segment. }
+
+ if not entropy^.pub.insufficient_data then
+ begin
+
+ { Load up working state }
+ {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);}
+ br_state.cinfo := cinfo;
+ br_state.next_input_byte := cinfo^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ get_buffer := entropy^.bitstate.get_buffer;
+ bits_left := entropy^.bitstate.bits_left;
+
+ {ASSIGN_STATE(state, entropy^.saved);}
+ state := entropy^.saved;
+
+ { Outer loop handles each block in the MCU }
+
+ 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];
+ tbl := entropy^.derived_tbls[compptr^.dc_tbl_no];
+
+ { Decode a single block's worth of coefficients }
+
+ { Section F.2.2.1: decode the DC coefficient difference }
+ {HUFF_DECODE(s, br_state, tbl, return FALSE, label1);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu_DC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label1;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := tbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := tbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label1:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb);
+ if (s < 0) then
+ begin
+ decode_mcu_DC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ if (s <> 0) then
+ begin
+ {CHECK_BIT_BUFFER(br_state, s, return FALSE);}
+ if (bits_left < s) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then
+ begin
+ decode_mcu_DC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(s);}
+ Dec(bits_left, s);
+ r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) );
+
+ {s := HUFF_EXTEND(r, s);}
+ if (r < extend_test[s]) then
+ s := r + extend_offset[s]
+ else
+ s := r;
+ end;
+
+ { Convert DC difference to actual value, update last_dc_val }
+ Inc(s, state.last_dc_val[ci]);
+ state.last_dc_val[ci] := s;
+ { Scale and output the DC coefficient (assumes jpeg_natural_order[0]=0) }
+ block^[0] := JCOEF (s shl Al);
+ end;
+
+ { Completed MCU, so update state }
+ {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);}
+ cinfo^.src^.next_input_byte := br_state.next_input_byte;
+ cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ entropy^.bitstate.get_buffer := get_buffer;
+ entropy^.bitstate.bits_left := bits_left;
+
+ {ASSIGN_STATE(entropy^.saved, state);}
+ entropy^.saved := state;
+ end;
+
+ { Account for restart interval (no-op if not using restarts) }
+ Dec(entropy^.restarts_to_go);
+
+ decode_mcu_DC_first := TRUE;
+end;
+
+
+{ MCU decoding for AC initial scan (either spectral selection,
+ or first pass of successive approximation). }
+
+{METHODDEF}
+function decode_mcu_AC_first (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+label
+ label2;
+var
+ entropy : phuff_entropy_ptr;
+ Se : int;
+ Al : int;
+ {register} s, k, r : int;
+ EOBRUN : uInt;
+ block : JBLOCK_PTR;
+ {BITREAD_STATE_VARS;}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+
+ tbl : d_derived_tbl_ptr;
+var
+ nb, look : int; {register}
+begin
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+ Se := cinfo^.Se;
+ Al := cinfo^.Al;
+
+ { Process restart marker if needed; may have to suspend }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if (not process_restart(cinfo)) then
+ begin
+ decode_mcu_AC_first := FALSE;
+ exit;
+ end;
+ end;
+
+ { If we've run out of data, just leave the MCU set to zeroes.
+ This way, we return uniform gray for the remainder of the segment. }
+ if not entropy^.pub.insufficient_data then
+ begin
+
+ { Load up working state.
+ We can avoid loading/saving bitread state if in an EOB run. }
+
+ EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about }
+
+ { There is always only one block per MCU }
+
+ if (EOBRUN > 0) then { if it's a band of zeroes... }
+ Dec(EOBRUN) { ...process it now (we do nothing) }
+ else
+ begin
+ {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);}
+ br_state.cinfo := cinfo;
+ br_state.next_input_byte := cinfo^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ get_buffer := entropy^.bitstate.get_buffer;
+ bits_left := entropy^.bitstate.bits_left;
+
+ block := JBLOCK_PTR(MCU_data[0]);
+ tbl := entropy^.ac_derived_tbl;
+
+ k := cinfo^.Ss;
+ while (k <= Se) do
+ begin
+ {HUFF_DECODE(s, br_state, tbl, return FALSE, label2);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ begin
+ decode_mcu_AC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label2;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := tbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := tbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label2:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb);
+ if (s < 0) then
+ begin
+ decode_mcu_AC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ r := s shr 4;
+ s := s and 15;
+ if (s <> 0) then
+ begin
+ Inc(k, r);
+ {CHECK_BIT_BUFFER(br_state, s, return FALSE);}
+ if (bits_left < s) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then
+ begin
+ decode_mcu_AC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(s);}
+ Dec(bits_left, s);
+ r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) );
+
+ {s := HUFF_EXTEND(r, s);}
+ if (r < extend_test[s]) then
+ s := r + extend_offset[s]
+ else
+ s := r;
+
+ { Scale and output coefficient in natural (dezigzagged) order }
+ block^[jpeg_natural_order[k]] := JCOEF (s shl Al);
+ end
+ else
+ begin
+ if (r = 15) then
+ begin { ZRL }
+ Inc(k, 15); { skip 15 zeroes in band }
+ end
+ else
+ begin { EOBr, run length is 2^r + appended bits }
+ EOBRUN := 1 shl r;
+ if (r <> 0) then
+ begin { EOBr, r > 0 }
+ {CHECK_BIT_BUFFER(br_state, r, return FALSE);}
+ if (bits_left < r) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then
+ begin
+ decode_mcu_AC_first := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(r);}
+ Dec(bits_left, r);
+ r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) );
+
+ Inc(EOBRUN, r);
+ end;
+ Dec(EOBRUN); { this band is processed at this moment }
+ break; { force end-of-band }
+ end;
+ end;
+ Inc(k);
+ end;
+
+ {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);}
+ cinfo^.src^.next_input_byte := br_state.next_input_byte;
+ cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ entropy^.bitstate.get_buffer := get_buffer;
+ entropy^.bitstate.bits_left := bits_left;
+ end;
+
+ { Completed MCU, so update state }
+ entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about }
+ end;
+
+ { Account for restart interval (no-op if not using restarts) }
+ Dec(entropy^.restarts_to_go);
+
+ decode_mcu_AC_first := TRUE;
+end;
+
+
+{ MCU decoding 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 decode_mcu_DC_refine (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+
+var
+ entropy : phuff_entropy_ptr;
+ p1 : int; { 1 in the bit position being coded }
+ blkn : int;
+ block : JBLOCK_PTR;
+ {BITREAD_STATE_VARS;}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+begin
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+ p1 := 1 shl cinfo^.Al;
+
+ { Process restart marker if needed; may have to suspend }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if (not process_restart(cinfo)) then
+ begin
+ decode_mcu_DC_refine := FALSE;
+ exit;
+ end;
+ end;
+
+ { Not worth the cycles to check insufficient_data here,
+ since we will not change the data anyway if we read zeroes. }
+
+ { Load up working state }
+ {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);}
+ br_state.cinfo := cinfo;
+ br_state.next_input_byte := cinfo^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ get_buffer := entropy^.bitstate.get_buffer;
+ bits_left := entropy^.bitstate.bits_left;
+
+ { Outer loop handles each block in the MCU }
+
+ for blkn := 0 to pred(cinfo^.blocks_in_MCU) do
+ begin
+ block := JBLOCK_PTR(MCU_data[blkn]);
+
+ { Encoded data is simply the next bit of the two's-complement DC value }
+ {CHECK_BIT_BUFFER(br_state, 1, return FALSE);}
+ if (bits_left < 1) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then
+ begin
+ decode_mcu_DC_refine := FALSE;
+ exit;
+ end;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {if (GET_BITS(1)) then}
+ Dec(bits_left);
+ if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) ) <> 0 then
+ block^[0] := block^[0] or p1;
+ { Note: since we use OR, repeating the assignment later is safe }
+ end;
+
+ { Completed MCU, so update state }
+ {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);}
+ cinfo^.src^.next_input_byte := br_state.next_input_byte;
+ cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ entropy^.bitstate.get_buffer := get_buffer;
+ entropy^.bitstate.bits_left := bits_left;
+
+ { Account for restart interval (no-op if not using restarts) }
+ Dec(entropy^.restarts_to_go);
+
+ decode_mcu_DC_refine := TRUE;
+end;
+
+
+{ MCU decoding for AC successive approximation refinement scan. }
+
+{METHODDEF}
+function decode_mcu_AC_refine (cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+label
+ undoit, label3;
+var
+ entropy : phuff_entropy_ptr;
+ Se : int;
+ p1 : int; { 1 in the bit position being coded }
+ m1 : int; { -1 in the bit position being coded }
+ {register} s, k, r : int;
+ EOBRUN : uInt;
+ block : JBLOCK_PTR;
+ thiscoef : JCOEF_PTR;
+ {BITREAD_STATE_VARS;}
+ get_buffer : bit_buf_type ; {register}
+ bits_left : int; {register}
+ br_state : bitread_working_state;
+
+ tbl : d_derived_tbl_ptr;
+ num_newnz : int;
+ newnz_pos : array[0..DCTSIZE2-1] of int;
+var
+ pos : int;
+var
+ nb, look : int; {register}
+begin
+ num_newnz := 0;
+ block := nil;
+
+ entropy := phuff_entropy_ptr (cinfo^.entropy);
+ Se := cinfo^.Se;
+ p1 := 1 shl cinfo^.Al; { 1 in the bit position being coded }
+ m1 := (-1) shl cinfo^.Al; { -1 in the bit position being coded }
+
+ { Process restart marker if needed; may have to suspend }
+ if (cinfo^.restart_interval <> 0) then
+ begin
+ if (entropy^.restarts_to_go = 0) then
+ if (not process_restart(cinfo)) then
+ begin
+ decode_mcu_AC_refine := FALSE;
+ exit;
+ end;
+ end;
+
+ { If we've run out of data, don't modify the MCU. }
+ if not entropy^.pub.insufficient_data then
+ begin
+
+ { Load up working state }
+ {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);}
+ br_state.cinfo := cinfo;
+ br_state.next_input_byte := cinfo^.src^.next_input_byte;
+ br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer;
+ get_buffer := entropy^.bitstate.get_buffer;
+ bits_left := entropy^.bitstate.bits_left;
+
+ EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about }
+
+ { There is always only one block per MCU }
+ block := JBLOCK_PTR(MCU_data[0]);
+ tbl := entropy^.ac_derived_tbl;
+
+ { If we are forced to suspend, we must undo the assignments to any newly
+ nonzero coefficients in the block, because otherwise we'd get confused
+ next time about which coefficients were already nonzero.
+ But we need not undo addition of bits to already-nonzero coefficients;
+ instead, we can test the current bit position to see if we already did it.}
+
+ num_newnz := 0;
+
+ { initialize coefficient loop counter to start of band }
+ k := cinfo^.Ss;
+
+ if (EOBRUN = 0) then
+ begin
+ while (k <= Se) do
+ begin
+ {HUFF_DECODE(s, br_state, tbl, goto undoit, label3);}
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ if (bits_left < HUFF_LOOKAHEAD) then
+ begin
+ nb := 1;
+ goto label3;
+ end;
+ end;
+ {look := PEEK_BITS(HUFF_LOOKAHEAD);}
+ look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and
+ pred(1 shl HUFF_LOOKAHEAD);
+
+ nb := tbl^.look_nbits[look];
+ if (nb <> 0) then
+ begin
+ {DROP_BITS(nb);}
+ Dec(bits_left, nb);
+
+ s := tbl^.look_sym[look];
+ end
+ else
+ begin
+ nb := HUFF_LOOKAHEAD+1;
+ label3:
+ s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb);
+ if (s < 0) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ r := s shr 4;
+ s := s and 15;
+ if (s <> 0) then
+ begin
+ if (s <> 1) then { size of new coef should always be 1 }
+ WARNMS(j_common_ptr(cinfo), JWRN_HUFF_BAD_CODE);
+ {CHECK_BIT_BUFFER(br_state, 1, goto undoit);}
+ if (bits_left < 1) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {if (GET_BITS(1)) then}
+ Dec(bits_left);
+ if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then
+ s := p1 { newly nonzero coef is positive }
+ else
+ s := m1; { newly nonzero coef is negative }
+ end
+ else
+ begin
+ if (r <> 15) then
+ begin
+ EOBRUN := 1 shl r; { EOBr, run length is 2^r + appended bits }
+ if (r <> 0) then
+ begin
+ {CHECK_BIT_BUFFER(br_state, r, goto undoit);}
+ if (bits_left < r) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {r := GET_BITS(r);}
+ Dec(bits_left, r);
+ r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) );
+
+ Inc(EOBRUN, r);
+ end;
+ break; { rest of block is handled by EOB logic }
+ end;
+ { note s := 0 for processing ZRL }
+ end;
+ { Advance over already-nonzero coefs and r still-zero coefs,
+ appending correction bits to the nonzeroes. A correction bit is 1
+ if the absolute value of the coefficient must be increased. }
+
+ repeat
+ thiscoef :=@(block^[jpeg_natural_order[k]]);
+ if (thiscoef^ <> 0) then
+ begin
+ {CHECK_BIT_BUFFER(br_state, 1, goto undoit);}
+ if (bits_left < 1) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {if (GET_BITS(1)) then}
+ Dec(bits_left);
+ if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then
+ begin
+ if ((thiscoef^ and p1) = 0) then
+ begin { do nothing if already set it }
+ if (thiscoef^ >= 0) then
+ Inc(thiscoef^, p1)
+ else
+ Inc(thiscoef^, m1);
+ end;
+ end;
+ end
+ else
+ begin
+ Dec(r);
+ if (r < 0) then
+ break; { reached target zero coefficient }
+ end;
+ Inc(k);
+ until (k > Se);
+ if (s <> 0) then
+ begin
+ pos := jpeg_natural_order[k];
+ { Output newly nonzero coefficient }
+ block^[pos] := JCOEF (s);
+ { Remember its position in case we have to suspend }
+ newnz_pos[num_newnz] := pos;
+ Inc(num_newnz);
+ end;
+ Inc(k);
+ end;
+ end;
+
+ if (EOBRUN > 0) then
+ begin
+ { Scan any remaining coefficient positions after the end-of-band
+ (the last newly nonzero coefficient, if any). Append a correction
+ bit to each already-nonzero coefficient. A correction bit is 1
+ if the absolute value of the coefficient must be increased. }
+
+ while (k <= Se) do
+ begin
+ thiscoef := @(block^[jpeg_natural_order[k]]);
+ if (thiscoef^ <> 0) then
+ begin
+ {CHECK_BIT_BUFFER(br_state, 1, goto undoit);}
+ if (bits_left < 1) then
+ begin
+ if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then
+ goto undoit;
+ get_buffer := br_state.get_buffer;
+ bits_left := br_state.bits_left;
+ end;
+
+ {if (GET_BITS(1)) then}
+ Dec(bits_left);
+ if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then
+ begin
+ if ((thiscoef^ and p1) = 0) then
+ begin { do nothing if already changed it }
+ if (thiscoef^ >= 0) then
+ Inc(thiscoef^, p1)
+ else
+ Inc(thiscoef^, m1);
+ end;
+ end;
+ end;
+ Inc(k);
+ end;
+ { Count one block completed in EOB run }
+ Dec(EOBRUN);
+ end;
+
+ { Completed MCU, so update state }
+ {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);}
+ cinfo^.src^.next_input_byte := br_state.next_input_byte;
+ cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer;
+ entropy^.bitstate.get_buffer := get_buffer;
+ entropy^.bitstate.bits_left := bits_left;
+
+ entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about }
+ end;
+
+ { Account for restart interval (no-op if not using restarts) }
+ Dec(entropy^.restarts_to_go);
+
+ decode_mcu_AC_refine := TRUE;
+ exit;
+
+undoit:
+ { Re-zero any output coefficients that we made newly nonzero }
+ while (num_newnz > 0) do
+ begin
+ Dec(num_newnz);
+ block^[newnz_pos[num_newnz]] := 0;
+ end;
+
+ decode_mcu_AC_refine := FALSE;
+end;
+
+
+{ Module initialization routine for progressive Huffman entropy decoding. }
+
+{GLOBAL}
+procedure jinit_phuff_decoder (cinfo : j_decompress_ptr);
+var
+ entropy : phuff_entropy_ptr;
+ coef_bit_ptr : int_ptr;
+ ci, i : int;
+begin
+ entropy := phuff_entropy_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE,
+ SIZEOF(phuff_entropy_decoder)) );
+ cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy);
+ entropy^.pub.start_pass := start_pass_phuff_decoder;
+
+ { Mark derived tables unallocated }
+ for i := 0 to pred(NUM_HUFF_TBLS) do
+ begin
+ entropy^.derived_tbls[i] := NIL;
+ end;
+
+ { Create progression status table }
+ cinfo^.coef_bits := coef_bits_ptrrow (
+ cinfo^.mem^.alloc_small ( j_common_ptr (cinfo), JPOOL_IMAGE,
+ cinfo^.num_components*DCTSIZE2*SIZEOF(int)) );
+ coef_bit_ptr := @cinfo^.coef_bits^[0][0];
+ for ci := 0 to pred(cinfo^.num_components) do
+ for i := 0 to pred(DCTSIZE2) do
+ begin
+ coef_bit_ptr^ := -1;
+ Inc(coef_bit_ptr);
+ end;
+end;
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjdpostct.pas b/src/lib/vampimg/JpegLib/imjdpostct.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjdsample.pas b/src/lib/vampimg/JpegLib/imjdsample.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjerror.pas b/src/lib/vampimg/JpegLib/imjerror.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjfdctflt.pas b/src/lib/vampimg/JpegLib/imjfdctflt.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjfdctfst.pas b/src/lib/vampimg/JpegLib/imjfdctfst.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjfdctint.pas b/src/lib/vampimg/JpegLib/imjfdctint.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjidctasm.pas b/src/lib/vampimg/JpegLib/imjidctasm.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjidctflt.pas b/src/lib/vampimg/JpegLib/imjidctflt.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjidctfst.pas b/src/lib/vampimg/JpegLib/imjidctfst.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjidctint.pas b/src/lib/vampimg/JpegLib/imjidctint.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjidctred.pas b/src/lib/vampimg/JpegLib/imjidctred.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjinclude.pas b/src/lib/vampimg/JpegLib/imjinclude.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjmemmgr.pas b/src/lib/vampimg/JpegLib/imjmemmgr.pas
--- /dev/null
@@ -0,0 +1,1283 @@
+unit imjmemmgr;
+
+{ This file contains the JPEG system-independent memory management
+ routines. This code is usable across a wide variety of machines; most
+ of the system dependencies have been isolated in a separate file.
+ The major functions provided here are:
+ * pool-based allocation and freeing of memory;
+ * policy decisions about how to divide available memory among the
+ virtual arrays;
+ * control logic for swapping virtual arrays between main memory and
+ backing storage.
+ The separate system-dependent file provides the actual backing-storage
+ access code, and it contains the policy decision about how much total
+ main memory to use.
+ This file is system-dependent in the sense that some of its functions
+ are unnecessary in some systems. For example, if there is enough virtual
+ memory so that backing storage will never be used, much of the virtual
+ array control logic could be removed. (Of course, if you have that much
+ memory then you shouldn't care about a little bit of unused code...) }
+
+{ Original : jmemmgr.c ; Copyright (C) 1991-1997, Thomas G. Lane. }
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg,
+ imjinclude,
+ imjdeferr,
+ imjerror,
+ imjpeglib,
+ imjutils,
+{$IFDEF VER70}
+{$ifndef NO_GETENV}
+ Dos, { DOS unit should declare getenv() }
+ { function GetEnv(name : string) : string; }
+{$endif}
+ imjmemdos; { import the system-dependent declarations }
+{$ELSE}
+ imjmemnobs;
+ {$DEFINE NO_GETENV}
+{$ENDIF}
+
+{ Memory manager initialization.
+ When this is called, only the error manager pointer is valid in cinfo! }
+
+{GLOBAL}
+procedure jinit_memory_mgr (cinfo : j_common_ptr);
+
+implementation
+
+
+{ Some important notes:
+ The allocation routines provided here must never return NIL.
+ They should exit to error_exit if unsuccessful.
+
+ It's not a good idea to try to merge the sarray and barray routines,
+ even though they are textually almost the same, because samples are
+ usually stored as bytes while coefficients are shorts or ints. Thus,
+ in machines where byte pointers have a different representation from
+ word pointers, the resulting machine code could not be the same. }
+
+
+{ Many machines require storage alignment: longs must start on 4-byte
+ boundaries, doubles on 8-byte boundaries, etc. On such machines, malloc()
+ always returns pointers that are multiples of the worst-case alignment
+ requirement, and we had better do so too.
+ There isn't any really portable way to determine the worst-case alignment
+ requirement. This module assumes that the alignment requirement is
+ multiples of sizeof(ALIGN_TYPE).
+ By default, we define ALIGN_TYPE as double. This is necessary on some
+ workstations (where doubles really do need 8-byte alignment) and will work
+ fine on nearly everything. If your machine has lesser alignment needs,
+ you can save a few bytes by making ALIGN_TYPE smaller.
+ The only place I know of where this will NOT work is certain Macintosh
+ 680x0 compilers that define double as a 10-byte IEEE extended float.
+ Doing 10-byte alignment is counterproductive because longwords won't be
+ aligned well. Put "#define ALIGN_TYPE long" in jconfig.h if you have
+ such a compiler. }
+
+{$ifndef ALIGN_TYPE} { so can override from jconfig.h }
+type
+ ALIGN_TYPE = double;
+{$endif}
+
+
+{ We allocate objects from "pools", where each pool is gotten with a single
+ request to jpeg_get_small() or jpeg_get_large(). There is no per-object
+ overhead within a pool, except for alignment padding. Each pool has a
+ header with a link to the next pool of the same class.
+ Small and large pool headers are identical except that the latter's
+ link pointer must be FAR on 80x86 machines.
+ Notice that the "real" header fields are union'ed with a dummy ALIGN_TYPE
+ field. This forces the compiler to make SIZEOF(small_pool_hdr) a multiple
+ of the alignment requirement of ALIGN_TYPE. }
+
+type
+ small_pool_ptr = ^small_pool_hdr;
+ small_pool_hdr = record
+ case byte of
+ 0:(hdr : record
+ next : small_pool_ptr; { next in list of pools }
+ bytes_used : size_t; { how many bytes already used within pool }
+ bytes_left : size_t; { bytes still available in this pool }
+ end);
+ 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment }
+ end; {small_pool_hdr;}
+
+type
+ large_pool_ptr = ^large_pool_hdr; {FAR}
+ large_pool_hdr = record
+ case byte of
+ 0:(hdr : record
+ next : large_pool_ptr; { next in list of pools }
+ bytes_used : size_t; { how many bytes already used within pool }
+ bytes_left : size_t; { bytes still available in this pool }
+ end);
+ 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment }
+ end; {large_pool_hdr;}
+
+
+{ Here is the full definition of a memory manager object. }
+
+type
+ my_mem_ptr = ^my_memory_mgr;
+ my_memory_mgr = record
+ pub : jpeg_memory_mgr; { public fields }
+
+ { Each pool identifier (lifetime class) names a linked list of pools. }
+ small_list : array[0..JPOOL_NUMPOOLS-1] of small_pool_ptr ;
+ large_list : array[0..JPOOL_NUMPOOLS-1] of large_pool_ptr ;
+
+ { Since we only have one lifetime class of virtual arrays, only one
+ linked list is necessary (for each datatype). Note that the virtual
+ array control blocks being linked together are actually stored somewhere
+ in the small-pool list. }
+
+ virt_sarray_list : jvirt_sarray_ptr;
+ virt_barray_list : jvirt_barray_ptr;
+
+ { This counts total space obtained from jpeg_get_small/large }
+ total_space_allocated : long;
+
+ { alloc_sarray and alloc_barray set this value for use by virtual
+ array routines. }
+
+ last_rowsperchunk : JDIMENSION; { from most recent alloc_sarray/barray }
+ end; {my_memory_mgr;}
+
+ {$ifndef AM_MEMORY_MANAGER} { only jmemmgr.c defines these }
+
+{ The control blocks for virtual arrays.
+ Note that these blocks are allocated in the "small" pool area.
+ System-dependent info for the associated backing store (if any) is hidden
+ inside the backing_store_info struct. }
+type
+ jvirt_sarray_control = record
+ mem_buffer : JSAMPARRAY; { => the in-memory buffer }
+ rows_in_array : JDIMENSION; { total virtual array height }
+ samplesperrow : JDIMENSION; { width of array (and of memory buffer) }
+ maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray }
+ rows_in_mem : JDIMENSION; { height of memory buffer }
+ rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer }
+ cur_start_row : JDIMENSION; { first logical row # in the buffer }
+ first_undef_row : JDIMENSION; { row # of first uninitialized row }
+ pre_zero : boolean; { pre-zero mode requested? }
+ dirty : boolean; { do current buffer contents need written? }
+ b_s_open : boolean; { is backing-store data valid? }
+ next : jvirt_sarray_ptr; { link to next virtual sarray control block }
+ b_s_info : backing_store_info; { System-dependent control info }
+ end;
+
+ jvirt_barray_control = record
+ mem_buffer : JBLOCKARRAY; { => the in-memory buffer }
+ rows_in_array : JDIMENSION; { total virtual array height }
+ blocksperrow : JDIMENSION; { width of array (and of memory buffer) }
+ maxaccess : JDIMENSION; { max rows accessed by access_virt_barray }
+ rows_in_mem : JDIMENSION; { height of memory buffer }
+ rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer }
+ cur_start_row : JDIMENSION; { first logical row # in the buffer }
+ first_undef_row : JDIMENSION; { row # of first uninitialized row }
+ pre_zero : boolean; { pre-zero mode requested? }
+ dirty : boolean; { do current buffer contents need written? }
+ b_s_open : boolean; { is backing-store data valid? }
+ next : jvirt_barray_ptr; { link to next virtual barray control block }
+ b_s_info : backing_store_info; { System-dependent control info }
+ end;
+ {$endif} { AM_MEMORY_MANAGER}
+
+{$ifdef MEM_STATS} { optional extra stuff for statistics }
+
+{LOCAL}
+procedure print_mem_stats (cinfo : j_common_ptr; pool_id : int);
+var
+ mem : my_mem_ptr;
+ shdr_ptr : small_pool_ptr;
+ lhdr_ptr : large_pool_ptr;
+begin
+ mem := my_mem_ptr (cinfo^.mem);
+
+ { Since this is only a debugging stub, we can cheat a little by using
+ fprintf directly rather than going through the trace message code.
+ This is helpful because message parm array can't handle longs. }
+
+ WriteLn(output, 'Freeing pool ', pool_id,', total space := ',
+ mem^.total_space_allocated);
+
+ lhdr_ptr := mem^.large_list[pool_id];
+ while (lhdr_ptr <> NIL) do
+ begin
+ WriteLn(output, ' Large chunk used ',
+ long (lhdr_ptr^.hdr.bytes_used));
+ lhdr_ptr := lhdr_ptr^.hdr.next;
+ end;
+
+ shdr_ptr := mem^.small_list[pool_id];
+
+ while (shdr_ptr <> NIL) do
+ begin
+ WriteLn(output, ' Small chunk used ',
+ long (shdr_ptr^.hdr.bytes_used), ' free ',
+ long (shdr_ptr^.hdr.bytes_left) );
+ shdr_ptr := shdr_ptr^.hdr.next;
+ end;
+end;
+
+{$endif} { MEM_STATS }
+
+
+{LOCAL}
+procedure out_of_memory (cinfo : j_common_ptr; which : int);
+{ Report an out-of-memory error and stop execution }
+{ If we compiled MEM_STATS support, report alloc requests before dying }
+begin
+{$ifdef MEM_STATS}
+ cinfo^.err^.trace_level := 2; { force self_destruct to report stats }
+{$endif}
+ ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, which);
+end;
+
+
+{ Allocation of "small" objects.
+
+ For these, we use pooled storage. When a new pool must be created,
+ we try to get enough space for the current request plus a "slop" factor,
+ where the slop will be the amount of leftover space in the new pool.
+ The speed vs. space tradeoff is largely determined by the slop values.
+ A different slop value is provided for each pool class (lifetime),
+ and we also distinguish the first pool of a class from later ones.
+ NOTE: the values given work fairly well on both 16- and 32-bit-int
+ machines, but may be too small if longs are 64 bits or more. }
+
+const
+ first_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t =
+ (1600, { first PERMANENT pool }
+ 16000); { first IMAGE pool }
+
+const
+ extra_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t =
+ (0, { additional PERMANENT pools }
+ 5000); { additional IMAGE pools }
+
+const
+ MIN_SLOP = 50; { greater than 0 to avoid futile looping }
+
+
+{METHODDEF}
+function alloc_small (cinfo : j_common_ptr;
+ pool_id : int;
+ sizeofobject : size_t) : pointer;
+type
+ byteptr = ^byte;
+{ Allocate a "small" object }
+var
+ mem : my_mem_ptr;
+ hdr_ptr, prev_hdr_ptr : small_pool_ptr;
+ data_ptr : byteptr;
+ odd_bytes, min_request, slop : size_t;
+begin
+ mem := my_mem_ptr (cinfo^.mem);
+
+ { Check for unsatisfiable request (do now to ensure no overflow below) }
+ if (sizeofobject > size_t(MAX_ALLOC_CHUNK-SIZEOF(small_pool_hdr))) then
+ out_of_memory(cinfo, 1); { request exceeds malloc's ability }
+
+ { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) }
+ odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE);
+ if (odd_bytes > 0) then
+ Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes);
+
+ { See if space is available in any existing pool }
+ if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_BAD_POOL_ID, pool_id); { safety check }
+ prev_hdr_ptr := NIL;
+ hdr_ptr := mem^.small_list[pool_id];
+ while (hdr_ptr <> NIL) do
+ begin
+ if (hdr_ptr^.hdr.bytes_left >= sizeofobject) then
+ break; { found pool with enough space }
+ prev_hdr_ptr := hdr_ptr;
+ hdr_ptr := hdr_ptr^.hdr.next;
+ end;
+
+ { Time to make a new pool? }
+ if (hdr_ptr = NIL) then
+ begin
+ { min_request is what we need now, slop is what will be leftover }
+ min_request := sizeofobject + SIZEOF(small_pool_hdr);
+ if (prev_hdr_ptr = NIL) then { first pool in class? }
+ slop := first_pool_slop[pool_id]
+ else
+ slop := extra_pool_slop[pool_id];
+ { Don't ask for more than MAX_ALLOC_CHUNK }
+ if (slop > size_t (MAX_ALLOC_CHUNK-min_request)) then
+ slop := size_t (MAX_ALLOC_CHUNK-min_request);
+ { Try to get space, if fail reduce slop and try again }
+ while TRUE do
+ begin
+ hdr_ptr := small_pool_ptr(jpeg_get_small(cinfo, min_request + slop));
+ if (hdr_ptr <> NIL) then
+ break;
+ slop := slop div 2;
+ if (slop < MIN_SLOP) then { give up when it gets real small }
+ out_of_memory(cinfo, 2); { jpeg_get_small failed }
+ end;
+ Inc(mem^.total_space_allocated, min_request + slop);
+ { Success, initialize the new pool header and add to end of list }
+ hdr_ptr^.hdr.next := NIL;
+ hdr_ptr^.hdr.bytes_used := 0;
+ hdr_ptr^.hdr.bytes_left := sizeofobject + slop;
+ if (prev_hdr_ptr = NIL) then { first pool in class? }
+ mem^.small_list[pool_id] := hdr_ptr
+ else
+ prev_hdr_ptr^.hdr.next := hdr_ptr;
+ end;
+
+ { OK, allocate the object from the current pool }
+ data_ptr := byteptr (hdr_ptr);
+ Inc(small_pool_ptr(data_ptr)); { point to first data byte in pool }
+ Inc(data_ptr, hdr_ptr^.hdr.bytes_used); { point to place for object }
+ Inc(hdr_ptr^.hdr.bytes_used, sizeofobject);
+ Dec(hdr_ptr^.hdr.bytes_left, sizeofobject);
+
+ alloc_small := pointer(data_ptr);
+end;
+
+
+{ Allocation of "large" objects.
+
+ The external semantics of these are the same as "small" objects,
+ except that FAR pointers are used on 80x86. However the pool
+ management heuristics are quite different. We assume that each
+ request is large enough that it may as well be passed directly to
+ jpeg_get_large; the pool management just links everything together
+ so that we can free it all on demand.
+ Note: the major use of "large" objects is in JSAMPARRAY and JBLOCKARRAY
+ structures. The routines that create these structures (see below)
+ deliberately bunch rows together to ensure a large request size. }
+
+{METHODDEF}
+function alloc_large (cinfo : j_common_ptr;
+ pool_id : int;
+ sizeofobject : size_t) : pointer;
+{ Allocate a "large" object }
+var
+ mem : my_mem_ptr;
+ hdr_ptr : large_pool_ptr;
+ odd_bytes : size_t;
+var
+ dest_ptr : large_pool_ptr;
+begin
+ mem := my_mem_ptr (cinfo^.mem);
+
+ { Check for unsatisfiable request (do now to ensure no overflow below) }
+ if (sizeofobject > size_t (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr))) then
+ out_of_memory(cinfo, 3); { request exceeds malloc's ability }
+
+ { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) }
+ odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE);
+ if (odd_bytes > 0) then
+ Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes);
+
+ { Always make a new pool }
+ if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then
+ ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check }
+
+ hdr_ptr := large_pool_ptr (jpeg_get_large(cinfo, sizeofobject +
+ SIZEOF(large_pool_hdr)));
+ if (hdr_ptr = NIL) then
+ out_of_memory(cinfo, 4); { jpeg_get_large failed }
+ Inc(mem^.total_space_allocated, sizeofobject + SIZEOF(large_pool_hdr));
+
+ { Success, initialize the new pool header and add to list }
+ hdr_ptr^.hdr.next := mem^.large_list[pool_id];
+ { We maintain space counts in each pool header for statistical purposes,
+ even though they are not needed for allocation. }
+
+ hdr_ptr^.hdr.bytes_used := sizeofobject;
+ hdr_ptr^.hdr.bytes_left := 0;
+ mem^.large_list[pool_id] := hdr_ptr;
+
+ {alloc_large := pointerFAR (hdr_ptr + 1); - point to first data byte in pool }
+ dest_ptr := hdr_ptr;
+ Inc(large_pool_ptr(dest_ptr));
+ alloc_large := dest_ptr;
+end;
+
+
+{ Creation of 2-D sample arrays.
+ The pointers are in near heap, the samples themselves in FAR heap.
+
+ To minimize allocation overhead and to allow I/O of large contiguous
+ blocks, we allocate the sample rows in groups of as many rows as possible
+ without exceeding MAX_ALLOC_CHUNK total bytes per allocation request.
+ NB: the virtual array control routines, later in this file, know about
+ this chunking of rows. The rowsperchunk value is left in the mem manager
+ object so that it can be saved away if this sarray is the workspace for
+ a virtual array. }
+
+{METHODDEF}
+function alloc_sarray (cinfo : j_common_ptr;
+ pool_id : int;
+ samplesperrow : JDIMENSION;
+ numrows : JDIMENSION) : JSAMPARRAY;
+{ Allocate a 2-D sample array }
+var
+ mem : my_mem_ptr;
+ the_result : JSAMPARRAY;
+ workspace : JSAMPROW;
+ rowsperchunk, currow, i : JDIMENSION;
+ ltemp : long;
+begin
+ mem := my_mem_ptr(cinfo^.mem);
+
+ { Calculate max # of rows allowed in one allocation chunk }
+ ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div
+ (long(samplesperrow) * SIZEOF(JSAMPLE));
+ if (ltemp <= 0) then
+ ERREXIT(cinfo, JERR_WIDTH_OVERFLOW);
+ if (ltemp < long(numrows)) then
+ rowsperchunk := JDIMENSION (ltemp)
+ else
+ rowsperchunk := numrows;
+ mem^.last_rowsperchunk := rowsperchunk;
+
+ { Get space for row pointers (small object) }
+ the_result := JSAMPARRAY (alloc_small(cinfo, pool_id,
+ size_t (numrows * SIZEOF(JSAMPROW))));
+
+ { Get the rows themselves (large objects) }
+ currow := 0;
+ while (currow < numrows) do
+ begin
+ {rowsperchunk := MIN(rowsperchunk, numrows - currow);}
+ if rowsperchunk > numrows - currow then
+ rowsperchunk := numrows - currow;
+
+ workspace := JSAMPROW (alloc_large(cinfo, pool_id,
+ size_t (size_t(rowsperchunk) * size_t(samplesperrow)
+ * SIZEOF(JSAMPLE))) );
+ for i := pred(rowsperchunk) downto 0 do
+ begin
+ the_result^[currow] := workspace;
+ Inc(currow);
+ Inc(JSAMPLE_PTR(workspace), samplesperrow);
+ end;
+ end;
+
+ alloc_sarray := the_result;
+end;
+
+
+{ Creation of 2-D coefficient-block arrays.
+ This is essentially the same as the code for sample arrays, above. }
+
+{METHODDEF}
+function alloc_barray (cinfo : j_common_ptr;
+ pool_id : int;
+ blocksperrow : JDIMENSION;
+ numrows : JDIMENSION) : JBLOCKARRAY;
+{ Allocate a 2-D coefficient-block array }
+var
+ mem : my_mem_ptr;
+ the_result : JBLOCKARRAY;
+ workspace : JBLOCKROW;
+ rowsperchunk, currow, i : JDIMENSION;
+ ltemp : long;
+begin
+ mem := my_mem_ptr(cinfo^.mem);
+
+ { Calculate max # of rows allowed in one allocation chunk }
+ ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div
+ (long(blocksperrow) * SIZEOF(JBLOCK));
+
+ if (ltemp <= 0) then
+ ERREXIT(cinfo, JERR_WIDTH_OVERFLOW);
+ if (ltemp < long(numrows)) then
+ rowsperchunk := JDIMENSION (ltemp)
+ else
+ rowsperchunk := numrows;
+ mem^.last_rowsperchunk := rowsperchunk;
+
+ { Get space for row pointers (small object) }
+ the_result := JBLOCKARRAY (alloc_small(cinfo, pool_id,
+ size_t (numrows * SIZEOF(JBLOCKROW))) );
+
+ { Get the rows themselves (large objects) }
+ currow := 0;
+ while (currow < numrows) do
+ begin
+ {rowsperchunk := MIN(rowsperchunk, numrows - currow);}
+ if rowsperchunk > numrows - currow then
+ rowsperchunk := numrows - currow;
+
+ workspace := JBLOCKROW (alloc_large(cinfo, pool_id,
+ size_t (size_t(rowsperchunk) * size_t(blocksperrow)
+ * SIZEOF(JBLOCK))) );
+ for i := rowsperchunk downto 1 do
+ begin
+ the_result^[currow] := workspace;
+ Inc(currow);
+ Inc(JBLOCK_PTR(workspace), blocksperrow);
+ end;
+ end;
+
+ alloc_barray := the_result;
+end;
+
+
+{ About virtual array management:
+
+ The above "normal" array routines are only used to allocate strip buffers
+ (as wide as the image, but just a few rows high). Full-image-sized buffers
+ are handled as "virtual" arrays. The array is still accessed a strip at a
+ time, but the memory manager must save the whole array for repeated
+ accesses. The intended implementation is that there is a strip buffer in
+ memory (as high as is possible given the desired memory limit), plus a
+ backing file that holds the rest of the array.
+
+ The request_virt_array routines are told the total size of the image and
+ the maximum number of rows that will be accessed at once. The in-memory
+ buffer must be at least as large as the maxaccess value.
+
+ The request routines create control blocks but not the in-memory buffers.
+ That is postponed until realize_virt_arrays is called. At that time the
+ total amount of space needed is known (approximately, anyway), so free
+ memory can be divided up fairly.
+
+ The access_virt_array routines are responsible for making a specific strip
+ area accessible (after reading or writing the backing file, if necessary).
+ Note that the access routines are told whether the caller intends to modify
+ the accessed strip; during a read-only pass this saves having to rewrite
+ data to disk. The access routines are also responsible for pre-zeroing
+ any newly accessed rows, if pre-zeroing was requested.
+
+ In current usage, the access requests are usually for nonoverlapping
+ strips; that is, successive access start_row numbers differ by exactly
+ num_rows := maxaccess. This means we can get good performance with simple
+ buffer dump/reload logic, by making the in-memory buffer be a multiple
+ of the access height; then there will never be accesses across bufferload
+ boundaries. The code will still work with overlapping access requests,
+ but it doesn't handle bufferload overlaps very efficiently. }
+
+
+{METHODDEF}
+function request_virt_sarray (cinfo : j_common_ptr;
+ pool_id : int;
+ pre_zero : boolean;
+ samplesperrow : JDIMENSION;
+ numrows : JDIMENSION;
+ maxaccess : JDIMENSION) : jvirt_sarray_ptr;
+{ Request a virtual 2-D sample array }
+var
+ mem : my_mem_ptr;
+ the_result : jvirt_sarray_ptr;
+begin
+ mem := my_mem_ptr (cinfo^.mem);
+
+ { Only IMAGE-lifetime virtual arrays are currently supported }
+ if (pool_id <> JPOOL_IMAGE) then
+ ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check }
+
+ { get control block }
+ the_result := jvirt_sarray_ptr (alloc_small(cinfo, pool_id,
+ SIZEOF(jvirt_sarray_control)) );
+
+ the_result^.mem_buffer := NIL; { marks array not yet realized }
+ the_result^.rows_in_array := numrows;
+ the_result^.samplesperrow := samplesperrow;
+ the_result^.maxaccess := maxaccess;
+ the_result^.pre_zero := pre_zero;
+ the_result^.b_s_open := FALSE; { no associated backing-store object }
+ the_result^.next := mem^.virt_sarray_list; { add to list of virtual arrays }
+ mem^.virt_sarray_list := the_result;
+
+ request_virt_sarray := the_result;
+end;
+
+
+{METHODDEF}
+function request_virt_barray (cinfo : j_common_ptr;
+ pool_id : int;
+ pre_zero : boolean;
+ blocksperrow : JDIMENSION;
+ numrows : JDIMENSION;
+ maxaccess : JDIMENSION) : jvirt_barray_ptr;
+{ Request a virtual 2-D coefficient-block array }
+var
+ mem : my_mem_ptr;
+ the_result : jvirt_barray_ptr;
+begin
+ mem := my_mem_ptr(cinfo^.mem);
+
+ { Only IMAGE-lifetime virtual arrays are currently supported }
+ if (pool_id <> JPOOL_IMAGE) then
+ ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check }
+
+ { get control block }
+ the_result := jvirt_barray_ptr(alloc_small(cinfo, pool_id,
+ SIZEOF(jvirt_barray_control)) );
+
+ the_result^.mem_buffer := NIL; { marks array not yet realized }
+ the_result^.rows_in_array := numrows;
+ the_result^.blocksperrow := blocksperrow;
+ the_result^.maxaccess := maxaccess;
+ the_result^.pre_zero := pre_zero;
+ the_result^.b_s_open := FALSE; { no associated backing-store object }
+ the_result^.next := mem^.virt_barray_list; { add to list of virtual arrays }
+ mem^.virt_barray_list := the_result;
+
+ request_virt_barray := the_result;
+end;
+
+
+{METHODDEF}
+procedure realize_virt_arrays (cinfo : j_common_ptr);
+{ Allocate the in-memory buffers for any unrealized virtual arrays }
+var
+ mem : my_mem_ptr;
+ space_per_minheight, maximum_space, avail_mem : long;
+ minheights, max_minheights : long;
+ sptr : jvirt_sarray_ptr;
+ bptr : jvirt_barray_ptr;
+begin
+ mem := my_mem_ptr (cinfo^.mem);
+ { Compute the minimum space needed (maxaccess rows in each buffer)
+ and the maximum space needed (full image height in each buffer).
+ These may be of use to the system-dependent jpeg_mem_available routine. }
+
+ space_per_minheight := 0;
+ maximum_space := 0;
+ sptr := mem^.virt_sarray_list;
+ while (sptr <> NIL) do
+ begin
+ if (sptr^.mem_buffer = NIL) then
+ begin { if not realized yet }
+ Inc(space_per_minheight, long(sptr^.maxaccess) *
+ long(sptr^.samplesperrow) * SIZEOF(JSAMPLE));
+ Inc(maximum_space, long(sptr^.rows_in_array) *
+ long(sptr^.samplesperrow) * SIZEOF(JSAMPLE));
+ end;
+ sptr := sptr^.next;
+ end;
+ bptr := mem^.virt_barray_list;
+ while (bptr <> NIL) do
+ begin
+ if (bptr^.mem_buffer = NIL) then
+ begin { if not realized yet }
+ Inc(space_per_minheight, long(bptr^.maxaccess) *
+ long(bptr^.blocksperrow) * SIZEOF(JBLOCK));
+ Inc(maximum_space, long(bptr^.rows_in_array) *
+ long(bptr^.blocksperrow) * SIZEOF(JBLOCK));
+ end;
+ bptr := bptr^.next;
+ end;
+
+ if (space_per_minheight <= 0) then
+ exit; { no unrealized arrays, no work }
+
+ { Determine amount of memory to actually use; this is system-dependent. }
+ avail_mem := jpeg_mem_available(cinfo, space_per_minheight, maximum_space,
+ mem^.total_space_allocated);
+
+ { If the maximum space needed is available, make all the buffers full
+ height; otherwise parcel it out with the same number of minheights
+ in each buffer. }
+
+ if (avail_mem >= maximum_space) then
+ max_minheights := long(1000000000)
+ else
+ begin
+ max_minheights := avail_mem div space_per_minheight;
+ { If there doesn't seem to be enough space, try to get the minimum
+ anyway. This allows a "stub" implementation of jpeg_mem_available(). }
+ if (max_minheights <= 0) then
+ max_minheights := 1;
+ end;
+
+ { Allocate the in-memory buffers and initialize backing store as needed. }
+
+ sptr := mem^.virt_sarray_list;
+ while (sptr <> NIL) do
+ begin
+ if (sptr^.mem_buffer = NIL) then
+ begin { if not realized yet }
+ minheights := (long(sptr^.rows_in_array) - long(1)) div LongInt(sptr^.maxaccess) + long(1);
+ if (minheights <= max_minheights) then
+ begin
+ { This buffer fits in memory }
+ sptr^.rows_in_mem := sptr^.rows_in_array;
+ end
+ else
+ begin
+ { It doesn't fit in memory, create backing store. }
+ sptr^.rows_in_mem := JDIMENSION(max_minheights) * sptr^.maxaccess;
+ jpeg_open_backing_store(cinfo,
+ @sptr^.b_s_info,
+ long(sptr^.rows_in_array) *
+ long(sptr^.samplesperrow) *
+ long(SIZEOF(JSAMPLE)));
+ sptr^.b_s_open := TRUE;
+ end;
+ sptr^.mem_buffer := alloc_sarray(cinfo, JPOOL_IMAGE,
+ sptr^.samplesperrow, sptr^.rows_in_mem);
+ sptr^.rowsperchunk := mem^.last_rowsperchunk;
+ sptr^.cur_start_row := 0;
+ sptr^.first_undef_row := 0;
+ sptr^.dirty := FALSE;
+ end;
+ sptr := sptr^.next;
+ end;
+
+ bptr := mem^.virt_barray_list;
+ while (bptr <> NIL) do
+ begin
+ if (bptr^.mem_buffer = NIL) then
+ begin { if not realized yet }
+ minheights := (long(bptr^.rows_in_array) - long(1)) div LongInt(bptr^.maxaccess) + long(1);
+ if (minheights <= max_minheights) then
+ begin
+ { This buffer fits in memory }
+ bptr^.rows_in_mem := bptr^.rows_in_array;
+ end
+ else
+ begin
+ { It doesn't fit in memory, create backing store. }
+ bptr^.rows_in_mem := JDIMENSION (max_minheights) * bptr^.maxaccess;
+ jpeg_open_backing_store(cinfo,
+ @bptr^.b_s_info,
+ long(bptr^.rows_in_array) *
+ long(bptr^.blocksperrow) *
+ long(SIZEOF(JBLOCK)));
+ bptr^.b_s_open := TRUE;
+ end;
+ bptr^.mem_buffer := alloc_barray(cinfo, JPOOL_IMAGE,
+ bptr^.blocksperrow, bptr^.rows_in_mem);
+ bptr^.rowsperchunk := mem^.last_rowsperchunk;
+ bptr^.cur_start_row := 0;
+ bptr^.first_undef_row := 0;
+ bptr^.dirty := FALSE;
+ end;
+ bptr := bptr^.next;
+ end;
+end;
+
+
+{LOCAL}
+procedure do_sarray_io (cinfo : j_common_ptr;
+ ptr : jvirt_sarray_ptr;
+ writing : boolean);
+{ Do backing store read or write of a virtual sample array }
+var
+ bytesperrow, file_offset, byte_count, rows, thisrow, i : long;
+begin
+
+ bytesperrow := long(ptr^.samplesperrow * SIZEOF(JSAMPLE));
+ file_offset := LongInt(ptr^.cur_start_row) * bytesperrow;
+ { Loop to read or write each allocation chunk in mem_buffer }
+ i := 0;
+ while i < long(ptr^.rows_in_mem) do
+ begin
+
+ { One chunk, but check for short chunk at end of buffer }
+ {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));}
+ rows := long(ptr^.rowsperchunk);
+ if rows > long(ptr^.rows_in_mem) - i then
+ rows := long(ptr^.rows_in_mem) - i;
+ { Transfer no more than is currently defined }
+ thisrow := long (ptr^.cur_start_row) + i;
+ {rows := MIN(rows, long(ptr^.first_undef_row) - thisrow);}
+ if (rows > long(ptr^.first_undef_row) - thisrow) then
+ rows := long(ptr^.first_undef_row) - thisrow;
+ { Transfer no more than fits in file }
+ {rows := MIN(rows, long(ptr^.rows_in_array) - thisrow);}
+ if (rows > long(ptr^.rows_in_array) - thisrow) then
+ rows := long(ptr^.rows_in_array) - thisrow;
+
+ if (rows <= 0) then { this chunk might be past end of file! }
+ break;
+ byte_count := rows * bytesperrow;
+ if (writing) then
+ ptr^.b_s_info.write_backing_store (cinfo,
+ @ptr^.b_s_info,
+ pointer {FAR} (ptr^.mem_buffer^[i]),
+ file_offset, byte_count)
+ else
+ ptr^.b_s_info.read_backing_store (cinfo,
+ @ptr^.b_s_info,
+ pointer {FAR} (ptr^.mem_buffer^[i]),
+ file_offset, byte_count);
+ Inc(file_offset, byte_count);
+ Inc(i, ptr^.rowsperchunk);
+ end;
+end;
+
+
+{LOCAL}
+procedure do_barray_io (cinfo : j_common_ptr;
+ ptr : jvirt_barray_ptr;
+ writing : boolean);
+{ Do backing store read or write of a virtual coefficient-block array }
+var
+ bytesperrow, file_offset, byte_count, rows, thisrow, i : long;
+begin
+ bytesperrow := long (ptr^.blocksperrow) * SIZEOF(JBLOCK);
+ file_offset := LongInt(ptr^.cur_start_row) * bytesperrow;
+ { Loop to read or write each allocation chunk in mem_buffer }
+ i := 0;
+ while (i < long(ptr^.rows_in_mem)) do
+ begin
+ { One chunk, but check for short chunk at end of buffer }
+ {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));}
+ rows := long(ptr^.rowsperchunk);
+ if rows > long(ptr^.rows_in_mem) - i then
+ rows := long(ptr^.rows_in_mem) - i;
+ { Transfer no more than is currently defined }
+ thisrow := long (ptr^.cur_start_row) + i;
+ {rows := MIN(rows, long(ptr^.first_undef_row - thisrow));}
+ if rows > long(ptr^.first_undef_row) - thisrow then
+ rows := long(ptr^.first_undef_row) - thisrow;
+ { Transfer no more than fits in file }
+ {rows := MIN(rows, long (ptr^.rows_in_array - thisrow));}
+ if (rows > long (ptr^.rows_in_array) - thisrow) then
+ rows := long (ptr^.rows_in_array) - thisrow;
+
+ if (rows <= 0) then { this chunk might be past end of file! }
+ break;
+ byte_count := rows * bytesperrow;
+ if (writing) then
+ ptr^.b_s_info.write_backing_store (cinfo,
+ @ptr^.b_s_info,
+ {FAR} pointer(ptr^.mem_buffer^[i]),
+ file_offset, byte_count)
+ else
+ ptr^.b_s_info.read_backing_store (cinfo,
+ @ptr^.b_s_info,
+ {FAR} pointer(ptr^.mem_buffer^[i]),
+ file_offset, byte_count);
+ Inc(file_offset, byte_count);
+ Inc(i, ptr^.rowsperchunk);
+ end;
+end;
+
+
+{METHODDEF}
+function access_virt_sarray (cinfo : j_common_ptr;
+ ptr : jvirt_sarray_ptr;
+ start_row : JDIMENSION;
+ num_rows : JDIMENSION;
+ writable : boolean ) : JSAMPARRAY;
+{ Access the part of a virtual sample array starting at start_row }
+{ and extending for num_rows rows. writable is true if }
+{ caller intends to modify the accessed area. }
+var
+ end_row : JDIMENSION;
+ undef_row : JDIMENSION;
+var
+ bytesperrow : size_t;
+var
+ ltemp : long;
+begin
+ end_row := start_row + num_rows;
+ { debugging check }
+ if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or
+ (ptr^.mem_buffer = NIL) then
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+
+ { Make the desired part of the virtual array accessible }
+ if (start_row < ptr^.cur_start_row) or
+ (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then
+ begin
+ if (not ptr^.b_s_open) then
+ ERREXIT(cinfo, JERR_VIRTUAL_BUG);
+ { Flush old buffer contents if necessary }
+ if (ptr^.dirty) then
+ begin
+ do_sarray_io(cinfo, ptr, TRUE);
+ ptr^.dirty := FALSE;
+ end;
+ { Decide what part of virtual array to access.
+ Algorithm: if target address > current window, assume forward scan,
+ load starting at target address. If target address < current window,
+ assume backward scan, load so that target area is top of window.
+ Note that when switching from forward write to forward read, will have
+ start_row := 0, so the limiting case applies and we load from 0 anyway. }
+ if (start_row > ptr^.cur_start_row) then
+ begin
+ ptr^.cur_start_row := start_row;
+ end
+ else
+ begin
+ { use long arithmetic here to avoid overflow & unsigned problems }
+
+
+ ltemp := long(end_row) - long(ptr^.rows_in_mem);
+ if (ltemp < 0) then
+ ltemp := 0; { don't fall off front end of file }
+ ptr^.cur_start_row := JDIMENSION(ltemp);
+ end;
+ { Read in the selected part of the array.
+ During the initial write pass, we will do no actual read
+ because the selected part is all undefined. }
+
+ do_sarray_io(cinfo, ptr, FALSE);
+ end;
+ { Ensure the accessed part of the array is defined; prezero if needed.
+ To improve locality of access, we only prezero the part of the array
+ that the caller is about to access, not the entire in-memory array. }
+ if (ptr^.first_undef_row < end_row) then
+ begin
+ if (ptr^.first_undef_row < start_row) then
+ begin
+ if (writable) then { writer skipped over a section of array }
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+ undef_row := start_row; { but reader is allowed to read ahead }
+ end
+ else
+ begin
+ undef_row := ptr^.first_undef_row;
+ end;
+ if (writable) then
+ ptr^.first_undef_row := end_row;
+ if (ptr^.pre_zero) then
+ begin
+ bytesperrow := size_t(ptr^.samplesperrow) * SIZEOF(JSAMPLE);
+ Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer }
+ Dec(end_row, ptr^.cur_start_row);
+ while (undef_row < end_row) do
+ begin
+ jzero_far({FAR} pointer(ptr^.mem_buffer^[undef_row]), bytesperrow);
+ Inc(undef_row);
+ end;
+ end
+ else
+ begin
+ if (not writable) then { reader looking at undefined data }
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+ end;
+ end;
+ { Flag the buffer dirty if caller will write in it }
+ if (writable) then
+ ptr^.dirty := TRUE;
+ { Return address of proper part of the buffer }
+ access_virt_sarray := JSAMPARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]);
+end;
+
+
+{METHODDEF}
+function access_virt_barray (cinfo : j_common_ptr;
+ ptr : jvirt_barray_ptr;
+ start_row : JDIMENSION;
+ num_rows : JDIMENSION;
+ writable : boolean) : JBLOCKARRAY;
+{ Access the part of a virtual block array starting at start_row }
+{ and extending for num_rows rows. writable is true if }
+{ caller intends to modify the accessed area. }
+var
+ end_row : JDIMENSION;
+ undef_row : JDIMENSION;
+ ltemp : long;
+var
+ bytesperrow : size_t;
+begin
+ end_row := start_row + num_rows;
+
+ { debugging check }
+ if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or
+ (ptr^.mem_buffer = NIL) then
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+
+ { Make the desired part of the virtual array accessible }
+ if (start_row < ptr^.cur_start_row) or
+ (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then
+ begin
+ if (not ptr^.b_s_open) then
+ ERREXIT(cinfo, JERR_VIRTUAL_BUG);
+ { Flush old buffer contents if necessary }
+ if (ptr^.dirty) then
+ begin
+ do_barray_io(cinfo, ptr, TRUE);
+ ptr^.dirty := FALSE;
+ end;
+ { Decide what part of virtual array to access.
+ Algorithm: if target address > current window, assume forward scan,
+ load starting at target address. If target address < current window,
+ assume backward scan, load so that target area is top of window.
+ Note that when switching from forward write to forward read, will have
+ start_row := 0, so the limiting case applies and we load from 0 anyway. }
+
+ if (start_row > ptr^.cur_start_row) then
+ begin
+ ptr^.cur_start_row := start_row;
+ end
+ else
+ begin
+ { use long arithmetic here to avoid overflow & unsigned problems }
+
+ ltemp := long(end_row) - long(ptr^.rows_in_mem);
+ if (ltemp < 0) then
+ ltemp := 0; { don't fall off front end of file }
+ ptr^.cur_start_row := JDIMENSION (ltemp);
+ end;
+ { Read in the selected part of the array.
+ During the initial write pass, we will do no actual read
+ because the selected part is all undefined. }
+
+ do_barray_io(cinfo, ptr, FALSE);
+ end;
+ { Ensure the accessed part of the array is defined; prezero if needed.
+ To improve locality of access, we only prezero the part of the array
+ that the caller is about to access, not the entire in-memory array. }
+
+ if (ptr^.first_undef_row < end_row) then
+ begin
+ if (ptr^.first_undef_row < start_row) then
+ begin
+ if (writable) then { writer skipped over a section of array }
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+ undef_row := start_row; { but reader is allowed to read ahead }
+ end
+ else
+ begin
+ undef_row := ptr^.first_undef_row;
+ end;
+ if (writable) then
+ ptr^.first_undef_row := end_row;
+ if (ptr^.pre_zero) then
+ begin
+ bytesperrow := size_t (ptr^.blocksperrow) * SIZEOF(JBLOCK);
+ Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer }
+ Dec(end_row, ptr^.cur_start_row);
+ while (undef_row < end_row) do
+ begin
+ jzero_far({FAR}pointer(ptr^.mem_buffer^[undef_row]), bytesperrow);
+ Inc(undef_row);
+ end;
+ end
+ else
+ begin
+ if (not writable) then { reader looking at undefined data }
+ ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS);
+ end;
+ end;
+ { Flag the buffer dirty if caller will write in it }
+ if (writable) then
+ ptr^.dirty := TRUE;
+ { Return address of proper part of the buffer }
+ access_virt_barray := JBLOCKARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]);
+end;
+
+
+{ Release all objects belonging to a specified pool. }
+
+{METHODDEF}
+procedure free_pool (cinfo : j_common_ptr; pool_id : int);
+var
+ mem : my_mem_ptr;
+ shdr_ptr : small_pool_ptr;
+ lhdr_ptr : large_pool_ptr;
+ space_freed : size_t;
+var
+ sptr : jvirt_sarray_ptr;
+ bptr : jvirt_barray_ptr;
+var
+ next_lhdr_ptr : large_pool_ptr;
+ next_shdr_ptr : small_pool_ptr;
+begin
+ mem := my_mem_ptr(cinfo^.mem);
+
+ if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then
+ ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check }
+
+{$ifdef MEM_STATS}
+ if (cinfo^.err^.trace_level > 1) then
+ print_mem_stats(cinfo, pool_id); { print pool's memory usage statistics }
+{$endif}
+
+ { If freeing IMAGE pool, close any virtual arrays first }
+ if (pool_id = JPOOL_IMAGE) then
+ begin
+ sptr := mem^.virt_sarray_list;
+ while (sptr <> NIL) do
+ begin
+ if (sptr^.b_s_open) then
+ begin { there may be no backing store }
+ sptr^.b_s_open := FALSE; { prevent recursive close if error }
+ sptr^.b_s_info.close_backing_store (cinfo, @sptr^.b_s_info);
+ end;
+ sptr := sptr^.next;
+ end;
+ mem^.virt_sarray_list := NIL;
+ bptr := mem^.virt_barray_list;
+ while (bptr <> NIL) do
+ begin
+ if (bptr^.b_s_open) then
+ begin { there may be no backing store }
+ bptr^.b_s_open := FALSE; { prevent recursive close if error }
+ bptr^.b_s_info.close_backing_store (cinfo, @bptr^.b_s_info);
+ end;
+ bptr := bptr^.next;
+ end;
+ mem^.virt_barray_list := NIL;
+ end;
+
+ { Release large objects }
+ lhdr_ptr := mem^.large_list[pool_id];
+ mem^.large_list[pool_id] := NIL;
+
+ while (lhdr_ptr <> NIL) do
+ begin
+ next_lhdr_ptr := lhdr_ptr^.hdr.next;
+ space_freed := lhdr_ptr^.hdr.bytes_used +
+ lhdr_ptr^.hdr.bytes_left +
+ SIZEOF(large_pool_hdr);
+ jpeg_free_large(cinfo, {FAR} pointer(lhdr_ptr), space_freed);
+ Dec(mem^.total_space_allocated, space_freed);
+ lhdr_ptr := next_lhdr_ptr;
+ end;
+
+ { Release small objects }
+ shdr_ptr := mem^.small_list[pool_id];
+ mem^.small_list[pool_id] := NIL;
+
+ while (shdr_ptr <> NIL) do
+ begin
+ next_shdr_ptr := shdr_ptr^.hdr.next;
+ space_freed := shdr_ptr^.hdr.bytes_used +
+ shdr_ptr^.hdr.bytes_left +
+ SIZEOF(small_pool_hdr);
+ jpeg_free_small(cinfo, pointer(shdr_ptr), space_freed);
+ Dec(mem^.total_space_allocated, space_freed);
+ shdr_ptr := next_shdr_ptr;
+ end;
+end;
+
+
+{ Close up shop entirely.
+ Note that this cannot be called unless cinfo^.mem is non-NIL. }
+
+{METHODDEF}
+procedure self_destruct (cinfo : j_common_ptr);
+var
+ pool : int;
+begin
+ { Close all backing store, release all memory.
+ Releasing pools in reverse order might help avoid fragmentation
+ with some (brain-damaged) malloc libraries. }
+
+ for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do
+ begin
+ free_pool(cinfo, pool);
+ end;
+
+ { Release the memory manager control block too. }
+ jpeg_free_small(cinfo, pointer(cinfo^.mem), SIZEOF(my_memory_mgr));
+ cinfo^.mem := NIL; { ensures I will be called only once }
+
+ jpeg_mem_term(cinfo); { system-dependent cleanup }
+end;
+
+
+{ Memory manager initialization.
+ When this is called, only the error manager pointer is valid in cinfo! }
+
+{GLOBAL}
+procedure jinit_memory_mgr (cinfo : j_common_ptr);
+var
+ mem : my_mem_ptr;
+ max_to_use : long;
+ pool : int;
+ test_mac : size_t;
+{$ifndef NO_GETENV}
+var
+ memenv : string;
+ code : integer;
+{$endif}
+begin
+ cinfo^.mem := NIL; { for safety if init fails }
+
+ { Check for configuration errors.
+ SIZEOF(ALIGN_TYPE) should be a power of 2; otherwise, it probably
+ doesn't reflect any real hardware alignment requirement.
+ The test is a little tricky: for X>0, X and X-1 have no one-bits
+ in common if and only if X is a power of 2, ie has only one one-bit.
+ Some compilers may give an "unreachable code" warning here; ignore it. }
+ if ((SIZEOF(ALIGN_TYPE) and (SIZEOF(ALIGN_TYPE)-1)) <> 0) then
+ ERREXIT(cinfo, JERR_BAD_ALIGN_TYPE);
+ { MAX_ALLOC_CHUNK must be representable as type size_t, and must be
+ a multiple of SIZEOF(ALIGN_TYPE).
+ Again, an "unreachable code" warning may be ignored here.
+ But a "constant too large" warning means you need to fix MAX_ALLOC_CHUNK. }
+
+ test_mac := size_t (MAX_ALLOC_CHUNK);
+ if (long (test_mac) <> MAX_ALLOC_CHUNK) or
+ ((MAX_ALLOC_CHUNK mod SIZEOF(ALIGN_TYPE)) <> 0) then
+ ERREXIT(cinfo, JERR_BAD_ALLOC_CHUNK);
+
+ max_to_use := jpeg_mem_init(cinfo); { system-dependent initialization }
+
+ { Attempt to allocate memory manager's control block }
+ mem := my_mem_ptr (jpeg_get_small(cinfo, SIZEOF(my_memory_mgr)));
+
+ if (mem = NIL) then
+ begin
+ jpeg_mem_term(cinfo); { system-dependent cleanup }
+ ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, 0);
+ end;
+
+ { OK, fill in the method pointers }
+ mem^.pub.alloc_small := alloc_small;
+ mem^.pub.alloc_large := alloc_large;
+ mem^.pub.alloc_sarray := alloc_sarray;
+ mem^.pub.alloc_barray := alloc_barray;
+ mem^.pub.request_virt_sarray := request_virt_sarray;
+ mem^.pub.request_virt_barray := request_virt_barray;
+ mem^.pub.realize_virt_arrays := realize_virt_arrays;
+ mem^.pub.access_virt_sarray := access_virt_sarray;
+ mem^.pub.access_virt_barray := access_virt_barray;
+ mem^.pub.free_pool := free_pool;
+ mem^.pub.self_destruct := self_destruct;
+
+ { Make MAX_ALLOC_CHUNK accessible to other modules }
+ mem^.pub.max_alloc_chunk := MAX_ALLOC_CHUNK;
+
+ { Initialize working state }
+ mem^.pub.max_memory_to_use := max_to_use;
+
+ for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do
+ begin
+ mem^.small_list[pool] := NIL;
+ mem^.large_list[pool] := NIL;
+ end;
+ mem^.virt_sarray_list := NIL;
+ mem^.virt_barray_list := NIL;
+
+ mem^.total_space_allocated := SIZEOF(my_memory_mgr);
+
+ { Declare ourselves open for business }
+ cinfo^.mem := @mem^.pub;
+
+ { Check for an environment variable JPEGMEM; if found, override the
+ default max_memory setting from jpeg_mem_init. Note that the
+ surrounding application may again override this value.
+ If your system doesn't support getenv(), define NO_GETENV to disable
+ this feature. }
+
+{$ifndef NO_GETENV}
+ memenv := getenv('JPEGMEM');
+ if (memenv <> '') then
+ begin
+ Val(memenv, max_to_use, code);
+ if (Code = 0) then
+ begin
+ max_to_use := max_to_use * long(1000);
+ mem^.pub.max_memory_to_use := max_to_use * long(1000);
+ end;
+ end;
+{$endif}
+
+end;
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjmemnobs.pas b/src/lib/vampimg/JpegLib/imjmemnobs.pas
--- /dev/null
@@ -0,0 +1,259 @@
+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). }
+
+const
+ MAX_ALLOC_CHUNK = long(1000000000);
+
+{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.
diff --git a/src/lib/vampimg/JpegLib/imjmorecfg.pas b/src/lib/vampimg/JpegLib/imjmorecfg.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/imjpeglib.pas b/src/lib/vampimg/JpegLib/imjpeglib.pas
--- /dev/null
@@ -0,0 +1,1300 @@
+unit imjpeglib;
+
+{ This file defines the application interface for the JPEG library.
+ Most applications using the library need only include this file,
+ and perhaps jerror.h if they want to know the exact error codes. }
+
+{ Source:jpeglib.h+jpegint.h; Copyright (C) 1991-1998, Thomas G. Lane. }
+
+
+interface
+
+{$I imjconfig.inc}
+
+{ First we include the configuration files that record how this
+ installation of the JPEG library is set up. jconfig.h can be
+ generated automatically for many systems. jmorecfg.h contains
+ manual configuration options that most people need not worry about. }
+
+uses
+ imjdeferr,
+ imjmorecfg; { seldom changed options }
+
+{ Version ID for the JPEG library.
+ Might be useful for tests like "#if JPEG_LIB_VERSION >= 60". }
+
+
+Const
+ JPEG_LIB_VERSION = 62; { Version 6b }
+
+
+{ These marker codes are exported since applications and data source modules
+ are likely to want to use them. }
+
+const
+ JPEG_RST0 = $D0; { RST0 marker code }
+ JPEG_EOI = $D9; { EOI marker code }
+ JPEG_APP0 = $E0; { APP0 marker code }
+ JPEG_COM = $FE; { COM marker code }
+
+
+{ Various constants determining the sizes of things.
+ All of these are specified by the JPEG standard, so don't change them
+ if you want to be compatible. }
+
+const
+ DCTSIZE = 8; { The basic DCT block is 8x8 samples }
+ DCTSIZE2 = 64; { DCTSIZE squared; # of elements in a block }
+ NUM_QUANT_TBLS = 4; { Quantization tables are numbered 0..3 }
+ NUM_HUFF_TBLS = 4; { Huffman tables are numbered 0..3 }
+ NUM_ARITH_TBLS = 16; { Arith-coding tables are numbered 0..15 }
+ MAX_COMPS_IN_SCAN = 4; { JPEG limit on # of components in one scan }
+ MAX_SAMP_FACTOR = 4; { JPEG limit on sampling factors }
+{ Unfortunately, some bozo at Adobe saw no reason to be bound by the standard;
+ the PostScript DCT filter can emit files with many more than 10 blocks/MCU.
+ If you happen to run across such a file, you can up D_MAX_BLOCKS_IN_MCU
+ to handle it. We even let you do this from the jconfig.h file. However,
+ we strongly discourage changing C_MAX_BLOCKS_IN_MCU; just because Adobe
+ sometimes emits noncompliant files doesn't mean you should too. }
+ C_MAX_BLOCKS_IN_MCU = 10; { compressor's limit on blocks per MCU }
+ D_MAX_BLOCKS_IN_MCU = 10; { decompressor's limit on blocks per MCU }
+
+
+{ Data structures for images (arrays of samples and of DCT coefficients).
+ On 80x86 machines, the image arrays are too big for near pointers,
+ but the pointer arrays can fit in near memory. }
+
+type
+{ for typecasting }
+ JSAMPLE_PTR = ^JSAMPLE;
+ JSAMPROW_PTR = ^JSAMPROW;
+ JBLOCKROW_PTR = ^JBLOCKROW;
+
+ 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. }
+
+ jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1;
+ JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW;
+ JSAMPARRAY = ^JSAMPROW_ARRAY; { ptr to some rows (a 2-D sample array) }
+
+ jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1;
+ JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY;
+ JSAMPIMAGE = ^JSAMP_ARRAY; { a 3-D sample array: top index is color }
+
+ JBLOCK = Array[0..DCTSIZE2-1] of JCOEF; { one block of coefficients }
+ JBLOCK_PTR = ^JBLOCK;
+
+ jTBlockRow = 0..(MaxInt div SIZEOF(JBLOCK))-1;
+ JBLOCK_ROWS = Array[jTBlockRow] of JBLOCK;
+ JBLOCKROW = ^JBLOCK_ROWS; {far} { pointer to one row of coefficient blocks }
+
+
+ jTBlockArray = 0..(MaxInt div SIZEOF(JBLOCKROW))-1;
+ JBLOCK_ARRAY = Array[jTBlockArray] of JBLOCKROW;
+ JBLOCKARRAY = ^JBLOCK_ARRAY; { a 2-D array of coefficient blocks }
+
+ jTBlockImage = 0..(MaxInt div SIZEOF(JBLOCKARRAY))-1;
+ JBLOCK_IMAGE = Array[jTBlockImage] of JBLOCKARRAY;
+ JBLOCKIMAGE = ^JBLOCK_IMAGE; { a 3-D array of coefficient blocks }
+
+ jTCoef = 0..(MaxInt div SIZEOF(JCOEF))-1;
+ JCOEF_ROW = Array[jTCoef] of JCOEF;
+ JCOEFPTR = ^JCOEF_ROW; {far} { useful in a couple of places }
+
+
+type
+ jTByte = 0..(MaxInt div SIZEOF(byte))-1;
+ JByteArray = Array[jTByte] of byte;
+ JBytePtr = ^JByteArray;
+type
+ byteptr = ^byte;
+
+{ Types for JPEG compression parameters and working tables. }
+
+
+{ DCT coefficient quantization tables. }
+
+type
+ JQUANT_TBL_PTR = ^JQUANT_TBL;
+ JQUANT_TBL = record
+ { This array gives the coefficient quantizers in natural array order
+ (not the zigzag order in which they are stored in a JPEG DQT marker).
+ CAUTION: IJG versions prior to v6a kept this array in zigzag order. }
+ quantval : Array[0..DCTSIZE2-1] of UINT16;
+ { quantization step for each coefficient }
+ { This field is used only during compression. It's initialized FALSE when
+ the table is created, and set TRUE when it's been output to the file.
+ You could suppress output of a table by setting this to TRUE.
+ (See jpeg_suppress_tables for an example.) }
+ sent_table : boolean; { TRUE when table has been output }
+ end;
+ JQUANT_TBL_FIELD = Array[0..(MaxInt div SizeOf(JQUANT_TBL))-1] of JQUANT_TBL;
+
+{ Huffman coding tables. }
+
+type
+ JHUFF_TBL_PTR = ^JHUFF_TBL;
+ JHUFF_TBL = record
+ { These two fields directly represent the contents of a JPEG DHT marker }
+ bits : Array[0..17-1] of UINT8; { bits[k] = # of symbols with codes of }
+ { length k bits; bits[0] is unused }
+ huffval : Array[0..256-1] of UINT8;
+ { The symbols, in order of incr code length }
+ { This field is used only during compression. It's initialized FALSE when
+ the table is created, and set TRUE when it's been output to the file.
+ You could suppress output of a table by setting this to TRUE.
+ (See jpeg_suppress_tables for an example.) }
+ sent_table : boolean; { TRUE when table has been output }
+ end;
+ JHUFF_TBL_FIELD = Array[0..(MaxInt div SizeOf(JHUFF_TBL))-1] of JHUFF_TBL;
+
+{ Declarations for both compression & decompression }
+
+type
+ J_BUF_MODE = ( { Operating modes for buffer controllers }
+ JBUF_PASS_THRU, { Plain stripwise operation }
+ { Remaining modes require a full-image buffer to have been created }
+ JBUF_SAVE_SOURCE, { Run source subobject only, save output }
+ JBUF_CRANK_DEST, { Run dest subobject only, using saved data }
+ JBUF_SAVE_AND_PASS { Run both subobjects, save output }
+ );
+
+{ Values of global_state field (jdapi.c has some dependencies on ordering!) }
+const
+ CSTATE_START = 100; { after create_compress }
+ CSTATE_SCANNING = 101; { start_compress done, write_scanlines OK }
+ CSTATE_RAW_OK = 102; { start_compress done, write_raw_data OK }
+ CSTATE_WRCOEFS = 103; { jpeg_write_coefficients done }
+ DSTATE_START = 200; { after create_decompress }
+ DSTATE_INHEADER = 201; { reading header markers, no SOS yet }
+ DSTATE_READY = 202; { found SOS, ready for start_decompress }
+ DSTATE_PRELOAD = 203; { reading multiscan file in start_decompress}
+ DSTATE_PRESCAN = 204; { performing dummy pass for 2-pass quant }
+ DSTATE_SCANNING = 205; { start_decompress done, read_scanlines OK }
+ DSTATE_RAW_OK = 206; { start_decompress done, read_raw_data OK }
+ DSTATE_BUFIMAGE = 207; { expecting jpeg_start_output }
+ DSTATE_BUFPOST = 208; { looking for SOS/EOI in jpeg_finish_output }
+ DSTATE_RDCOEFS = 209; { reading file in jpeg_read_coefficients }
+ DSTATE_STOPPING = 210; { looking for EOI in jpeg_finish_decompress }
+
+
+
+{ Basic info about one component (color channel). }
+
+type
+ jpeg_component_info_ptr = ^jpeg_component_info;
+ jpeg_component_info = record
+ { These values are fixed over the whole image. }
+ { For compression, they must be supplied by parameter setup; }
+ { for decompression, they are read from the SOF marker. }
+ component_id : int; { identifier for this component (0..255) }
+ component_index : int; { its index in SOF or cinfo^.comp_info[] }
+ h_samp_factor : int; { horizontal sampling factor (1..4) }
+ v_samp_factor : int; { vertical sampling factor (1..4) }
+ quant_tbl_no : int; { quantization table selector (0..3) }
+ { These values may vary between scans. }
+ { For compression, they must be supplied by parameter setup; }
+ { for decompression, they are read from the SOS marker. }
+ { The decompressor output side may not use these variables. }
+ dc_tbl_no : int; { DC entropy table selector (0..3) }
+ ac_tbl_no : int; { AC entropy table selector (0..3) }
+
+ { Remaining fields should be treated as private by applications. }
+
+ { These values are computed during compression or decompression startup: }
+ { Component's size in DCT blocks.
+ Any dummy blocks added to complete an MCU are not counted; therefore
+ these values do not depend on whether a scan is interleaved or not. }
+ width_in_blocks : JDIMENSION;
+ height_in_blocks : JDIMENSION;
+ { Size of a DCT block in samples. Always DCTSIZE for compression.
+ For decompression this is the size of the output from one DCT block,
+ reflecting any scaling we choose to apply during the IDCT step.
+ Values of 1,2,4,8 are likely to be supported. Note that different
+ components may receive different IDCT scalings. }
+
+ DCT_scaled_size : int;
+ { The downsampled dimensions are the component's actual, unpadded number
+ of samples at the main buffer (preprocessing/compression interface), thus
+ downsampled_width = ceil(image_width * Hi/Hmax)
+ and similarly for height. For decompression, IDCT scaling is included, so
+ downsampled_width = ceil(image_width * Hi/Hmax * DCT_scaled_size/DCTSIZE)}
+
+ downsampled_width : JDIMENSION; { actual width in samples }
+ downsampled_height : JDIMENSION; { actual height in samples }
+ { This flag is used only for decompression. In cases where some of the
+ components will be ignored (eg grayscale output from YCbCr image),
+ we can skip most computations for the unused components. }
+
+ component_needed : boolean; { do we need the value of this component? }
+
+ { These values are computed before starting a scan of the component. }
+ { The decompressor output side may not use these variables. }
+ MCU_width : int; { number of blocks per MCU, horizontally }
+ MCU_height : int; { number of blocks per MCU, vertically }
+ MCU_blocks : int; { MCU_width * MCU_height }
+ MCU_sample_width : int; { MCU width in samples, MCU_width*DCT_scaled_size }
+ last_col_width : int; { # of non-dummy blocks across in last MCU }
+ last_row_height : int; { # of non-dummy blocks down in last MCU }
+
+ { Saved quantization table for component; NIL if none yet saved.
+ See jdinput.c comments about the need for this information.
+ This field is currently used only for decompression. }
+
+ quant_table : JQUANT_TBL_PTR;
+
+ { Private per-component storage for DCT or IDCT subsystem. }
+ dct_table : pointer;
+ end; { record jpeg_component_info }
+
+ jTCinfo = 0..(MaxInt div SizeOf(jpeg_component_info))-1;
+ jpeg_component_info_array = array[jTCinfo] of jpeg_component_info;
+ jpeg_component_info_list_ptr = ^jpeg_component_info_array;
+
+
+{ The script for encoding a multiple-scan file is an array of these: }
+
+type
+ jpeg_scan_info_ptr = ^jpeg_scan_info;
+ jpeg_scan_info = record
+ comps_in_scan : int; { number of components encoded in this scan }
+ component_index : Array[0..MAX_COMPS_IN_SCAN-1] of int;
+ { their SOF/comp_info[] indexes }
+ Ss, Se : int; { progressive JPEG spectral selection parms }
+ Ah, Al : int; { progressive JPEG successive approx. parms }
+ end;
+
+{ The decompressor can save APPn and COM markers in a list of these: }
+
+type
+ jpeg_saved_marker_ptr = ^jpeg_marker_struct;
+ jpeg_marker_struct = record
+ next : jpeg_saved_marker_ptr; { next in list, or NULL }
+ marker : UINT8; { marker code: JPEG_COM, or JPEG_APP0+n }
+ original_length : uint; { # bytes of data in the file }
+ data_length : uint; { # bytes of data saved at data[] }
+ data : JOCTET_FIELD_PTR; { the data contained in the marker }
+ { the marker length word is not counted in data_length or original_length }
+ end;
+
+{ Known color spaces. }
+
+type
+ J_COLOR_SPACE = (
+ JCS_UNKNOWN, { error/unspecified }
+ JCS_GRAYSCALE, { monochrome }
+ JCS_RGB, { red/green/blue }
+ JCS_YCbCr, { Y/Cb/Cr (also known as YUV) }
+ JCS_CMYK, { C/M/Y/K }
+ JCS_YCCK { Y/Cb/Cr/K }
+ );
+
+{ DCT/IDCT algorithm options. }
+
+type
+ J_DCT_METHOD = (
+ JDCT_ISLOW, { slow but accurate integer algorithm }
+ JDCT_IFAST, { faster, less accurate integer method }
+ JDCT_FLOAT { floating-point: accurate, fast on fast HW }
+ );
+
+const
+ JDCT_DEFAULT = JDCT_ISLOW;
+ JDCT_FASTEST = JDCT_IFAST;
+
+{ Dithering options for decompression. }
+
+type
+ J_DITHER_MODE = (
+ JDITHER_NONE, { no dithering }
+ JDITHER_ORDERED, { simple ordered dither }
+ JDITHER_FS { Floyd-Steinberg error diffusion dither }
+ );
+
+
+const
+ JPOOL_PERMANENT = 0; { lasts until master record is destroyed }
+ JPOOL_IMAGE = 1; { lasts until done with image/datastream }
+ JPOOL_NUMPOOLS = 2;
+
+
+{ "Object" declarations for JPEG modules that may be supplied or called
+ directly by the surrounding application.
+ As with all objects in the JPEG library, these structs only define the
+ publicly visible methods and state variables of a module. Additional
+ private fields may exist after the public ones. }
+
+
+{ Error handler object }
+
+const
+ JMSG_LENGTH_MAX = 200; { recommended size of format_message buffer }
+ JMSG_STR_PARM_MAX = 80;
+
+const
+ TEMP_NAME_LENGTH = 64; { max length of a temporary file's name }
+type
+ TEMP_STRING = string[TEMP_NAME_LENGTH];
+
+{$ifdef USE_MSDOS_MEMMGR} { DOS-specific junk }
+type
+ XMSH = ushort; { type of extended-memory handles }
+ EMSH = ushort; { type of expanded-memory handles }
+
+ handle_union = record
+ case byte of
+ 0:(file_handle : short); { DOS file handle if it's a temp file }
+ 1:(xms_handle : XMSH); { handle if it's a chunk of XMS }
+ 2:(ems_handle : EMSH); { handle if it's a chunk of EMS }
+ end;
+{$endif} { USE_MSDOS_MEMMGR }
+
+type
+ jpeg_error_mgr_ptr = ^jpeg_error_mgr;
+ jpeg_memory_mgr_ptr = ^jpeg_memory_mgr;
+ jpeg_progress_mgr_ptr = ^jpeg_progress_mgr;
+
+
+{$ifdef common}
+{ Common fields between JPEG compression and decompression master structs. }
+ err : jpeg_error_mgr_ptr; { Error handler module }
+ mem : jpeg_memory_mgr_ptr; { Memory manager module }
+ progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none }
+ client_data : voidp; { Available for use by application }
+ is_decompressor : boolean; { so common code can tell which is which }
+ global_state : int; { for checking call sequence validity }
+{$endif}
+
+ j_common_ptr = ^jpeg_common_struct;
+ j_compress_ptr = ^jpeg_compress_struct;
+ j_decompress_ptr = ^jpeg_decompress_struct;
+
+ {$ifdef AM_MEMORY_MANAGER} { only jmemmgr.c defines these }
+
+{ 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. }
+
+
+ backing_store_ptr = ^backing_store_info;
+ backing_store_info = record
+ { Methods for reading/writing/closing this backing-store object }
+ read_backing_store : procedure (cinfo : j_common_ptr;
+ info : backing_store_ptr;
+ buffer_address : pointer; {far}
+ file_offset : long;
+ byte_count : long);
+ write_backing_store : procedure (cinfo : j_common_ptr;
+ info : backing_store_ptr;
+ buffer_address : pointer; {far}
+ file_offset : long;
+ byte_count : long);
+
+ close_backing_store : procedure (cinfo : j_common_ptr;
+ info : backing_store_ptr);
+
+ { Private fields for system-dependent backing-store management }
+ {$ifdef USE_MSDOS_MEMMGR}
+ { For the MS-DOS manager (jmemdos.c), we need: }
+ handle : handle_union; { reference to backing-store storage object }
+ temp_name : TEMP_STRING; { name if it's a file }
+ {$else}
+ { For a typical implementation with temp files, we need: }
+ temp_file : file; { stdio reference to temp file }
+ temp_name : TEMP_STRING; { name of temp file }
+ {$endif}
+ end;
+
+
+{ The control blocks for virtual arrays.
+ Note that these blocks are allocated in the "small" pool area.
+ System-dependent info for the associated backing store (if any) is hidden
+ inside the backing_store_info struct. }
+
+ jvirt_sarray_ptr = ^jvirt_sarray_control;
+ jvirt_sarray_control = record
+ mem_buffer : JSAMPARRAY; { => the in-memory buffer }
+ rows_in_array : JDIMENSION; { total virtual array height }
+ samplesperrow : JDIMENSION; { width of array (and of memory buffer) }
+ maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray }
+ rows_in_mem : JDIMENSION; { height of memory buffer }
+ rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer }
+ cur_start_row : JDIMENSION; { first logical row # in the buffer }
+ first_undef_row : JDIMENSION; { row # of first uninitialized row }
+ pre_zero : boolean; { pre-zero mode requested? }
+ dirty : boolean; { do current buffer contents need written? }
+ b_s_open : boolean; { is backing-store data valid? }
+ next : jvirt_sarray_ptr; { link to next virtual sarray control block }
+ b_s_info : backing_store_info; { System-dependent control info }
+ end;
+
+ jvirt_barray_ptr = ^jvirt_barray_control;
+ jvirt_barray_control = record
+ mem_buffer : JBLOCKARRAY; { => the in-memory buffer }
+ rows_in_array : JDIMENSION; { total virtual array height }
+ blocksperrow : JDIMENSION; { width of array (and of memory buffer) }
+ maxaccess : JDIMENSION; { max rows accessed by access_virt_barray }
+ rows_in_mem : JDIMENSION; { height of memory buffer }
+ rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer }
+ cur_start_row : JDIMENSION; { first logical row # in the buffer }
+ first_undef_row : JDIMENSION; { row # of first uninitialized row }
+ pre_zero : boolean; { pre-zero mode requested? }
+ dirty : boolean; { do current buffer contents need written? }
+ b_s_open : boolean; { is backing-store data valid? }
+ next : jvirt_barray_ptr; { link to next virtual barray control block }
+ b_s_info : backing_store_info; { System-dependent control info }
+ end;
+
+ {$endif} { AM_MEMORY_MANAGER }
+
+{ Declarations for compression modules }
+
+{ Master control module }
+ jpeg_comp_master_ptr = ^jpeg_comp_master;
+ jpeg_comp_master = record
+ prepare_for_pass : procedure(cinfo : j_compress_ptr);
+ pass_startup : procedure(cinfo : j_compress_ptr);
+ finish_pass : procedure(cinfo : j_compress_ptr);
+
+ { State variables made visible to other modules }
+ call_pass_startup : Boolean; { True if pass_startup must be called }
+ is_last_pass : Boolean; { True during last pass }
+ end;
+
+{ Main buffer control (downsampled-data buffer) }
+ jpeg_c_main_controller_ptr = ^jpeg_c_main_controller;
+ jpeg_c_main_controller = record
+ start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE);
+ process_data : procedure(cinfo : j_compress_ptr;
+ input_buf : JSAMPARRAY;
+ var in_row_ctr : JDIMENSION;
+ in_rows_avail : JDIMENSION);
+ end;
+
+{ Compression preprocessing (downsampling input buffer control) }
+ jpeg_c_prep_controller_ptr = ^jpeg_c_prep_controller;
+ jpeg_c_prep_controller = record
+ start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE);
+ pre_process_data : procedure(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);
+ end;
+
+{ Coefficient buffer control }
+ jpeg_c_coef_controller_ptr = ^jpeg_c_coef_controller;
+ jpeg_c_coef_controller = record
+ start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE);
+ compress_data : function(cinfo : j_compress_ptr;
+ input_buf : JSAMPIMAGE) : boolean;
+ end;
+
+{ Colorspace conversion }
+ jpeg_color_converter_ptr = ^jpeg_color_converter;
+ jpeg_color_converter = record
+ start_pass : procedure(cinfo : j_compress_ptr);
+ color_convert : procedure(cinfo : j_compress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPIMAGE;
+ output_row : JDIMENSION;
+ num_rows : int);
+ end;
+
+{ Downsampling }
+ jpeg_downsampler_ptr = ^jpeg_downsampler;
+ jpeg_downsampler = record
+ start_pass : procedure(cinfo : j_compress_ptr);
+ downsample : procedure(cinfo : j_compress_ptr;
+ input_buf : JSAMPIMAGE;
+ in_row_index : JDIMENSION;
+ output_buf : JSAMPIMAGE;
+ out_row_group_index: JDIMENSION);
+ need_context_rows : Boolean; { TRUE if need rows above & below }
+ end;
+
+{ Forward DCT (also controls coefficient quantization) }
+ jpeg_forward_dct_ptr = ^jpeg_forward_dct;
+ jpeg_forward_dct = record
+ start_pass : procedure(cinfo : j_compress_ptr);
+ { perhaps this should be an array??? }
+ forward_DCT : procedure(cinfo : j_compress_ptr;
+ compptr : jpeg_component_info_ptr;
+ sample_data : JSAMPARRAY;
+ coef_blocks : JBLOCKROW;
+ start_row : JDIMENSION;
+ start_col : JDIMENSION;
+ num_blocks : JDIMENSION);
+ end;
+
+{ Entropy encoding }
+
+ jpeg_entropy_encoder_ptr = ^jpeg_entropy_encoder;
+ jpeg_entropy_encoder = record
+ start_pass : procedure(cinfo : j_compress_ptr; gather_statistics : boolean);
+ encode_mcu : function(cinfo : j_compress_ptr;
+ const MCU_data: array of JBLOCKROW) : boolean;
+ finish_pass : procedure(cinfo : j_compress_ptr);
+ end;
+
+{ Marker writing }
+ jpeg_marker_writer_ptr = ^jpeg_marker_writer;
+ jpeg_marker_writer = record
+ write_file_header : procedure(cinfo : j_compress_ptr);
+ write_frame_header : procedure(cinfo : j_compress_ptr);
+ write_scan_header : procedure(cinfo : j_compress_ptr);
+ write_file_trailer : procedure(cinfo : j_compress_ptr);
+ write_tables_only : procedure(cinfo : j_compress_ptr);
+ { These routines are exported to allow insertion of extra markers }
+ { Probably only COM and APPn markers should be written this way }
+ write_marker_header : procedure (cinfo : j_compress_ptr;
+ marker : int;
+ datalen : uint);
+ write_marker_byte : procedure (cinfo : j_compress_ptr; val : int);
+ end;
+
+{ Declarations for decompression modules }
+
+{ Master control module }
+ jpeg_decomp_master_ptr = ^jpeg_decomp_master;
+ jpeg_decomp_master = record
+ prepare_for_output_pass : procedure( cinfo : j_decompress_ptr);
+ finish_output_pass : procedure(cinfo : j_decompress_ptr);
+
+ { State variables made visible to other modules }
+ is_dummy_pass : Boolean; { True during 1st pass for 2-pass quant }
+ end;
+
+{ Input control module }
+ jpeg_input_controller_ptr = ^jpeg_input_controller;
+ jpeg_input_controller = record
+ consume_input : function (cinfo : j_decompress_ptr) : int;
+ reset_input_controller : procedure(cinfo : j_decompress_ptr);
+ start_input_pass : procedure(cinfo : j_decompress_ptr);
+ finish_input_pass : procedure(cinfo : j_decompress_ptr);
+
+ { State variables made visible to other modules }
+ has_multiple_scans : Boolean; { True if file has multiple scans }
+ eoi_reached : Boolean; { True when EOI has been consumed }
+ end;
+
+{ Main buffer control (downsampled-data buffer) }
+
+ jpeg_d_main_controller_ptr = ^jpeg_d_main_controller;
+ jpeg_d_main_controller = record
+ start_pass : procedure(cinfo : j_decompress_ptr; pass_mode : J_BUF_MODE);
+ process_data : procedure(cinfo : j_decompress_ptr;
+ output_buf : JSAMPARRAY;
+ var out_row_ctr : JDIMENSION;
+ out_rows_avail : JDIMENSION);
+ end;
+
+{ Coefficient buffer control }
+ jvirt_barray_tbl = array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr;
+ jvirt_barray_tbl_ptr = ^jvirt_barray_tbl;
+ jpeg_d_coef_controller_ptr = ^jpeg_d_coef_controller;
+ jpeg_d_coef_controller = record
+ start_input_pass : procedure(cinfo : j_decompress_ptr);
+ consume_data : function (cinfo : j_decompress_ptr) : int;
+ start_output_pass : procedure(cinfo : j_decompress_ptr);
+ decompress_data : function (cinfo : j_decompress_ptr;
+ output_buf : JSAMPIMAGE) : int;
+ { Pointer to array of coefficient virtual arrays, or NIL if none }
+ coef_arrays : jvirt_barray_tbl_ptr;
+ end;
+
+{ Decompression postprocessing (color quantization buffer control) }
+ jpeg_d_post_controller_ptr = ^jpeg_d_post_controller;
+ jpeg_d_post_controller = record
+ start_pass : procedure(cinfo : j_decompress_ptr;
+ pass_mode : J_BUF_MODE);
+ post_process_data : procedure(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);
+ end;
+
+
+{ Routine signature for application-supplied marker processing methods.
+ Need not pass marker code since it is stored in cinfo^.unread_marker. }
+
+ jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : boolean;
+
+{ Marker reading & parsing }
+ jpeg_marker_reader_ptr = ^jpeg_marker_reader;
+ jpeg_marker_reader = record
+ reset_marker_reader : procedure(cinfo : j_decompress_ptr);
+ { Read markers until SOS or EOI.
+ Returns same codes as are defined for jpeg_consume_input:
+ JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. }
+
+ read_markers : function (cinfo : j_decompress_ptr) : int;
+ { Read a restart marker --- exported for use by entropy decoder only }
+ read_restart_marker : jpeg_marker_parser_method;
+
+ { State of marker reader --- nominally internal, but applications
+ supplying COM or APPn handlers might like to know the state. }
+
+ saw_SOI : boolean; { found SOI? }
+ saw_SOF : boolean; { found SOF? }
+ next_restart_num : int; { next restart number expected (0-7) }
+ discarded_bytes : uint; { # of bytes skipped looking for a marker }
+ end;
+
+{ Entropy decoding }
+ jpeg_entropy_decoder_ptr = ^jpeg_entropy_decoder;
+ jpeg_entropy_decoder = record
+ start_pass : procedure(cinfo : j_decompress_ptr);
+ decode_mcu : function(cinfo : j_decompress_ptr;
+ var MCU_data : array of JBLOCKROW) : boolean;
+ { This is here to share code between baseline and progressive decoders; }
+ { other modules probably should not use it }
+ insufficient_data : BOOLEAN; { set TRUE after emitting warning }
+ end;
+
+{ Inverse DCT (also performs dequantization) }
+ inverse_DCT_method_ptr = procedure(cinfo : j_decompress_ptr;
+ compptr : jpeg_component_info_ptr;
+ coef_block : JCOEFPTR;
+ output_buf : JSAMPARRAY; output_col : JDIMENSION);
+
+ jpeg_inverse_dct_ptr = ^jpeg_inverse_dct;
+ jpeg_inverse_dct = record
+ start_pass : procedure(cinfo : j_decompress_ptr);
+ { It is useful to allow each component to have a separate IDCT method. }
+ inverse_DCT : Array[0..MAX_COMPONENTS-1] of inverse_DCT_method_ptr;
+ end;
+
+{ Upsampling (note that upsampler must also call color converter) }
+ jpeg_upsampler_ptr = ^jpeg_upsampler;
+ jpeg_upsampler = record
+ start_pass : procedure(cinfo : j_decompress_ptr);
+ upsample : procedure(cinfo : j_decompress_ptr;
+ input_buf : JSAMPIMAGE;
+ var in_row_group_ctr : JDIMENSION; { array of }
+ in_row_groups_avail : JDIMENSION;
+ output_buf : JSAMPARRAY;
+ var out_row_ctr : JDIMENSION;
+ out_rows_avail : JDIMENSION);
+
+ need_context_rows : boolean; { TRUE if need rows above & below }
+ end;
+
+{ Colorspace conversion }
+ jpeg_color_deconverter_ptr = ^jpeg_color_deconverter;
+ jpeg_color_deconverter = record
+ start_pass : procedure(cinfo: j_decompress_ptr);
+ color_convert : procedure(cinfo : j_decompress_ptr;
+ input_buf : JSAMPIMAGE;
+ input_row : JDIMENSION;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+ end;
+
+{ Color quantization or color precision reduction }
+ jpeg_color_quantizer_ptr = ^jpeg_color_quantizer;
+ jpeg_color_quantizer = record
+ start_pass : procedure(cinfo : j_decompress_ptr; is_pre_scan : boolean);
+ color_quantize : procedure(cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+
+ finish_pass : procedure(cinfo : j_decompress_ptr);
+ new_color_map : procedure(cinfo : j_decompress_ptr);
+ end;
+
+ {int8array = Array[0..8-1] of int;}
+ int8array = Array[0..8-1] of longint; { for TP FormatStr }
+
+ jpeg_error_mgr = record
+ { Error exit handler: does not return to caller }
+ error_exit : procedure (cinfo : j_common_ptr);
+ { Conditionally emit a trace or warning message }
+ emit_message : procedure (cinfo : j_common_ptr; msg_level : int);
+ { Routine that actually outputs a trace or error message }
+ output_message : procedure (cinfo : j_common_ptr);
+ { Format a message string for the most recent JPEG error or message }
+ format_message : procedure (cinfo : j_common_ptr; var buffer : string);
+
+ { Reset error state variables at start of a new image }
+ reset_error_mgr : procedure (cinfo : j_common_ptr);
+
+ { The message ID code and any parameters are saved here.
+ A message can have one string parameter or up to 8 int parameters. }
+
+ msg_code : int;
+
+ msg_parm : record
+ case byte of
+ 0:(i : int8array);
+ 1:(s : string[JMSG_STR_PARM_MAX]);
+ end;
+
+ { Standard state variables for error facility }
+
+ trace_level : int; { max msg_level that will be displayed }
+
+ { For recoverable corrupt-data errors, we emit a warning message,
+ but keep going unless emit_message chooses to abort. emit_message
+ should count warnings in num_warnings. The surrounding application
+ can check for bad data by seeing if num_warnings is nonzero at the
+ end of processing. }
+
+ num_warnings : long; { number of corrupt-data warnings }
+
+ { These fields point to the table(s) of error message strings.
+ An application can change the table pointer to switch to a different
+ message list (typically, to change the language in which errors are
+ reported). Some applications may wish to add additional error codes
+ that will be handled by the JPEG library error mechanism; the second
+ table pointer is used for this purpose.
+
+ First table includes all errors generated by JPEG library itself.
+ Error code 0 is reserved for a "no such error string" message. }
+
+ {const char * const * jpeg_message_table; }
+ jpeg_message_table : ^msg_table; { Library errors }
+
+ last_jpeg_message : J_MESSAGE_CODE;
+ { Table contains strings 0..last_jpeg_message }
+ { Second table can be added by application (see cjpeg/djpeg for example).
+ It contains strings numbered first_addon_message..last_addon_message. }
+
+ {const char * const * addon_message_table; }
+ addon_message_table : ^msg_table; { Non-library errors }
+
+ first_addon_message : J_MESSAGE_CODE; { code for first string in addon table }
+ last_addon_message : J_MESSAGE_CODE; { code for last string in addon table }
+ end;
+
+
+{ Progress monitor object }
+
+ jpeg_progress_mgr = record
+ progress_monitor : procedure(cinfo : j_common_ptr);
+
+ pass_counter : long; { work units completed in this pass }
+ pass_limit : long; { total number of work units in this pass }
+ completed_passes : int; { passes completed so far }
+ total_passes : int; { total number of passes expected }
+ end;
+
+
+{ Data destination object for compression }
+ jpeg_destination_mgr_ptr = ^jpeg_destination_mgr;
+ jpeg_destination_mgr = record
+ next_output_byte : JOCTETptr; { => next byte to write in buffer }
+ free_in_buffer : size_t; { # of byte spaces remaining in buffer }
+
+ init_destination : procedure (cinfo : j_compress_ptr);
+ empty_output_buffer : function (cinfo : j_compress_ptr) : boolean;
+ term_destination : procedure (cinfo : j_compress_ptr);
+ end;
+
+
+{ Data source object for decompression }
+
+ jpeg_source_mgr_ptr = ^jpeg_source_mgr;
+ jpeg_source_mgr = record
+ {const JOCTET * next_input_byte;}
+ next_input_byte : JOCTETptr; { => next byte to read from buffer }
+ bytes_in_buffer : size_t; { # of bytes remaining in buffer }
+
+ init_source : procedure (cinfo : j_decompress_ptr);
+ fill_input_buffer : function (cinfo : j_decompress_ptr) : boolean;
+ skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : long);
+ resync_to_restart : function (cinfo : j_decompress_ptr;
+ desired : int) : boolean;
+ term_source : procedure (cinfo : j_decompress_ptr);
+ end;
+
+
+{ Memory manager object.
+ Allocates "small" objects (a few K total), "large" objects (tens of K),
+ and "really big" objects (virtual arrays with backing store if needed).
+ The memory manager does not allow individual objects to be freed; rather,
+ each created object is assigned to a pool, and whole pools can be freed
+ at once. This is faster and more convenient than remembering exactly what
+ to free, especially where malloc()/free() are not too speedy.
+ NB: alloc routines never return NIL. They exit to error_exit if not
+ successful. }
+
+
+ jpeg_memory_mgr = record
+ { Method pointers }
+ alloc_small : function (cinfo : j_common_ptr; pool_id : int;
+ sizeofobject : size_t) : pointer;
+ alloc_large : function (cinfo : j_common_ptr; pool_id : int;
+ sizeofobject : size_t) : pointer; {far}
+ alloc_sarray : function (cinfo : j_common_ptr; pool_id : int;
+ samplesperrow : JDIMENSION;
+ numrows : JDIMENSION) : JSAMPARRAY;
+
+ alloc_barray : function (cinfo : j_common_ptr; pool_id : int;
+ blocksperrow : JDIMENSION;
+ numrows : JDIMENSION) : JBLOCKARRAY;
+
+ request_virt_sarray : function(cinfo : j_common_ptr;
+ pool_id : int;
+ pre_zero : boolean;
+ samplesperrow : JDIMENSION;
+ numrows : JDIMENSION;
+ maxaccess : JDIMENSION) : jvirt_sarray_ptr;
+
+ request_virt_barray : function(cinfo : j_common_ptr;
+ pool_id : int;
+ pre_zero : boolean;
+ blocksperrow : JDIMENSION;
+ numrows : JDIMENSION;
+ maxaccess : JDIMENSION) : jvirt_barray_ptr;
+
+ realize_virt_arrays : procedure (cinfo : j_common_ptr);
+
+ access_virt_sarray : function (cinfo : j_common_ptr;
+ ptr : jvirt_sarray_ptr;
+ start_row : JDIMENSION;
+ num_rows : JDIMENSION;
+ writable : boolean) : JSAMPARRAY;
+
+ access_virt_barray : function (cinfo : j_common_ptr;
+ ptr : jvirt_barray_ptr;
+ start_row : JDIMENSION;
+ num_rows : JDIMENSION;
+ writable : boolean) : JBLOCKARRAY;
+
+ free_pool : procedure (cinfo : j_common_ptr; pool_id : int);
+ self_destruct : procedure (cinfo : j_common_ptr);
+
+ { Limit on memory allocation for this JPEG object. (Note that this is
+ merely advisory, not a guaranteed maximum; it only affects the space
+ used for virtual-array buffers.) May be changed by outer application
+ after creating the JPEG object. }
+ max_memory_to_use : long;
+
+ { Maximum allocation request accepted by alloc_large. }
+ max_alloc_chunk : long;
+ end;
+
+{ Routines that are to be used by both halves of the library are declared
+ to receive a pointer to this structure. There are no actual instances of
+ jpeg_common_struct, only of jpeg_compress_struct and jpeg_decompress_struct.}
+ jpeg_common_struct = record
+ { Fields common to both master struct types }
+ err : jpeg_error_mgr_ptr; { Error handler module }
+ mem : jpeg_memory_mgr_ptr; { Memory manager module }
+ progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none }
+ client_data : voidp; { Available for use by application }
+ is_decompressor : boolean; { so common code can tell which is which }
+ global_state : int; { for checking call sequence validity }
+
+ { Additional fields follow in an actual jpeg_compress_struct or
+ jpeg_decompress_struct. All three structs must agree on these
+ initial fields! (This would be a lot cleaner in C++.) }
+ end;
+
+
+{ Master record for a compression instance }
+
+ jpeg_compress_struct = record
+ { Fields shared with jpeg_decompress_struct }
+ err : jpeg_error_mgr_ptr; { Error handler module }
+ mem : jpeg_memory_mgr_ptr; { Memory manager module }
+ progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none }
+ client_data : voidp; { Available for use by application }
+ is_decompressor : boolean; { so common code can tell which is which }
+ global_state : int; { for checking call sequence validity }
+
+ { Destination for compressed data }
+ dest : jpeg_destination_mgr_ptr;
+
+ { Description of source image --- these fields must be filled in by
+ outer application before starting compression. in_color_space must
+ be correct before you can even call jpeg_set_defaults(). }
+
+
+ image_width : JDIMENSION; { input image width }
+ image_height : JDIMENSION; { input image height }
+ input_components : int; { # of color components in input image }
+ in_color_space : J_COLOR_SPACE; { colorspace of input image }
+
+ input_gamma : double; { image gamma of input image }
+
+ { Compression parameters --- these fields must be set before calling
+ jpeg_start_compress(). We recommend calling jpeg_set_defaults() to
+ initialize everything to reasonable defaults, then changing anything
+ the application specifically wants to change. That way you won't get
+ burnt when new parameters are added. Also note that there are several
+ helper routines to simplify changing parameters. }
+
+ data_precision : int; { bits of precision in image data }
+
+ num_components : int; { # of color components in JPEG image }
+ jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image }
+
+ comp_info : jpeg_component_info_list_ptr;
+ { comp_info^[i] describes component that appears i'th in SOF }
+
+ quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR;
+ { ptrs to coefficient quantization tables, or NIL if not defined }
+
+ dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR;
+ ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR;
+ { ptrs to Huffman coding tables, or NIL if not defined }
+
+ arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
+ arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
+ arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }
+
+ num_scans : int; { # of entries in scan_info array }
+ scan_info : jpeg_scan_info_ptr; { script for multi-scan file, or NIL }
+ { The default value of scan_info is NIL, which causes a single-scan
+ sequential JPEG file to be emitted. To create a multi-scan file,
+ set num_scans and scan_info to point to an array of scan definitions. }
+
+ raw_data_in : boolean; { TRUE=caller supplies downsampled data }
+ arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman }
+ optimize_coding : boolean; { TRUE=optimize entropy encoding parms }
+ CCIR601_sampling : boolean; { TRUE=first samples are cosited }
+ smoothing_factor : int; { 1..100, or 0 for no input smoothing }
+ dct_method : J_DCT_METHOD; { DCT algorithm selector }
+
+ { The restart interval can be specified in absolute MCUs by setting
+ restart_interval, or in MCU rows by setting restart_in_rows
+ (in which case the correct restart_interval will be figured
+ for each scan). }
+
+ restart_interval : uint; { MCUs per restart, or 0 for no restart }
+ restart_in_rows : int; { if > 0, MCU rows per restart interval }
+
+ { Parameters controlling emission of special markers. }
+
+ write_JFIF_header : boolean; { should a JFIF marker be written? }
+ JFIF_major_version : UINT8; { What to write for the JFIF version number }
+ JFIF_minor_version : UINT8;
+ { These three values are not used by the JPEG code, merely copied }
+ { into the JFIF APP0 marker. density_unit can be 0 for unknown, }
+ { 1 for dots/inch, or 2 for dots/cm. Note that the pixel aspect }
+ { ratio is defined by X_density/Y_density even when density_unit=0. }
+ density_unit : UINT8; { JFIF code for pixel size units }
+ X_density : UINT16; { Horizontal pixel density }
+ Y_density : UINT16; { Vertical pixel density }
+ write_Adobe_marker : boolean; { should an Adobe marker be written? }
+
+ { State variable: index of next scanline to be written to
+ jpeg_write_scanlines(). Application may use this to control its
+ processing loop, e.g., "while (next_scanline < image_height)". }
+
+ next_scanline : JDIMENSION; { 0 .. image_height-1 }
+
+ { Remaining fields are known throughout compressor, but generally
+ should not be touched by a surrounding application. }
+
+ { These fields are computed during compression startup }
+ progressive_mode : boolean; { TRUE if scan script uses progressive mode }
+ max_h_samp_factor : int; { largest h_samp_factor }
+ max_v_samp_factor : int; { largest v_samp_factor }
+
+ total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr }
+ { The coefficient controller receives data in units of MCU rows as defined
+ for fully interleaved scans (whether the JPEG file is interleaved or not).
+ There are v_samp_factor * DCTSIZE sample rows of each component in an
+ "iMCU" (interleaved MCU) row. }
+
+ { These fields are valid during any one scan.
+ They describe the components and MCUs actually appearing in the scan. }
+
+ comps_in_scan : int; { # of JPEG components in this scan }
+ cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr;
+ { cur_comp_info[i]^ describes component that appears i'th in SOS }
+
+ MCUs_per_row : JDIMENSION; { # of MCUs across the image }
+ MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image }
+
+ blocks_in_MCU : int; { # of DCT blocks per MCU }
+ MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of int;
+ { MCU_membership[i] is index in cur_comp_info of component owning }
+ { i'th block in an MCU }
+
+ Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan }
+
+ { Links to compression subobjects (methods and private variables of modules) }
+ master : jpeg_comp_master_ptr;
+ main : jpeg_c_main_controller_ptr;
+ prep : jpeg_c_prep_controller_ptr;
+ coef : jpeg_c_coef_controller_ptr;
+ marker : jpeg_marker_writer_ptr;
+ cconvert : jpeg_color_converter_ptr;
+ downsample : jpeg_downsampler_ptr;
+ fdct : jpeg_forward_dct_ptr;
+ entropy : jpeg_entropy_encoder_ptr;
+ script_space : jpeg_scan_info_ptr; { workspace for jpeg_simple_progression }
+ script_space_size : int;
+ end;
+
+
+{ Master record for a decompression instance }
+
+ coef_bits_field = Array[0..DCTSIZE2-1] of int;
+ coef_bits_ptr = ^coef_bits_field;
+ coef_bits_ptrfield = Array[0..MAX_COMPS_IN_SCAN-1] of coef_bits_field;
+ coef_bits_ptrrow = ^coef_bits_ptrfield;
+
+ range_limit_table = array[-(MAXJSAMPLE+1)..4*(MAXJSAMPLE+1)
+ + CENTERJSAMPLE -1] of JSAMPLE;
+ range_limit_table_ptr = ^range_limit_table;
+
+ jpeg_decompress_struct = record
+ { Fields shared with jpeg_compress_struct }
+ err : jpeg_error_mgr_ptr; { Error handler module }
+ mem : jpeg_memory_mgr_ptr; { Memory manager module }
+ progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none }
+ client_data : voidp; { Available for use by application }
+ is_decompressor : boolean; { so common code can tell which is which }
+ global_state : int; { for checking call sequence validity }
+
+ { Source of compressed data }
+ src : jpeg_source_mgr_ptr;
+
+ { Basic description of image --- filled in by jpeg_read_header(). }
+ { Application may inspect these values to decide how to process image. }
+
+ image_width : JDIMENSION; { nominal image width (from SOF marker) }
+ image_height : JDIMENSION; { nominal image height }
+ num_components : int; { # of color components in JPEG image }
+ jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image }
+
+ { Decompression processing parameters --- these fields must be set before
+ calling jpeg_start_decompress(). Note that jpeg_read_header()
+ initializes them to default values. }
+
+ out_color_space : J_COLOR_SPACE; { colorspace for output }
+
+ scale_num, scale_denom : uint ; { fraction by which to scale image }
+
+ output_gamma : double; { image gamma wanted in output }
+
+ buffered_image : boolean; { TRUE=multiple output passes }
+ raw_data_out : boolean; { TRUE=downsampled data wanted }
+
+ dct_method : J_DCT_METHOD; { IDCT algorithm selector }
+ do_fancy_upsampling : boolean; { TRUE=apply fancy upsampling }
+ do_block_smoothing : boolean; { TRUE=apply interblock smoothing }
+
+ quantize_colors : boolean; { TRUE=colormapped output wanted }
+ { the following are ignored if not quantize_colors: }
+ dither_mode : J_DITHER_MODE; { type of color dithering to use }
+ two_pass_quantize : boolean; { TRUE=use two-pass color quantization }
+ desired_number_of_colors : int; { max # colors to use in created colormap }
+ { these are significant only in buffered-image mode: }
+ enable_1pass_quant : boolean; { enable future use of 1-pass quantizer }
+ enable_external_quant : boolean; { enable future use of external colormap }
+ enable_2pass_quant : boolean; { enable future use of 2-pass quantizer }
+
+ { Description of actual output image that will be returned to application.
+ These fields are computed by jpeg_start_decompress().
+ You can also use jpeg_calc_output_dimensions() to determine these values
+ in advance of calling jpeg_start_decompress(). }
+
+ output_width : JDIMENSION; { scaled image width }
+ output_height: JDIMENSION; { scaled image height }
+ out_color_components : int; { # of color components in out_color_space }
+ output_components : int; { # of color components returned }
+ { output_components is 1 (a colormap index) when quantizing colors;
+ otherwise it equals out_color_components. }
+
+ rec_outbuf_height : int; { min recommended height of scanline buffer }
+ { If the buffer passed to jpeg_read_scanlines() is less than this many
+ rows high, space and time will be wasted due to unnecessary data
+ copying. Usually rec_outbuf_height will be 1 or 2, at most 4. }
+
+ { When quantizing colors, the output colormap is described by these
+ fields. The application can supply a colormap by setting colormap
+ non-NIL before calling jpeg_start_decompress; otherwise a colormap
+ is created during jpeg_start_decompress or jpeg_start_output. The map
+ has out_color_components rows and actual_number_of_colors columns. }
+
+ actual_number_of_colors : int; { number of entries in use }
+ colormap : JSAMPARRAY; { The color map as a 2-D pixel array }
+
+ { State variables: these variables indicate the progress of decompression.
+ The application may examine these but must not modify them. }
+
+ { Row index of next scanline to be read from jpeg_read_scanlines().
+ Application may use this to control its processing loop, e.g.,
+ "while (output_scanline < output_height)". }
+
+ output_scanline : JDIMENSION; { 0 .. output_height-1 }
+
+ { Current input scan number and number of iMCU rows completed in scan.
+ These indicate the progress of the decompressor input side. }
+
+ input_scan_number : int; { Number of SOS markers seen so far }
+ input_iMCU_row : JDIMENSION; { Number of iMCU rows completed }
+
+ { The "output scan number" is the notional scan being displayed by the
+ output side. The decompressor will not allow output scan/row number
+ to get ahead of input scan/row, but it can fall arbitrarily far behind.}
+
+ output_scan_number : int; { Nominal scan number being displayed }
+ output_iMCU_row : int; { Number of iMCU rows read }
+
+ { Current progression status. coef_bits[c][i] indicates the precision
+ with which component c's DCT coefficient i (in zigzag order) is known.
+ It is -1 when no data has yet been received, otherwise it is the point
+ transform (shift) value for the most recent scan of the coefficient
+ (thus, 0 at completion of the progression).
+ This pointer is NIL when reading a non-progressive file. }
+
+ coef_bits : coef_bits_ptrrow;
+ { -1 or current Al value for each coef }
+
+ { Internal JPEG parameters --- the application usually need not look at
+ these fields. Note that the decompressor output side may not use
+ any parameters that can change between scans. }
+
+ { Quantization and Huffman tables are carried forward across input
+ datastreams when processing abbreviated JPEG datastreams. }
+
+ quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR;
+ { ptrs to coefficient quantization tables, or NIL if not defined }
+
+ dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR;
+ ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR;
+ { ptrs to Huffman coding tables, or NIL if not defined }
+
+ { These parameters are never carried across datastreams, since they
+ are given in SOF/SOS markers or defined to be reset by SOI. }
+
+ data_precision : int; { bits of precision in image data }
+
+ comp_info : jpeg_component_info_list_ptr;
+ { comp_info^[i] describes component that appears i'th in SOF }
+
+ progressive_mode : boolean; { TRUE if SOFn specifies progressive mode }
+ arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman }
+
+ arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
+ arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
+ arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }
+
+ restart_interval : uint; { MCUs per restart interval, or 0 for no restart }
+
+ { These fields record data obtained from optional markers recognized by
+ the JPEG library. }
+
+ saw_JFIF_marker : boolean; { TRUE iff a JFIF APP0 marker was found }
+ { Data copied from JFIF marker; only valid if saw_JFIF_marker is TRUE: }
+ JFIF_major_version : UINT8; { JFIF version number }
+ JFIF_minor_version : UINT8;
+ density_unit : UINT8; { JFIF code for pixel size units }
+ X_density : UINT16; { Horizontal pixel density }
+ Y_density : UINT16; { Vertical pixel density }
+ saw_Adobe_marker : boolean; { TRUE iff an Adobe APP14 marker was found }
+ Adobe_transform : UINT8; { Color transform code from Adobe marker }
+
+ CCIR601_sampling : boolean; { TRUE=first samples are cosited }
+
+ { Aside from the specific data retained from APPn markers known to the
+ library, the uninterpreted contents of any or all APPn and COM markers
+ can be saved in a list for examination by the application. }
+
+ marker_list : jpeg_saved_marker_ptr; { Head of list of saved markers }
+
+ { Remaining fields are known throughout decompressor, but generally
+ should not be touched by a surrounding application. }
+
+
+ { These fields are computed during decompression startup }
+
+ max_h_samp_factor : int; { largest h_samp_factor }
+ max_v_samp_factor : int; { largest v_samp_factor }
+
+ min_DCT_scaled_size : int; { smallest DCT_scaled_size of any component }
+
+ total_iMCU_rows : JDIMENSION; { # of iMCU rows in image }
+ { The coefficient controller's input and output progress is measured in
+ units of "iMCU" (interleaved MCU) rows. These are the same as MCU rows
+ in fully interleaved JPEG scans, but are used whether the scan is
+ interleaved or not. We define an iMCU row as v_samp_factor DCT block
+ rows of each component. Therefore, the IDCT output contains
+ v_samp_factor*DCT_scaled_size sample rows of a component per iMCU row.}
+
+ sample_range_limit : range_limit_table_ptr; { table for fast range-limiting }
+
+
+ { These fields are valid during any one scan.
+ They describe the components and MCUs actually appearing in the scan.
+ Note that the decompressor output side must not use these fields. }
+
+ comps_in_scan : int; { # of JPEG components in this scan }
+ cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr;
+ { cur_comp_info[i]^ describes component that appears i'th in SOS }
+
+ MCUs_per_row : JDIMENSION; { # of MCUs across the image }
+ MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image }
+
+ blocks_in_MCU : JDIMENSION; { # of DCT blocks per MCU }
+ MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of int;
+ { MCU_membership[i] is index in cur_comp_info of component owning }
+ { i'th block in an MCU }
+
+ Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan }
+
+ { This field is shared between entropy decoder and marker parser.
+ It is either zero or the code of a JPEG marker that has been
+ read from the data source, but has not yet been processed. }
+
+ unread_marker : int;
+
+ { Links to decompression subobjects
+ (methods, private variables of modules) }
+
+ master : jpeg_decomp_master_ptr;
+ main : jpeg_d_main_controller_ptr;
+ coef : jpeg_d_coef_controller_ptr;
+ post : jpeg_d_post_controller_ptr;
+ inputctl : jpeg_input_controller_ptr;
+ marker : jpeg_marker_reader_ptr;
+ entropy : jpeg_entropy_decoder_ptr;
+ idct : jpeg_inverse_dct_ptr;
+ upsample : jpeg_upsampler_ptr;
+ cconvert : jpeg_color_deconverter_ptr;
+ cquantize : jpeg_color_quantizer_ptr;
+ end;
+
+{ Decompression startup: read start of JPEG datastream to see what's there
+ function jpeg_read_header (cinfo : j_decompress_ptr;
+ require_image : boolean) : int;
+ Return value is one of: }
+const
+ JPEG_SUSPENDED = 0; { Suspended due to lack of input data }
+ JPEG_HEADER_OK = 1; { Found valid image datastream }
+ JPEG_HEADER_TABLES_ONLY = 2; { Found valid table-specs-only datastream }
+{ If you pass require_image = TRUE (normal case), you need not check for
+ a TABLES_ONLY return code; an abbreviated file will cause an error exit.
+ JPEG_SUSPENDED is only possible if you use a data source module that can
+ give a suspension return (the stdio source module doesn't). }
+
+
+{ function jpeg_consume_input (cinfo : j_decompress_ptr) : int;
+ Return value is one of: }
+
+ JPEG_REACHED_SOS = 1; { Reached start of new scan }
+ JPEG_REACHED_EOI = 2; { Reached end of image }
+ JPEG_ROW_COMPLETED = 3; { Completed one iMCU row }
+ JPEG_SCAN_COMPLETED = 4; { Completed last iMCU row of a scan }
+
+
+
+
+implementation
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjquant1.pas b/src/lib/vampimg/JpegLib/imjquant1.pas
--- /dev/null
@@ -0,0 +1,1009 @@
+unit imjquant1;
+
+{ This file contains 1-pass color quantization (color mapping) routines.
+ These routines provide mapping to a fixed color map using equally spaced
+ color values. Optional Floyd-Steinberg or ordered dithering is available. }
+
+{ Original: jquant1.c; Copyright (C) 1991-1996, Thomas G. Lane. }
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjpeglib;
+
+{GLOBAL}
+procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr);
+
+implementation
+
+uses
+ imjmorecfg,
+ imjdeferr,
+ imjerror,
+ imjutils;
+
+{ The main purpose of 1-pass quantization is to provide a fast, if not very
+ high quality, colormapped output capability. A 2-pass quantizer usually
+ gives better visual quality; however, for quantized grayscale output this
+ quantizer is perfectly adequate. Dithering is highly recommended with this
+ quantizer, though you can turn it off if you really want to.
+
+ In 1-pass quantization the colormap must be chosen in advance of seeing the
+ image. We use a map consisting of all combinations of Ncolors[i] color
+ values for the i'th component. The Ncolors[] values are chosen so that
+ their product, the total number of colors, is no more than that requested.
+ (In most cases, the product will be somewhat less.)
+
+ Since the colormap is orthogonal, the representative value for each color
+ component can be determined without considering the other components;
+ then these indexes can be combined into a colormap index by a standard
+ N-dimensional-array-subscript calculation. Most of the arithmetic involved
+ can be precalculated and stored in the lookup table colorindex[].
+ colorindex[i][j] maps pixel value j in component i to the nearest
+ representative value (grid plane) for that component; this index is
+ multiplied by the array stride for component i, so that the
+ index of the colormap entry closest to a given pixel value is just
+ sum( colorindex[component-number][pixel-component-value] )
+ Aside from being fast, this scheme allows for variable spacing between
+ representative values with no additional lookup cost.
+
+ If gamma correction has been applied in color conversion, it might be wise
+ to adjust the color grid spacing so that the representative colors are
+ equidistant in linear space. At this writing, gamma correction is not
+ implemented by jdcolor, so nothing is done here. }
+
+
+{ Declarations for ordered dithering.
+
+ We use a standard 16x16 ordered dither array. The basic concept of ordered
+ dithering is described in many references, for instance Dale Schumacher's
+ chapter II.2 of Graphics Gems II (James Arvo, ed. Academic Press, 1991).
+ In place of Schumacher's comparisons against a "threshold" value, we add a
+ "dither" value to the input pixel and then round the result to the nearest
+ output value. The dither value is equivalent to (0.5 - threshold) times
+ the distance between output values. For ordered dithering, we assume that
+ the output colors are equally spaced; if not, results will probably be
+ worse, since the dither may be too much or too little at a given point.
+
+ The normal calculation would be to form pixel value + dither, range-limit
+ this to 0..MAXJSAMPLE, and then index into the colorindex table as usual.
+ We can skip the separate range-limiting step by extending the colorindex
+ table in both directions. }
+
+
+const
+ ODITHER_SIZE = 16; { dimension of dither matrix }
+{ NB: if ODITHER_SIZE is not a power of 2, ODITHER_MASK uses will break }
+ ODITHER_CELLS = (ODITHER_SIZE*ODITHER_SIZE); { # cells in matrix }
+ ODITHER_MASK = (ODITHER_SIZE-1); { mask for wrapping around counters }
+
+type
+ ODITHER_vector = Array[0..ODITHER_SIZE-1] of int;
+ ODITHER_MATRIX = Array[0..ODITHER_SIZE-1] of ODITHER_vector;
+ {ODITHER_MATRIX_PTR = ^array[0..ODITHER_SIZE-1] of int;}
+ ODITHER_MATRIX_PTR = ^ODITHER_MATRIX;
+
+const
+ base_dither_matrix : Array[0..ODITHER_SIZE-1,0..ODITHER_SIZE-1] of UINT8
+ = (
+ { Bayer's order-4 dither array. Generated by the code given in
+ Stephen Hawley's article "Ordered Dithering" in Graphics Gems I.
+ The values in this array must range from 0 to ODITHER_CELLS-1. }
+
+ ( 0,192, 48,240, 12,204, 60,252, 3,195, 51,243, 15,207, 63,255 ),
+ ( 128, 64,176,112,140, 76,188,124,131, 67,179,115,143, 79,191,127 ),
+ ( 32,224, 16,208, 44,236, 28,220, 35,227, 19,211, 47,239, 31,223 ),
+ ( 160, 96,144, 80,172,108,156, 92,163, 99,147, 83,175,111,159, 95 ),
+ ( 8,200, 56,248, 4,196, 52,244, 11,203, 59,251, 7,199, 55,247 ),
+ ( 136, 72,184,120,132, 68,180,116,139, 75,187,123,135, 71,183,119 ),
+ ( 40,232, 24,216, 36,228, 20,212, 43,235, 27,219, 39,231, 23,215 ),
+ ( 168,104,152, 88,164,100,148, 84,171,107,155, 91,167,103,151, 87 ),
+ ( 2,194, 50,242, 14,206, 62,254, 1,193, 49,241, 13,205, 61,253 ),
+ ( 130, 66,178,114,142, 78,190,126,129, 65,177,113,141, 77,189,125 ),
+ ( 34,226, 18,210, 46,238, 30,222, 33,225, 17,209, 45,237, 29,221 ),
+ ( 162, 98,146, 82,174,110,158, 94,161, 97,145, 81,173,109,157, 93 ),
+ ( 10,202, 58,250, 6,198, 54,246, 9,201, 57,249, 5,197, 53,245 ),
+ ( 138, 74,186,122,134, 70,182,118,137, 73,185,121,133, 69,181,117 ),
+ ( 42,234, 26,218, 38,230, 22,214, 41,233, 25,217, 37,229, 21,213 ),
+ ( 170,106,154, 90,166,102,150, 86,169,105,153, 89,165,101,149, 85 )
+ );
+
+
+{ Declarations for Floyd-Steinberg dithering.
+
+ Errors are accumulated into the array fserrors[], at a resolution of
+ 1/16th of a pixel count. The error at a given pixel is propagated
+ to its not-yet-processed neighbors using the standard F-S fractions,
+ ... (here) 7/16
+ 3/16 5/16 1/16
+ We work left-to-right on even rows, right-to-left on odd rows.
+
+ We can get away with a single array (holding one row's worth of errors)
+ by using it to store the current row's errors at pixel columns not yet
+ processed, but the next row's errors at columns already processed. We
+ need only a few extra variables to hold the errors immediately around the
+ current column. (If we are lucky, those variables are in registers, but
+ even if not, they're probably cheaper to access than array elements are.)
+
+ The fserrors[] array is indexed [component#][position].
+ We provide (#columns + 2) entries per component; the extra entry at each
+ end saves us from special-casing the first and last pixels.
+
+ Note: on a wide image, we might not have enough room in a PC's near data
+ segment to hold the error array; so it is allocated with alloc_large. }
+
+{$ifdef BITS_IN_JSAMPLE_IS_8}
+type
+ FSERROR = INT16; { 16 bits should be enough }
+ LOCFSERROR = int; { use 'int' for calculation temps }
+{$else}
+type
+ FSERROR = INT32; { may need more than 16 bits }
+ LOCFSERROR = INT32; { be sure calculation temps are big enough }
+{$endif}
+
+type
+ jFSError = 0..(MaxInt div SIZEOF(FSERROR))-1;
+ FS_ERROR_FIELD = array[jFSError] of FSERROR;
+ FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far}
+ { pointer to error array (in FAR storage!) }
+ FSERRORPTR = ^FSERROR;
+
+
+{ Private subobject }
+
+const
+ MAX_Q_COMPS = 4; { max components I can handle }
+
+type
+ my_cquantize_ptr = ^my_cquantizer;
+ my_cquantizer = record
+ pub : jpeg_color_quantizer; { public fields }
+
+ { Initially allocated colormap is saved here }
+ sv_colormap : JSAMPARRAY; { The color map as a 2-D pixel array }
+ sv_actual : int; { number of entries in use }
+
+ colorindex : JSAMPARRAY; { Precomputed mapping for speed }
+ { colorindex[i][j] = index of color closest to pixel value j in component i,
+ premultiplied as described above. Since colormap indexes must fit into
+ JSAMPLEs, the entries of this array will too. }
+
+ is_padded : boolean; { is the colorindex padded for odither? }
+
+ Ncolors : array[0..MAX_Q_COMPS-1] of int;
+ { # of values alloced to each component }
+
+ { Variables for ordered dithering }
+ row_index : int; { cur row's vertical index in dither matrix }
+ odither : array[0..MAX_Q_COMPS-1] of ODITHER_MATRIX_PTR;
+ { one dither array per component }
+ { Variables for Floyd-Steinberg dithering }
+ fserrors : array[0..MAX_Q_COMPS-1] of FS_ERROR_FIELD_PTR;
+ { accumulated errors }
+ on_odd_row : boolean; { flag to remember which row we are on }
+ end;
+
+
+{ Policy-making subroutines for create_colormap and create_colorindex.
+ These routines determine the colormap to be used. The rest of the module
+ only assumes that the colormap is orthogonal.
+
+ * select_ncolors decides how to divvy up the available colors
+ among the components.
+ * output_value defines the set of representative values for a component.
+ * largest_input_value defines the mapping from input values to
+ representative values for a component.
+ Note that the latter two routines may impose different policies for
+ different components, though this is not currently done. }
+
+
+
+{LOCAL}
+function select_ncolors (cinfo : j_decompress_ptr;
+ var Ncolors : array of int) : int;
+{ Determine allocation of desired colors to components, }
+{ and fill in Ncolors[] array to indicate choice. }
+{ Return value is total number of colors (product of Ncolors[] values). }
+var
+ nc : int;
+ max_colors : int;
+ total_colors, iroot, i, j : int;
+ changed : boolean;
+ temp : long;
+const
+ RGB_order:array[0..2] of int = (RGB_GREEN, RGB_RED, RGB_BLUE);
+begin
+ nc := cinfo^.out_color_components; { number of color components }
+ max_colors := cinfo^.desired_number_of_colors;
+
+ { We can allocate at least the nc'th root of max_colors per component. }
+ { Compute floor(nc'th root of max_colors). }
+ iroot := 1;
+ repeat
+ Inc(iroot);
+ temp := iroot; { set temp = iroot ** nc }
+ for i := 1 to pred(nc) do
+ temp := temp * iroot;
+ until (temp > long(max_colors)); { repeat till iroot exceeds root }
+ Dec(iroot); { now iroot = floor(root) }
+
+ { Must have at least 2 color values per component }
+ if (iroot < 2) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, int(temp));
+
+ { Initialize to iroot color values for each component }
+ total_colors := 1;
+ for i := 0 to pred(nc) do
+ begin
+ Ncolors[i] := iroot;
+ total_colors := total_colors * iroot;
+ end;
+
+ { We may be able to increment the count for one or more components without
+ exceeding max_colors, though we know not all can be incremented.
+ Sometimes, the first component can be incremented more than once!
+ (Example: for 16 colors, we start at 2*2*2, go to 3*2*2, then 4*2*2.)
+ In RGB colorspace, try to increment G first, then R, then B. }
+
+ repeat
+ changed := FALSE;
+ for i := 0 to pred(nc) do
+ begin
+ if cinfo^.out_color_space = JCS_RGB then
+ j := RGB_order[i]
+ else
+ j := i;
+ { calculate new total_colors if Ncolors[j] is incremented }
+ temp := total_colors div Ncolors[j];
+ temp := temp * (Ncolors[j]+1); { done in long arith to avoid oflo }
+ if (temp > long(max_colors)) then
+ break; { won't fit, done with this pass }
+ Inc(Ncolors[j]); { OK, apply the increment }
+ total_colors := int(temp);
+ changed := TRUE;
+ end;
+ until not changed;
+
+ select_ncolors := total_colors;
+end;
+
+
+{LOCAL}
+function output_value (cinfo : j_decompress_ptr;
+ ci : int; j : int; maxj : int) : int;
+{ Return j'th output value, where j will range from 0 to maxj }
+{ The output values must fall in 0..MAXJSAMPLE in increasing order }
+begin
+ { We always provide values 0 and MAXJSAMPLE for each component;
+ any additional values are equally spaced between these limits.
+ (Forcing the upper and lower values to the limits ensures that
+ dithering can't produce a color outside the selected gamut.) }
+
+ output_value := int (( INT32(j) * MAXJSAMPLE + maxj div 2) div maxj);
+end;
+
+
+{LOCAL}
+function largest_input_value (cinfo : j_decompress_ptr;
+ ci : int; j : int; maxj : int) : int;
+{ Return largest input value that should map to j'th output value }
+{ Must have largest(j=0) >= 0, and largest(j=maxj) >= MAXJSAMPLE }
+begin
+ { Breakpoints are halfway between values returned by output_value }
+ largest_input_value := int (( INT32(2*j + 1) * MAXJSAMPLE +
+ maxj) div (2*maxj));
+end;
+
+
+{ Create the colormap. }
+
+{LOCAL}
+procedure create_colormap (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+ colormap : JSAMPARRAY; { Created colormap }
+
+ total_colors : int; { Number of distinct output colors }
+ i,j,k, nci, blksize, blkdist, ptr, val : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+
+ { Select number of colors for each component }
+ total_colors := select_ncolors(cinfo, cquantize^.Ncolors);
+
+ { Report selected color counts }
+ {$IFDEF DEBUG}
+ if (cinfo^.out_color_components = 3) then
+ TRACEMS4(j_common_ptr(cinfo), 1, JTRC_QUANT_3_NCOLORS,
+ total_colors, cquantize^.Ncolors[0],
+ cquantize^.Ncolors[1], cquantize^.Ncolors[2])
+ else
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_NCOLORS, total_colors);
+ {$ENDIF}
+
+ { Allocate and fill in the colormap. }
+ { The colors are ordered in the map in standard row-major order, }
+ { i.e. rightmost (highest-indexed) color changes most rapidly. }
+
+ colormap := cinfo^.mem^.alloc_sarray(
+ j_common_ptr(cinfo), JPOOL_IMAGE,
+ JDIMENSION(total_colors), JDIMENSION(cinfo^.out_color_components));
+
+ { blksize is number of adjacent repeated entries for a component }
+ { blkdist is distance between groups of identical entries for a component }
+ blkdist := total_colors;
+
+ for i := 0 to pred(cinfo^.out_color_components) do
+ begin
+ { fill in colormap entries for i'th color component }
+ nci := cquantize^.Ncolors[i]; { # of distinct values for this color }
+ blksize := blkdist div nci;
+ for j := 0 to pred(nci) do
+ begin
+ { Compute j'th output value (out of nci) for component }
+ val := output_value(cinfo, i, j, nci-1);
+ { Fill in all colormap entries that have this value of this component }
+ ptr := j * blksize;
+ while (ptr < total_colors) do
+ begin
+ { fill in blksize entries beginning at ptr }
+ for k := 0 to pred(blksize) do
+ colormap^[i]^[ptr+k] := JSAMPLE(val);
+
+ Inc(ptr, blkdist);
+ end;
+ end;
+ blkdist := blksize; { blksize of this color is blkdist of next }
+ end;
+
+ { Save the colormap in private storage,
+ where it will survive color quantization mode changes. }
+
+ cquantize^.sv_colormap := colormap;
+ cquantize^.sv_actual := total_colors;
+end;
+
+{ Create the color index table. }
+
+{LOCAL}
+procedure create_colorindex (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+ indexptr,
+ help_indexptr : JSAMPROW; { for negative offsets }
+ i,j,k, nci, blksize, val, pad : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ { For ordered dither, we pad the color index tables by MAXJSAMPLE in
+ each direction (input index values can be -MAXJSAMPLE .. 2*MAXJSAMPLE).
+ This is not necessary in the other dithering modes. However, we
+ flag whether it was done in case user changes dithering mode. }
+
+ if (cinfo^.dither_mode = JDITHER_ORDERED) then
+ begin
+ pad := MAXJSAMPLE*2;
+ cquantize^.is_padded := TRUE;
+ end
+ else
+ begin
+ pad := 0;
+ cquantize^.is_padded := FALSE;
+ end;
+
+ cquantize^.colorindex := cinfo^.mem^.alloc_sarray
+ (j_common_ptr(cinfo), JPOOL_IMAGE,
+ JDIMENSION(MAXJSAMPLE+1 + pad),
+ JDIMENSION(cinfo^.out_color_components));
+
+ { blksize is number of adjacent repeated entries for a component }
+ blksize := cquantize^.sv_actual;
+
+ for i := 0 to pred(cinfo^.out_color_components) do
+ begin
+ { fill in colorindex entries for i'th color component }
+ nci := cquantize^.Ncolors[i]; { # of distinct values for this color }
+ blksize := blksize div nci;
+
+ { adjust colorindex pointers to provide padding at negative indexes. }
+ if (pad <> 0) then
+ Inc(JSAMPLE_PTR(cquantize^.colorindex^[i]), MAXJSAMPLE);
+
+ { in loop, val = index of current output value, }
+ { and k = largest j that maps to current val }
+ indexptr := cquantize^.colorindex^[i];
+ val := 0;
+ k := largest_input_value(cinfo, i, 0, nci-1);
+ for j := 0 to MAXJSAMPLE do
+ begin
+ while (j > k) do { advance val if past boundary }
+ begin
+ Inc(val);
+ k := largest_input_value(cinfo, i, val, nci-1);
+ end;
+ { premultiply so that no multiplication needed in main processing }
+ indexptr^[j] := JSAMPLE (val * blksize);
+ end;
+ { Pad at both ends if necessary }
+ if (pad <> 0) then
+ begin
+ help_indexptr := indexptr;
+ { adjust the help pointer to avoid negative offsets }
+ Dec(JSAMPLE_PTR(help_indexptr), MAXJSAMPLE);
+
+ for j := 1 to MAXJSAMPLE do
+ begin
+ {indexptr^[-j] := indexptr^[0];}
+ help_indexptr^[MAXJSAMPLE-j] := indexptr^[0];
+ indexptr^[MAXJSAMPLE+j] := indexptr^[MAXJSAMPLE];
+ end;
+ end;
+ end;
+end;
+
+
+{ Create an ordered-dither array for a component having ncolors
+ distinct output values. }
+
+{LOCAL}
+function make_odither_array (cinfo : j_decompress_ptr;
+ ncolors : int) : ODITHER_MATRIX_PTR;
+var
+ odither : ODITHER_MATRIX_PTR;
+ j, k : int;
+ num, den : INT32;
+begin
+ odither := ODITHER_MATRIX_PTR (
+ cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(ODITHER_MATRIX)));
+ { The inter-value distance for this color is MAXJSAMPLE/(ncolors-1).
+ Hence the dither value for the matrix cell with fill order f
+ (f=0..N-1) should be (N-1-2*f)/(2*N) * MAXJSAMPLE/(ncolors-1).
+ On 16-bit-int machine, be careful to avoid overflow. }
+
+ den := 2 * ODITHER_CELLS * ( INT32(ncolors - 1));
+ for j := 0 to pred(ODITHER_SIZE) do
+ begin
+ for k := 0 to pred(ODITHER_SIZE) do
+ begin
+ num := ( INT32(ODITHER_CELLS-1 - 2*( int(base_dither_matrix[j][k]))))
+ * MAXJSAMPLE;
+ { Ensure round towards zero despite C's lack of consistency
+ about rounding negative values in integer division... }
+
+ if num<0 then
+ odither^[j][k] := int (-((-num) div den))
+ else
+ odither^[j][k] := int (num div den);
+ end;
+ end;
+ make_odither_array := odither;
+end;
+
+
+{ Create the ordered-dither tables.
+ Components having the same number of representative colors may
+ share a dither table. }
+
+{LOCAL}
+procedure create_odither_tables (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+ odither : ODITHER_MATRIX_PTR;
+ i, j, nci : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+
+ for i := 0 to pred(cinfo^.out_color_components) do
+ begin
+ nci := cquantize^.Ncolors[i]; { # of distinct values for this color }
+ odither := NIL; { search for matching prior component }
+ for j := 0 to pred(i) do
+ begin
+ if (nci = cquantize^.Ncolors[j]) then
+ begin
+ odither := cquantize^.odither[j];
+ break;
+ end;
+ end;
+ if (odither = NIL) then { need a new table? }
+ odither := make_odither_array(cinfo, nci);
+ cquantize^.odither[i] := odither;
+ end;
+end;
+
+
+{ Map some rows of pixels to the output colormapped representation. }
+
+{METHODDEF}
+procedure color_quantize (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ General case, no dithering }
+var
+ cquantize : my_cquantize_ptr;
+ colorindex : JSAMPARRAY;
+ pixcode, ci : int; {register}
+ ptrin, ptrout : JSAMPLE_PTR; {register}
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+ nc : int; {register}
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ colorindex := cquantize^.colorindex;
+ width := cinfo^.output_width;
+ nc := cinfo^.out_color_components;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ ptrin := JSAMPLE_PTR(input_buf^[row]);
+ ptrout := JSAMPLE_PTR(output_buf^[row]);
+ for col := pred(width) downto 0 do
+ begin
+ pixcode := 0;
+ for ci := 0 to pred(nc) do
+ begin
+ Inc(pixcode, GETJSAMPLE(colorindex^[ci]^[GETJSAMPLE(ptrin^)]) );
+ Inc(ptrin);
+ end;
+ ptrout^ := JSAMPLE (pixcode);
+ Inc(ptrout);
+ end;
+ end;
+end;
+
+
+{METHODDEF}
+procedure color_quantize3 (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ Fast path for out_color_components=3, no dithering }
+var
+ cquantize : my_cquantize_ptr;
+ pixcode : int; {register}
+ ptrin, ptrout : JSAMPLE_PTR; {register}
+ colorindex0 : JSAMPROW;
+ colorindex1 : JSAMPROW;
+ colorindex2 : JSAMPROW;
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ colorindex0 := (cquantize^.colorindex)^[0];
+ colorindex1 := (cquantize^.colorindex)^[1];
+ colorindex2 := (cquantize^.colorindex)^[2];
+ width := cinfo^.output_width;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ ptrin := JSAMPLE_PTR(input_buf^[row]);
+ ptrout := JSAMPLE_PTR(output_buf^[row]);
+ for col := pred(width) downto 0 do
+ begin
+ pixcode := GETJSAMPLE((colorindex0)^[GETJSAMPLE(ptrin^)]);
+ Inc(ptrin);
+ Inc( pixcode, GETJSAMPLE((colorindex1)^[GETJSAMPLE(ptrin^)]) );
+ Inc(ptrin);
+ Inc( pixcode, GETJSAMPLE((colorindex2)^[GETJSAMPLE(ptrin^)]) );
+ Inc(ptrin);
+ ptrout^ := JSAMPLE (pixcode);
+ Inc(ptrout);
+ end;
+ end;
+end;
+
+
+{METHODDEF}
+procedure quantize_ord_dither (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ General case, with ordered dithering }
+var
+ cquantize : my_cquantize_ptr;
+ input_ptr, {register}
+ output_ptr : JSAMPLE_PTR; {register}
+ colorindex_ci : JSAMPROW;
+ dither : ^ODITHER_vector; { points to active row of dither matrix }
+ row_index, col_index : int; { current indexes into dither matrix }
+ nc : int;
+ ci : int;
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+var
+ pad_offset : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ nc := cinfo^.out_color_components;
+ width := cinfo^.output_width;
+
+ { Nomssi: work around negative offset }
+ if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then
+ pad_offset := MAXJSAMPLE
+ else
+ pad_offset := 0;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ { Initialize output values to 0 so can process components separately }
+ jzero_far( {far} pointer(output_buf^[row]),
+ size_t(width * SIZEOF(JSAMPLE)));
+ row_index := cquantize^.row_index;
+ for ci := 0 to pred(nc) do
+ begin
+ input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]);
+ output_ptr := JSAMPLE_PTR(output_buf^[row]);
+ colorindex_ci := cquantize^.colorindex^[ci];
+ { Nomssi }
+ Dec(JSAMPLE_PTR(colorindex_ci), pad_offset);
+
+ dither := @(cquantize^.odither[ci]^[row_index]);
+ col_index := 0;
+
+ for col := pred(width) downto 0 do
+ begin
+ { Form pixel value + dither, range-limit to 0..MAXJSAMPLE,
+ select output value, accumulate into output code for this pixel.
+ Range-limiting need not be done explicitly, as we have extended
+ the colorindex table to produce the right answers for out-of-range
+ inputs. The maximum dither is +- MAXJSAMPLE; this sets the
+ required amount of padding. }
+
+ Inc(output_ptr^,
+ colorindex_ci^[GETJSAMPLE(input_ptr^)+ pad_offset +
+ dither^[col_index]]);
+ Inc(output_ptr);
+ Inc(input_ptr, nc);
+ col_index := (col_index + 1) and ODITHER_MASK;
+ end;
+ end;
+ { Advance row index for next row }
+ row_index := (row_index + 1) and ODITHER_MASK;
+ cquantize^.row_index := row_index;
+ end;
+end;
+
+{METHODDEF}
+procedure quantize3_ord_dither (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ Fast path for out_color_components=3, with ordered dithering }
+var
+ cquantize : my_cquantize_ptr;
+ pixcode : int; {register}
+ input_ptr : JSAMPLE_PTR; {register}
+ output_ptr : JSAMPLE_PTR; {register}
+ colorindex0 : JSAMPROW;
+ colorindex1 : JSAMPROW;
+ colorindex2 : JSAMPROW;
+ dither0 : ^ODITHER_vector; { points to active row of dither matrix }
+ dither1 : ^ODITHER_vector;
+ dither2 : ^ODITHER_vector;
+ row_index, col_index : int; { current indexes into dither matrix }
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+var
+ pad_offset : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ colorindex0 := (cquantize^.colorindex)^[0];
+ colorindex1 := (cquantize^.colorindex)^[1];
+ colorindex2 := (cquantize^.colorindex)^[2];
+ width := cinfo^.output_width;
+
+ { Nomssi: work around negative offset }
+ if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then
+ pad_offset := MAXJSAMPLE
+ else
+ pad_offset := 0;
+
+ Dec(JSAMPLE_PTR(colorindex0), pad_offset);
+ Dec(JSAMPLE_PTR(colorindex1), pad_offset);
+ Dec(JSAMPLE_PTR(colorindex2), pad_offset);
+
+ for row := 0 to pred(num_rows) do
+ begin
+ row_index := cquantize^.row_index;
+ input_ptr := JSAMPLE_PTR(input_buf^[row]);
+ output_ptr := JSAMPLE_PTR(output_buf^[row]);
+ dither0 := @(cquantize^.odither[0]^[row_index]);
+ dither1 := @(cquantize^.odither[1]^[row_index]);
+ dither2 := @(cquantize^.odither[2]^[row_index]);
+ col_index := 0;
+
+
+ for col := pred(width) downto 0 do
+ begin
+ pixcode := GETJSAMPLE(colorindex0^[GETJSAMPLE(input_ptr^) + pad_offset
+ + dither0^[col_index]]);
+ Inc(input_ptr);
+ Inc(pixcode, GETJSAMPLE(colorindex1^[GETJSAMPLE(input_ptr^) + pad_offset
+ + dither1^[col_index]]));
+ Inc(input_ptr);
+ Inc(pixcode, GETJSAMPLE(colorindex2^[GETJSAMPLE(input_ptr^) + pad_offset
+ + dither2^[col_index]]));
+ Inc(input_ptr);
+ output_ptr^ := JSAMPLE (pixcode);
+ Inc(output_ptr);
+ col_index := (col_index + 1) and ODITHER_MASK;
+ end;
+ row_index := (row_index + 1) and ODITHER_MASK;
+ cquantize^.row_index := row_index;
+ end;
+end;
+
+
+{METHODDEF}
+procedure quantize_fs_dither (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ General case, with Floyd-Steinberg dithering }
+var
+ cquantize : my_cquantize_ptr;
+ cur : LOCFSERROR; {register} { current error or pixel value }
+ belowerr : LOCFSERROR; { error for pixel below cur }
+ bpreverr : LOCFSERROR; { error for below/prev col }
+ bnexterr : LOCFSERROR; { error for below/next col }
+ delta : LOCFSERROR;
+ prev_errorptr,
+ errorptr : FSERRORPTR; {register} { => fserrors[] at column before current }
+ input_ptr, {register}
+ output_ptr : JSAMPLE_PTR; {register}
+ colorindex_ci : JSAMPROW;
+ colormap_ci : JSAMPROW;
+ pixcode : int;
+ nc : int;
+ dir : int; { 1 for left-to-right, -1 for right-to-left }
+ dirnc : int; { dir * nc }
+ ci : int;
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+ range_limit : range_limit_table_ptr;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ nc := cinfo^.out_color_components;
+ width := cinfo^.output_width;
+ range_limit := cinfo^.sample_range_limit;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ { Initialize output values to 0 so can process components separately }
+ jzero_far( (output_buf)^[row],
+ size_t(width * SIZEOF(JSAMPLE)));
+ for ci := 0 to pred(nc) do
+ begin
+ input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]);
+ output_ptr := JSAMPLE_PTR(output_buf^[row]);
+ errorptr := FSERRORPTR(cquantize^.fserrors[ci]); { => entry before first column }
+ if (cquantize^.on_odd_row) then
+ begin
+ { work right to left in this row }
+ Inc(input_ptr, (width-1) * JDIMENSION(nc)); { so point to rightmost pixel }
+ Inc(output_ptr, width-1);
+ dir := -1;
+ dirnc := -nc;
+ Inc(errorptr, (width+1)); { => entry after last column }
+ end
+ else
+ begin
+ { work left to right in this row }
+ dir := 1;
+ dirnc := nc;
+ {errorptr := cquantize^.fserrors[ci];}
+ end;
+
+ colorindex_ci := cquantize^.colorindex^[ci];
+
+ colormap_ci := (cquantize^.sv_colormap)^[ci];
+ { Preset error values: no error propagated to first pixel from left }
+ cur := 0;
+ { and no error propagated to row below yet }
+ belowerr := 0;
+ bpreverr := 0;
+
+ for col := pred(width) downto 0 do
+ begin
+ prev_errorptr := errorptr;
+ Inc(errorptr, dir); { advance errorptr to current column }
+
+ { cur holds the error propagated from the previous pixel on the
+ current line. Add the error propagated from the previous line
+ to form the complete error correction term for this pixel, and
+ round the error term (which is expressed * 16) to an integer.
+ RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct
+ for either sign of the error value.
+ Note: errorptr points to *previous* column's array entry. }
+
+ cur := (cur + errorptr^ + 8) div 16;
+
+ { Form pixel value + error, and range-limit to 0..MAXJSAMPLE.
+ The maximum error is +- MAXJSAMPLE; this sets the required size
+ of the range_limit array. }
+
+ Inc( cur, GETJSAMPLE(input_ptr^));
+ cur := GETJSAMPLE(range_limit^[cur]);
+ { Select output value, accumulate into output code for this pixel }
+ pixcode := GETJSAMPLE(colorindex_ci^[cur]);
+ Inc(output_ptr^, JSAMPLE (pixcode));
+ { Compute actual representation error at this pixel }
+ { Note: we can do this even though we don't have the final }
+ { pixel code, because the colormap is orthogonal. }
+ Dec(cur, GETJSAMPLE(colormap_ci^[pixcode]));
+ { Compute error fractions to be propagated to adjacent pixels.
+ Add these into the running sums, and simultaneously shift the
+ next-line error sums left by 1 column. }
+
+ bnexterr := cur;
+ delta := cur * 2;
+ Inc(cur, delta); { form error * 3 }
+ prev_errorptr^ := FSERROR (bpreverr + cur);
+ Inc(cur, delta); { form error * 5 }
+ bpreverr := belowerr + cur;
+ belowerr := bnexterr;
+ Inc(cur, delta); { form error * 7 }
+ { At this point cur contains the 7/16 error value to be propagated
+ to the next pixel on the current line, and all the errors for the
+ next line have been shifted over. We are therefore ready to move on. }
+
+ Inc(input_ptr, dirnc); { advance input ptr to next column }
+ Inc(output_ptr, dir); { advance output ptr to next column }
+
+ end;
+ { Post-loop cleanup: we must unload the final error value into the
+ final fserrors[] entry. Note we need not unload belowerr because
+ it is for the dummy column before or after the actual array. }
+
+ errorptr^ := FSERROR (bpreverr); { unload prev err into array }
+ { Nomssi : ?? }
+ end;
+ cquantize^.on_odd_row := not cquantize^.on_odd_row;
+ end;
+end;
+
+
+{ Allocate workspace for Floyd-Steinberg errors. }
+
+{LOCAL}
+procedure alloc_fs_workspace (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+ arraysize : size_t;
+ i : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR));
+ for i := 0 to pred(cinfo^.out_color_components) do
+ begin
+ cquantize^.fserrors[i] := FS_ERROR_FIELD_PTR(
+ cinfo^.mem^.alloc_large(j_common_ptr(cinfo), JPOOL_IMAGE, arraysize));
+ end;
+end;
+
+
+{ Initialize for one-pass color quantization. }
+
+{METHODDEF}
+procedure start_pass_1_quant (cinfo : j_decompress_ptr;
+ is_pre_scan : boolean);
+var
+ cquantize : my_cquantize_ptr;
+ arraysize : size_t;
+ i : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ { Install my colormap. }
+ cinfo^.colormap := cquantize^.sv_colormap;
+ cinfo^.actual_number_of_colors := cquantize^.sv_actual;
+
+ { Initialize for desired dithering mode. }
+ case (cinfo^.dither_mode) of
+ JDITHER_NONE:
+ if (cinfo^.out_color_components = 3) then
+ cquantize^.pub.color_quantize := color_quantize3
+ else
+ cquantize^.pub.color_quantize := color_quantize;
+ JDITHER_ORDERED:
+ begin
+ if (cinfo^.out_color_components = 3) then
+ cquantize^.pub.color_quantize := quantize3_ord_dither
+ else
+ cquantize^.pub.color_quantize := quantize_ord_dither;
+ cquantize^.row_index := 0; { initialize state for ordered dither }
+ { If user changed to ordered dither from another mode,
+ we must recreate the color index table with padding.
+ This will cost extra space, but probably isn't very likely. }
+
+ if (not cquantize^.is_padded) then
+ create_colorindex(cinfo);
+ { Create ordered-dither tables if we didn't already. }
+ if (cquantize^.odither[0] = NIL) then
+ create_odither_tables(cinfo);
+ end;
+ JDITHER_FS:
+ begin
+ cquantize^.pub.color_quantize := quantize_fs_dither;
+ cquantize^.on_odd_row := FALSE; { initialize state for F-S dither }
+ { Allocate Floyd-Steinberg workspace if didn't already. }
+ if (cquantize^.fserrors[0] = NIL) then
+ alloc_fs_workspace(cinfo);
+ { Initialize the propagated errors to zero. }
+ arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR));
+ for i := 0 to pred(cinfo^.out_color_components) do
+ jzero_far({far} pointer( cquantize^.fserrors[i] ), arraysize);
+ end;
+ else
+ ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED);
+ end;
+end;
+
+
+{ Finish up at the end of the pass. }
+
+{METHODDEF}
+procedure finish_pass_1_quant (cinfo : j_decompress_ptr);
+begin
+ { no work in 1-pass case }
+end;
+
+
+{ Switch to a new external colormap between output passes.
+ Shouldn't get to this module! }
+
+{METHODDEF}
+procedure new_color_map_1_quant (cinfo : j_decompress_ptr);
+begin
+ ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE);
+end;
+
+
+{ Module initialization routine for 1-pass color quantization. }
+
+{GLOBAL}
+procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+begin
+ cquantize := my_cquantize_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(my_cquantizer)));
+ cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize);
+ cquantize^.pub.start_pass := start_pass_1_quant;
+ cquantize^.pub.finish_pass := finish_pass_1_quant;
+ cquantize^.pub.new_color_map := new_color_map_1_quant;
+ cquantize^.fserrors[0] := NIL; { Flag FS workspace not allocated }
+ cquantize^.odither[0] := NIL; { Also flag odither arrays not allocated }
+
+ { Make sure my internal arrays won't overflow }
+ if (cinfo^.out_color_components > MAX_Q_COMPS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_COMPONENTS, MAX_Q_COMPS);
+ { Make sure colormap indexes can be represented by JSAMPLEs }
+ if (cinfo^.desired_number_of_colors > (MAXJSAMPLE+1)) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXJSAMPLE+1);
+
+ { Create the colormap and color index table. }
+ create_colormap(cinfo);
+ create_colorindex(cinfo);
+
+ { Allocate Floyd-Steinberg workspace now if requested.
+ We do this now since it is FAR storage and may affect the memory
+ manager's space calculations. If the user changes to FS dither
+ mode in a later pass, we will allocate the space then, and will
+ possibly overrun the max_memory_to_use setting. }
+
+ if (cinfo^.dither_mode = JDITHER_FS) then
+ alloc_fs_workspace(cinfo);
+end;
+
+
+end.
diff --git a/src/lib/vampimg/JpegLib/imjquant2.pas b/src/lib/vampimg/JpegLib/imjquant2.pas
--- /dev/null
@@ -0,0 +1,1551 @@
+unit imjquant2;
+
+
+{ This file contains 2-pass color quantization (color mapping) routines.
+ These routines provide selection of a custom color map for an image,
+ followed by mapping of the image to that color map, with optional
+ Floyd-Steinberg dithering.
+ It is also possible to use just the second pass to map to an arbitrary
+ externally-given color map.
+
+ Note: ordered dithering is not supported, since there isn't any fast
+ way to compute intercolor distances; it's unclear that ordered dither's
+ fundamental assumptions even hold with an irregularly spaced color map. }
+
+{ Original: jquant2.c; Copyright (C) 1991-1996, Thomas G. Lane. }
+
+interface
+
+{$I imjconfig.inc}
+
+uses
+ imjmorecfg,
+ imjdeferr,
+ imjerror,
+ imjutils,
+ imjpeglib;
+
+{ Module initialization routine for 2-pass color quantization. }
+
+
+{GLOBAL}
+procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr);
+
+implementation
+
+{ This module implements the well-known Heckbert paradigm for color
+ quantization. Most of the ideas used here can be traced back to
+ Heckbert's seminal paper
+ Heckbert, Paul. "Color Image Quantization for Frame Buffer Display",
+ Proc. SIGGRAPH '82, Computer Graphics v.16 #3 (July 1982), pp 297-304.
+
+ In the first pass over the image, we accumulate a histogram showing the
+ usage count of each possible color. To keep the histogram to a reasonable
+ size, we reduce the precision of the input; typical practice is to retain
+ 5 or 6 bits per color, so that 8 or 4 different input values are counted
+ in the same histogram cell.
+
+ Next, the color-selection step begins with a box representing the whole
+ color space, and repeatedly splits the "largest" remaining box until we
+ have as many boxes as desired colors. Then the mean color in each
+ remaining box becomes one of the possible output colors.
+
+ The second pass over the image maps each input pixel to the closest output
+ color (optionally after applying a Floyd-Steinberg dithering correction).
+ This mapping is logically trivial, but making it go fast enough requires
+ considerable care.
+
+ Heckbert-style quantizers vary a good deal in their policies for choosing
+ the "largest" box and deciding where to cut it. The particular policies
+ used here have proved out well in experimental comparisons, but better ones
+ may yet be found.
+
+ In earlier versions of the IJG code, this module quantized in YCbCr color
+ space, processing the raw upsampled data without a color conversion step.
+ This allowed the color conversion math to be done only once per colormap
+ entry, not once per pixel. However, that optimization precluded other
+ useful optimizations (such as merging color conversion with upsampling)
+ and it also interfered with desired capabilities such as quantizing to an
+ externally-supplied colormap. We have therefore abandoned that approach.
+ The present code works in the post-conversion color space, typically RGB.
+
+ To improve the visual quality of the results, we actually work in scaled
+ RGB space, giving G distances more weight than R, and R in turn more than
+ B. To do everything in integer math, we must use integer scale factors.
+ The 2/3/1 scale factors used here correspond loosely to the relative
+ weights of the colors in the NTSC grayscale equation.
+ If you want to use this code to quantize a non-RGB color space, you'll
+ probably need to change these scale factors. }
+
+const
+ R_SCALE = 2; { scale R distances by this much }
+ G_SCALE = 3; { scale G distances by this much }
+ B_SCALE = 1; { and B by this much }
+
+{ Relabel R/G/B as components 0/1/2, respecting the RGB ordering defined
+ in jmorecfg.h. As the code stands, it will do the right thing for R,G,B
+ and B,G,R orders. If you define some other weird order in jmorecfg.h,
+ you'll get compile errors until you extend this logic. In that case
+ you'll probably want to tweak the histogram sizes too. }
+
+{$ifdef RGB_RED_IS_0}
+const
+ C0_SCALE = R_SCALE;
+ C1_SCALE = G_SCALE;
+ C2_SCALE = B_SCALE;
+{$else}
+const
+ C0_SCALE = B_SCALE;
+ C1_SCALE = G_SCALE;
+ C2_SCALE = R_SCALE;
+{$endif}
+
+
+{ First we have the histogram data structure and routines for creating it.
+
+ The number of bits of precision can be adjusted by changing these symbols.
+ We recommend keeping 6 bits for G and 5 each for R and B.
+ If you have plenty of memory and cycles, 6 bits all around gives marginally
+ better results; if you are short of memory, 5 bits all around will save
+ some space but degrade the results.
+ To maintain a fully accurate histogram, we'd need to allocate a "long"
+ (preferably unsigned long) for each cell. In practice this is overkill;
+ we can get by with 16 bits per cell. Few of the cell counts will overflow,
+ and clamping those that do overflow to the maximum value will give close-
+ enough results. This reduces the recommended histogram size from 256Kb
+ to 128Kb, which is a useful savings on PC-class machines.
+ (In the second pass the histogram space is re-used for pixel mapping data;
+ in that capacity, each cell must be able to store zero to the number of
+ desired colors. 16 bits/cell is plenty for that too.)
+ Since the JPEG code is intended to run in small memory model on 80x86
+ machines, we can't just allocate the histogram in one chunk. Instead
+ of a true 3-D array, we use a row of pointers to 2-D arrays. Each
+ pointer corresponds to a C0 value (typically 2^5 = 32 pointers) and
+ each 2-D array has 2^6*2^5 = 2048 or 2^6*2^6 = 4096 entries. Note that
+ on 80x86 machines, the pointer row is in near memory but the actual
+ arrays are in far memory (same arrangement as we use for image arrays). }
+
+
+const
+ MAXNUMCOLORS = (MAXJSAMPLE+1); { maximum size of colormap }
+
+{ These will do the right thing for either R,G,B or B,G,R color order,
+ but you may not like the results for other color orders. }
+
+const
+ HIST_C0_BITS = 5; { bits of precision in R/B histogram }
+ HIST_C1_BITS = 6; { bits of precision in G histogram }
+ HIST_C2_BITS = 5; { bits of precision in B/R histogram }
+
+{ Number of elements along histogram axes. }
+const
+ HIST_C0_ELEMS = (1 shl HIST_C0_BITS);
+ HIST_C1_ELEMS = (1 shl HIST_C1_BITS);
+ HIST_C2_ELEMS = (1 shl HIST_C2_BITS);
+
+{ These are the amounts to shift an input value to get a histogram index. }
+const
+ C0_SHIFT = (BITS_IN_JSAMPLE-HIST_C0_BITS);
+ C1_SHIFT = (BITS_IN_JSAMPLE-HIST_C1_BITS);
+ C2_SHIFT = (BITS_IN_JSAMPLE-HIST_C2_BITS);
+
+
+type { Nomssi }
+ RGBptr = ^RGBtype;
+ RGBtype = packed record
+ r,g,b : JSAMPLE;
+ end;
+type
+ histcell = UINT16; { histogram cell; prefer an unsigned type }
+
+type
+ histptr = ^histcell {FAR}; { for pointers to histogram cells }
+
+type
+ hist1d = array[0..HIST_C2_ELEMS-1] of histcell; { typedefs for the array }
+ {hist1d_ptr = ^hist1d;}
+ hist1d_field = array[0..HIST_C1_ELEMS-1] of hist1d;
+ { type for the 2nd-level pointers }
+ hist2d = ^hist1d_field;
+ hist2d_field = array[0..HIST_C0_ELEMS-1] of hist2d;
+ hist3d = ^hist2d_field; { type for top-level pointer }
+
+
+{ Declarations for Floyd-Steinberg dithering.
+
+ Errors are accumulated into the array fserrors[], at a resolution of
+ 1/16th of a pixel count. The error at a given pixel is propagated
+ to its not-yet-processed neighbors using the standard F-S fractions,
+ ... (here) 7/16
+ 3/16 5/16 1/16
+ We work left-to-right on even rows, right-to-left on odd rows.
+
+ We can get away with a single array (holding one row's worth of errors)
+ by using it to store the current row's errors at pixel columns not yet
+ processed, but the next row's errors at columns already processed. We
+ need only a few extra variables to hold the errors immediately around the
+ current column. (If we are lucky, those variables are in registers, but
+ even if not, they're probably cheaper to access than array elements are.)
+
+ The fserrors[] array has (#columns + 2) entries; the extra entry at
+ each end saves us from special-casing the first and last pixels.
+ Each entry is three values long, one value for each color component.
+
+ Note: on a wide image, we might not have enough room in a PC's near data
+ segment to hold the error array; so it is allocated with alloc_large. }
+
+
+{$ifdef BITS_IN_JSAMPLE_IS_8}
+type
+ FSERROR = INT16; { 16 bits should be enough }
+ LOCFSERROR = int; { use 'int' for calculation temps }
+{$else}
+type
+ FSERROR = INT32; { may need more than 16 bits }
+ LOCFSERROR = INT32; { be sure calculation temps are big enough }
+{$endif}
+type { Nomssi }
+ RGB_FSERROR_PTR = ^RGB_FSERROR;
+ RGB_FSERROR = packed record
+ r,g,b : FSERROR;
+ end;
+ LOCRGB_FSERROR = packed record
+ r,g,b : LOCFSERROR;
+ end;
+
+type
+ FSERROR_PTR = ^FSERROR;
+ jFSError = 0..(MaxInt div SIZEOF(RGB_FSERROR))-1;
+ FS_ERROR_FIELD = array[jFSError] of RGB_FSERROR;
+ FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far}
+ { pointer to error array (in FAR storage!) }
+
+type
+ error_limit_array = array[-MAXJSAMPLE..MAXJSAMPLE] of int;
+ { table for clamping the applied error }
+ error_limit_ptr = ^error_limit_array;
+
+{ Private subobject }
+type
+ my_cquantize_ptr = ^my_cquantizer;
+ my_cquantizer = record
+ pub : jpeg_color_quantizer; { public fields }
+
+ { Space for the eventually created colormap is stashed here }
+ sv_colormap : JSAMPARRAY; { colormap allocated at init time }
+ desired : int; { desired # of colors = size of colormap }
+
+ { Variables for accumulating image statistics }
+ histogram : hist3d; { pointer to the histogram }
+
+ needs_zeroed : boolean; { TRUE if next pass must zero histogram }
+
+ { Variables for Floyd-Steinberg dithering }
+ fserrors : FS_ERROR_FIELD_PTR; { accumulated errors }
+ on_odd_row : boolean; { flag to remember which row we are on }
+ error_limiter : error_limit_ptr; { table for clamping the applied error }
+ end;
+
+
+
+{ Prescan some rows of pixels.
+ In this module the prescan simply updates the histogram, which has been
+ initialized to zeroes by start_pass.
+ An output_buf parameter is required by the method signature, but no data
+ is actually output (in fact the buffer controller is probably passing a
+ NIL pointer). }
+
+{METHODDEF}
+procedure prescan_quantize (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+var
+ cquantize : my_cquantize_ptr;
+ {register} ptr : RGBptr;
+ {register} histp : histptr;
+ {register} histogram : hist3d;
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+begin
+ cquantize := my_cquantize_ptr(cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+ width := cinfo^.output_width;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ ptr := RGBptr(input_buf^[row]);
+ for col := pred(width) downto 0 do
+ begin
+ { get pixel value and index into the histogram }
+ histp := @(histogram^[GETJSAMPLE(ptr^.r) shr C0_SHIFT]^
+ [GETJSAMPLE(ptr^.g) shr C1_SHIFT]
+ [GETJSAMPLE(ptr^.b) shr C2_SHIFT]);
+ { increment, check for overflow and undo increment if so. }
+ Inc(histp^);
+ if (histp^ <= 0) then
+ Dec(histp^);
+ Inc(ptr);
+ end;
+ end;
+end;
+
+{ Next we have the really interesting routines: selection of a colormap
+ given the completed histogram.
+ These routines work with a list of "boxes", each representing a rectangular
+ subset of the input color space (to histogram precision). }
+
+type
+ box = record
+ { The bounds of the box (inclusive); expressed as histogram indexes }
+ c0min, c0max : int;
+ c1min, c1max : int;
+ c2min, c2max : int;
+ { The volume (actually 2-norm) of the box }
+ volume : INT32;
+ { The number of nonzero histogram cells within this box }
+ colorcount : long;
+ end;
+
+type
+ jBoxList = 0..(MaxInt div SizeOf(box))-1;
+ box_field = array[jBoxlist] of box;
+ boxlistptr = ^box_field;
+ boxptr = ^box;
+
+{LOCAL}
+function find_biggest_color_pop (boxlist : boxlistptr; numboxes : int) : boxptr;
+{ Find the splittable box with the largest color population }
+{ Returns NIL if no splittable boxes remain }
+var
+ boxp : boxptr ; {register}
+ i : int; {register}
+ maxc : long; {register}
+ which : boxptr;
+begin
+ which := NIL;
+ boxp := @(boxlist^[0]);
+ maxc := 0;
+ for i := 0 to pred(numboxes) do
+ begin
+ if (boxp^.colorcount > maxc) and (boxp^.volume > 0) then
+ begin
+ which := boxp;
+ maxc := boxp^.colorcount;
+ end;
+ Inc(boxp);
+ end;
+ find_biggest_color_pop := which;
+end;
+
+
+{LOCAL}
+function find_biggest_volume (boxlist : boxlistptr; numboxes : int) : boxptr;
+{ Find the splittable box with the largest (scaled) volume }
+{ Returns NULL if no splittable boxes remain }
+var
+ {register} boxp : boxptr;
+ {register} i : int;
+ {register} maxv : INT32;
+ which : boxptr;
+begin
+ maxv := 0;
+ which := NIL;
+ boxp := @(boxlist^[0]);
+ for i := 0 to pred(numboxes) do
+ begin
+ if (boxp^.volume > maxv) then
+ begin
+ which := boxp;
+ maxv := boxp^.volume;
+ end;
+ Inc(boxp);
+ end;
+ find_biggest_volume := which;
+end;
+
+
+{LOCAL}
+procedure update_box (cinfo : j_decompress_ptr; var boxp : box);
+label
+ have_c0min, have_c0max,
+ have_c1min, have_c1max,
+ have_c2min, have_c2max;
+{ Shrink the min/max bounds of a box to enclose only nonzero elements, }
+{ and recompute its volume and population }
+var
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ histp : histptr;
+ c0,c1,c2 : int;
+ c0min,c0max,c1min,c1max,c2min,c2max : int;
+ dist0,dist1,dist2 : INT32;
+ ccount : long;
+begin
+ cquantize := my_cquantize_ptr(cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+
+ c0min := boxp.c0min; c0max := boxp.c0max;
+ c1min := boxp.c1min; c1max := boxp.c1max;
+ c2min := boxp.c2min; c2max := boxp.c2max;
+
+ if (c0max > c0min) then
+ for c0 := c0min to c0max do
+ for c1 := c1min to c1max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ if (histp^ <> 0) then
+ begin
+ c0min := c0;
+ boxp.c0min := c0min;
+ goto have_c0min;
+ end;
+ Inc(histp);
+ end;
+ end;
+ have_c0min:
+ if (c0max > c0min) then
+ for c0 := c0max downto c0min do
+ for c1 := c1min to c1max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ if ( histp^ <> 0) then
+ begin
+ c0max := c0;
+ boxp.c0max := c0;
+ goto have_c0max;
+ end;
+ Inc(histp);
+ end;
+ end;
+ have_c0max:
+ if (c1max > c1min) then
+ for c1 := c1min to c1max do
+ for c0 := c0min to c0max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ if (histp^ <> 0) then
+ begin
+ c1min := c1;
+ boxp.c1min := c1;
+ goto have_c1min;
+ end;
+ Inc(histp);
+ end;
+ end;
+ have_c1min:
+ if (c1max > c1min) then
+ for c1 := c1max downto c1min do
+ for c0 := c0min to c0max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ if (histp^ <> 0) then
+ begin
+ c1max := c1;
+ boxp.c1max := c1;
+ goto have_c1max;
+ end;
+ Inc(histp);
+ end;
+ end;
+ have_c1max:
+ if (c2max > c2min) then
+ for c2 := c2min to c2max do
+ for c0 := c0min to c0max do
+ begin
+ histp := @(histogram^[c0]^[c1min][c2]);
+ for c1 := c1min to c1max do
+ begin
+ if (histp^ <> 0) then
+ begin
+ c2min := c2;
+ boxp.c2min := c2min;
+ goto have_c2min;
+ end;
+ Inc(histp, HIST_C2_ELEMS);
+ end;
+ end;
+ have_c2min:
+ if (c2max > c2min) then
+ for c2 := c2max downto c2min do
+ for c0 := c0min to c0max do
+ begin
+ histp := @(histogram^[c0]^[c1min][c2]);
+ for c1 := c1min to c1max do
+ begin
+ if (histp^ <> 0) then
+ begin
+ c2max := c2;
+ boxp.c2max := c2max;
+ goto have_c2max;
+ end;
+ Inc(histp, HIST_C2_ELEMS);
+ end;
+ end;
+ have_c2max:
+
+ { Update box volume.
+ We use 2-norm rather than real volume here; this biases the method
+ against making long narrow boxes, and it has the side benefit that
+ a box is splittable iff norm > 0.
+ Since the differences are expressed in histogram-cell units,
+ we have to shift back to JSAMPLE units to get consistent distances;
+ after which, we scale according to the selected distance scale factors.}
+
+ dist0 := ((c0max - c0min) shl C0_SHIFT) * C0_SCALE;
+ dist1 := ((c1max - c1min) shl C1_SHIFT) * C1_SCALE;
+ dist2 := ((c2max - c2min) shl C2_SHIFT) * C2_SCALE;
+ boxp.volume := dist0*dist0 + dist1*dist1 + dist2*dist2;
+
+ { Now scan remaining volume of box and compute population }
+ ccount := 0;
+ for c0 := c0min to c0max do
+ for c1 := c1min to c1max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ if (histp^ <> 0) then
+ Inc(ccount);
+ Inc(histp);
+ end;
+ end;
+ boxp.colorcount := ccount;
+end;
+
+
+{LOCAL}
+function median_cut (cinfo : j_decompress_ptr; boxlist : boxlistptr;
+ numboxes : int; desired_colors : int) : int;
+{ Repeatedly select and split the largest box until we have enough boxes }
+var
+ n,lb : int;
+ c0,c1,c2,cmax : int;
+ {register} b1,b2 : boxptr;
+begin
+ while (numboxes < desired_colors) do
+ begin
+ { Select box to split.
+ Current algorithm: by population for first half, then by volume. }
+
+ if (numboxes*2 <= desired_colors) then
+ b1 := find_biggest_color_pop(boxlist, numboxes)
+ else
+ b1 := find_biggest_volume(boxlist, numboxes);
+
+ if (b1 = NIL) then { no splittable boxes left! }
+ break;
+ b2 := @(boxlist^[numboxes]); { where new box will go }
+ { Copy the color bounds to the new box. }
+ b2^.c0max := b1^.c0max; b2^.c1max := b1^.c1max; b2^.c2max := b1^.c2max;
+ b2^.c0min := b1^.c0min; b2^.c1min := b1^.c1min; b2^.c2min := b1^.c2min;
+ { Choose which axis to split the box on.
+ Current algorithm: longest scaled axis.
+ See notes in update_box about scaling distances. }
+
+ c0 := ((b1^.c0max - b1^.c0min) shl C0_SHIFT) * C0_SCALE;
+ c1 := ((b1^.c1max - b1^.c1min) shl C1_SHIFT) * C1_SCALE;
+ c2 := ((b1^.c2max - b1^.c2min) shl C2_SHIFT) * C2_SCALE;
+ { We want to break any ties in favor of green, then red, blue last.
+ This code does the right thing for R,G,B or B,G,R color orders only. }
+
+{$ifdef RGB_RED_IS_0}
+ cmax := c1; n := 1;
+ if (c0 > cmax) then
+ begin
+ cmax := c0;
+ n := 0;
+ end;
+ if (c2 > cmax) then
+ n := 2;
+{$else}
+ cmax := c1;
+ n := 1;
+ if (c2 > cmax) then
+ begin
+ cmax := c2;
+ n := 2;
+ end;
+ if (c0 > cmax) then
+ n := 0;
+{$endif}
+ { Choose split point along selected axis, and update box bounds.
+ Current algorithm: split at halfway point.
+ (Since the box has been shrunk to minimum volume,
+ any split will produce two nonempty subboxes.)
+ Note that lb value is max for lower box, so must be < old max. }
+
+ case n of
+ 0:begin
+ lb := (b1^.c0max + b1^.c0min) div 2;
+ b1^.c0max := lb;
+ b2^.c0min := lb+1;
+ end;
+ 1:begin
+ lb := (b1^.c1max + b1^.c1min) div 2;
+ b1^.c1max := lb;
+ b2^.c1min := lb+1;
+ end;
+ 2:begin
+ lb := (b1^.c2max + b1^.c2min) div 2;
+ b1^.c2max := lb;
+ b2^.c2min := lb+1;
+ end;
+ end;
+ { Update stats for boxes }
+ update_box(cinfo, b1^);
+ update_box(cinfo, b2^);
+ Inc(numboxes);
+ end;
+ median_cut := numboxes;
+end;
+
+
+{LOCAL}
+procedure compute_color (cinfo : j_decompress_ptr;
+ const boxp : box; icolor : int);
+{ Compute representative color for a box, put it in colormap[icolor] }
+var
+ { Current algorithm: mean weighted by pixels (not colors) }
+ { Note it is important to get the rounding correct! }
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ histp : histptr;
+ c0,c1,c2 : int;
+ c0min,c0max,c1min,c1max,c2min,c2max : int;
+ count : long;
+ total : long;
+ c0total : long;
+ c1total : long;
+ c2total : long;
+begin
+ cquantize := my_cquantize_ptr(cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+ total := 0;
+ c0total := 0;
+ c1total := 0;
+ c2total := 0;
+
+ c0min := boxp.c0min; c0max := boxp.c0max;
+ c1min := boxp.c1min; c1max := boxp.c1max;
+ c2min := boxp.c2min; c2max := boxp.c2max;
+
+ for c0 := c0min to c0max do
+ for c1 := c1min to c1max do
+ begin
+ histp := @(histogram^[c0]^[c1][c2min]);
+ for c2 := c2min to c2max do
+ begin
+ count := histp^;
+ Inc(histp);
+ if (count <> 0) then
+ begin
+ Inc(total, count);
+ Inc(c0total, ((c0 shl C0_SHIFT) + ((1 shl C0_SHIFT) shr 1)) * count);
+ Inc(c1total, ((c1 shl C1_SHIFT) + ((1 shl C1_SHIFT) shr 1)) * count);
+ Inc(c2total, ((c2 shl C2_SHIFT) + ((1 shl C2_SHIFT) shr 1)) * count);
+ end;
+ end;
+ end;
+
+ cinfo^.colormap^[0]^[icolor] := JSAMPLE ((c0total + (total shr 1)) div total);
+ cinfo^.colormap^[1]^[icolor] := JSAMPLE ((c1total + (total shr 1)) div total);
+ cinfo^.colormap^[2]^[icolor] := JSAMPLE ((c2total + (total shr 1)) div total);
+end;
+
+
+{LOCAL}
+procedure select_colors (cinfo : j_decompress_ptr; desired_colors : int);
+{ Master routine for color selection }
+var
+ boxlist : boxlistptr;
+ numboxes : int;
+ i : int;
+begin
+ { Allocate workspace for box list }
+ boxlist := boxlistptr(cinfo^.mem^.alloc_small(
+ j_common_ptr(cinfo), JPOOL_IMAGE, desired_colors * SIZEOF(box)));
+ { Initialize one box containing whole space }
+ numboxes := 1;
+ boxlist^[0].c0min := 0;
+ boxlist^[0].c0max := MAXJSAMPLE shr C0_SHIFT;
+ boxlist^[0].c1min := 0;
+ boxlist^[0].c1max := MAXJSAMPLE shr C1_SHIFT;
+ boxlist^[0].c2min := 0;
+ boxlist^[0].c2max := MAXJSAMPLE shr C2_SHIFT;
+ { Shrink it to actually-used volume and set its statistics }
+ update_box(cinfo, boxlist^[0]);
+ { Perform median-cut to produce final box list }
+ numboxes := median_cut(cinfo, boxlist, numboxes, desired_colors);
+ { Compute the representative color for each box, fill colormap }
+ for i := 0 to pred(numboxes) do
+ compute_color(cinfo, boxlist^[i], i);
+ cinfo^.actual_number_of_colors := numboxes;
+ {$IFDEF DEBUG}
+ TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_SELECTED, numboxes);
+ {$ENDIF}
+end;
+
+
+{ These routines are concerned with the time-critical task of mapping input
+ colors to the nearest color in the selected colormap.
+
+ We re-use the histogram space as an "inverse color map", essentially a
+ cache for the results of nearest-color searches. All colors within a
+ histogram cell will be mapped to the same colormap entry, namely the one
+ closest to the cell's center. This may not be quite the closest entry to
+ the actual input color, but it's almost as good. A zero in the cache
+ indicates we haven't found the nearest color for that cell yet; the array
+ is cleared to zeroes before starting the mapping pass. When we find the
+ nearest color for a cell, its colormap index plus one is recorded in the
+ cache for future use. The pass2 scanning routines call fill_inverse_cmap
+ when they need to use an unfilled entry in the cache.
+
+ Our method of efficiently finding nearest colors is based on the "locally
+ sorted search" idea described by Heckbert and on the incremental distance
+ calculation described by Spencer W. Thomas in chapter III.1 of Graphics
+ Gems II (James Arvo, ed. Academic Press, 1991). Thomas points out that
+ the distances from a given colormap entry to each cell of the histogram can
+ be computed quickly using an incremental method: the differences between
+ distances to adjacent cells themselves differ by a constant. This allows a
+ fairly fast implementation of the "brute force" approach of computing the
+ distance from every colormap entry to every histogram cell. Unfortunately,
+ it needs a work array to hold the best-distance-so-far for each histogram
+ cell (because the inner loop has to be over cells, not colormap entries).
+ The work array elements have to be INT32s, so the work array would need
+ 256Kb at our recommended precision. This is not feasible in DOS machines.
+
+ To get around these problems, we apply Thomas' method to compute the
+ nearest colors for only the cells within a small subbox of the histogram.
+ The work array need be only as big as the subbox, so the memory usage
+ problem is solved. Furthermore, we need not fill subboxes that are never
+ referenced in pass2; many images use only part of the color gamut, so a
+ fair amount of work is saved. An additional advantage of this
+ approach is that we can apply Heckbert's locality criterion to quickly
+ eliminate colormap entries that are far away from the subbox; typically
+ three-fourths of the colormap entries are rejected by Heckbert's criterion,
+ and we need not compute their distances to individual cells in the subbox.
+ The speed of this approach is heavily influenced by the subbox size: too
+ small means too much overhead, too big loses because Heckbert's criterion
+ can't eliminate as many colormap entries. Empirically the best subbox
+ size seems to be about 1/512th of the histogram (1/8th in each direction).
+
+ Thomas' article also describes a refined method which is asymptotically
+ faster than the brute-force method, but it is also far more complex and
+ cannot efficiently be applied to small subboxes. It is therefore not
+ useful for programs intended to be portable to DOS machines. On machines
+ with plenty of memory, filling the whole histogram in one shot with Thomas'
+ refined method might be faster than the present code --- but then again,
+ it might not be any faster, and it's certainly more complicated. }
+
+
+
+{ log2(histogram cells in update box) for each axis; this can be adjusted }
+const
+ BOX_C0_LOG = (HIST_C0_BITS-3);
+ BOX_C1_LOG = (HIST_C1_BITS-3);
+ BOX_C2_LOG = (HIST_C2_BITS-3);
+
+ BOX_C0_ELEMS = (1 shl BOX_C0_LOG); { # of hist cells in update box }
+ BOX_C1_ELEMS = (1 shl BOX_C1_LOG);
+ BOX_C2_ELEMS = (1 shl BOX_C2_LOG);
+
+ BOX_C0_SHIFT = (C0_SHIFT + BOX_C0_LOG);
+ BOX_C1_SHIFT = (C1_SHIFT + BOX_C1_LOG);
+ BOX_C2_SHIFT = (C2_SHIFT + BOX_C2_LOG);
+
+
+{ The next three routines implement inverse colormap filling. They could
+ all be folded into one big routine, but splitting them up this way saves
+ some stack space (the mindist[] and bestdist[] arrays need not coexist)
+ and may allow some compilers to produce better code by registerizing more
+ inner-loop variables. }
+
+{LOCAL}
+function find_nearby_colors (cinfo : j_decompress_ptr;
+ minc0 : int; minc1 : int; minc2 : int;
+ var colorlist : array of JSAMPLE) : int;
+{ Locate the colormap entries close enough to an update box to be candidates
+ for the nearest entry to some cell(s) in the update box. The update box
+ is specified by the center coordinates of its first cell. The number of
+ candidate colormap entries is returned, and their colormap indexes are
+ placed in colorlist[].
+ This routine uses Heckbert's "locally sorted search" criterion to select
+ the colors that need further consideration. }
+
+var
+ numcolors : int;
+ maxc0, maxc1, maxc2 : int;
+ centerc0, centerc1, centerc2 : int;
+ i, x, ncolors : int;
+ minmaxdist, min_dist, max_dist, tdist : INT32;
+ mindist : array[0..MAXNUMCOLORS-1] of INT32;
+ { min distance to colormap entry i }
+begin
+ numcolors := cinfo^.actual_number_of_colors;
+
+ { Compute true coordinates of update box's upper corner and center.
+ Actually we compute the coordinates of the center of the upper-corner
+ histogram cell, which are the upper bounds of the volume we care about.
+ Note that since ">>" rounds down, the "center" values may be closer to
+ min than to max; hence comparisons to them must be "<=", not "<". }
+
+ maxc0 := minc0 + ((1 shl BOX_C0_SHIFT) - (1 shl C0_SHIFT));
+ centerc0 := (minc0 + maxc0) shr 1;
+ maxc1 := minc1 + ((1 shl BOX_C1_SHIFT) - (1 shl C1_SHIFT));
+ centerc1 := (minc1 + maxc1) shr 1;
+ maxc2 := minc2 + ((1 shl BOX_C2_SHIFT) - (1 shl C2_SHIFT));
+ centerc2 := (minc2 + maxc2) shr 1;
+
+ { For each color in colormap, find:
+ 1. its minimum squared-distance to any point in the update box
+ (zero if color is within update box);
+ 2. its maximum squared-distance to any point in the update box.
+ Both of these can be found by considering only the corners of the box.
+ We save the minimum distance for each color in mindist[];
+ only the smallest maximum distance is of interest. }
+
+ minmaxdist := long($7FFFFFFF);
+
+ for i := 0 to pred(numcolors) do
+ begin
+ { We compute the squared-c0-distance term, then add in the other two. }
+ x := GETJSAMPLE(cinfo^.colormap^[0]^[i]);
+ if (x < minc0) then
+ begin
+ tdist := (x - minc0) * C0_SCALE;
+ min_dist := tdist*tdist;
+ tdist := (x - maxc0) * C0_SCALE;
+ max_dist := tdist*tdist;
+ end
+ else
+ if (x > maxc0) then
+ begin
+ tdist := (x - maxc0) * C0_SCALE;
+ min_dist := tdist*tdist;
+ tdist := (x - minc0) * C0_SCALE;
+ max_dist := tdist*tdist;
+ end
+ else
+ begin
+ { within cell range so no contribution to min_dist }
+ min_dist := 0;
+ if (x <= centerc0) then
+ begin
+ tdist := (x - maxc0) * C0_SCALE;
+ max_dist := tdist*tdist;
+ end
+ else
+ begin
+ tdist := (x - minc0) * C0_SCALE;
+ max_dist := tdist*tdist;
+ end;
+ end;
+
+ x := GETJSAMPLE(cinfo^.colormap^[1]^[i]);
+ if (x < minc1) then
+ begin
+ tdist := (x - minc1) * C1_SCALE;
+ Inc(min_dist, tdist*tdist);
+ tdist := (x - maxc1) * C1_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ if (x > maxc1) then
+ begin
+ tdist := (x - maxc1) * C1_SCALE;
+ Inc(min_dist, tdist*tdist);
+ tdist := (x - minc1) * C1_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ begin
+ { within cell range so no contribution to min_dist }
+ if (x <= centerc1) then
+ begin
+ tdist := (x - maxc1) * C1_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ begin
+ tdist := (x - minc1) * C1_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ end;
+
+ x := GETJSAMPLE(cinfo^.colormap^[2]^[i]);
+ if (x < minc2) then
+ begin
+ tdist := (x - minc2) * C2_SCALE;
+ Inc(min_dist, tdist*tdist);
+ tdist := (x - maxc2) * C2_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ if (x > maxc2) then
+ begin
+ tdist := (x - maxc2) * C2_SCALE;
+ Inc(min_dist, tdist*tdist);
+ tdist := (x - minc2) * C2_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ begin
+ { within cell range so no contribution to min_dist }
+ if (x <= centerc2) then
+ begin
+ tdist := (x - maxc2) * C2_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end
+ else
+ begin
+ tdist := (x - minc2) * C2_SCALE;
+ Inc(max_dist, tdist*tdist);
+ end;
+ end;
+
+ mindist[i] := min_dist; { save away the results }
+ if (max_dist < minmaxdist) then
+ minmaxdist := max_dist;
+ end;
+
+ { Now we know that no cell in the update box is more than minmaxdist
+ away from some colormap entry. Therefore, only colors that are
+ within minmaxdist of some part of the box need be considered. }
+
+ ncolors := 0;
+ for i := 0 to pred(numcolors) do
+ begin
+ if (mindist[i] <= minmaxdist) then
+ begin
+ colorlist[ncolors] := JSAMPLE(i);
+ Inc(ncolors);
+ end;
+ end;
+ find_nearby_colors := ncolors;
+end;
+
+
+{LOCAL}
+procedure find_best_colors (cinfo : j_decompress_ptr;
+ minc0 : int; minc1 : int; minc2 : int;
+ numcolors : int;
+ var colorlist : array of JSAMPLE;
+ var bestcolor : array of JSAMPLE);
+{ Find the closest colormap entry for each cell in the update box,
+ given the list of candidate colors prepared by find_nearby_colors.
+ Return the indexes of the closest entries in the bestcolor[] array.
+ This routine uses Thomas' incremental distance calculation method to
+ find the distance from a colormap entry to successive cells in the box. }
+const
+ { Nominal steps between cell centers ("x" in Thomas article) }
+ STEP_C0 = ((1 shl C0_SHIFT) * C0_SCALE);
+ STEP_C1 = ((1 shl C1_SHIFT) * C1_SCALE);
+ STEP_C2 = ((1 shl C2_SHIFT) * C2_SCALE);
+var
+ ic0, ic1, ic2 : int;
+ i, icolor : int;
+ {register} bptr : INT32PTR; { pointer into bestdist[] array }
+ cptr : JSAMPLE_PTR; { pointer into bestcolor[] array }
+ dist0, dist1 : INT32; { initial distance values }
+ {register} dist2 : INT32; { current distance in inner loop }
+ xx0, xx1 : INT32; { distance increments }
+ {register} xx2 : INT32;
+ inc0, inc1, inc2 : INT32; { initial values for increments }
+ { This array holds the distance to the nearest-so-far color for each cell }
+ bestdist : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of INT32;
+begin
+ { Initialize best-distance for each cell of the update box }
+ for i := BOX_C0_ELEMS*BOX_C1_ELEMS*BOX_C2_ELEMS-1 downto 0 do
+ bestdist[i] := $7FFFFFFF;
+
+ { For each color selected by find_nearby_colors,
+ compute its distance to the center of each cell in the box.
+ If that's less than best-so-far, update best distance and color number. }
+
+
+
+ for i := 0 to pred(numcolors) do
+ begin
+ icolor := GETJSAMPLE(colorlist[i]);
+ { Compute (square of) distance from minc0/c1/c2 to this color }
+ inc0 := (minc0 - GETJSAMPLE(cinfo^.colormap^[0]^[icolor])) * C0_SCALE;
+ dist0 := inc0*inc0;
+ inc1 := (minc1 - GETJSAMPLE(cinfo^.colormap^[1]^[icolor])) * C1_SCALE;
+ Inc(dist0, inc1*inc1);
+ inc2 := (minc2 - GETJSAMPLE(cinfo^.colormap^[2]^[icolor])) * C2_SCALE;
+ Inc(dist0, inc2*inc2);
+ { Form the initial difference increments }
+ inc0 := inc0 * (2 * STEP_C0) + STEP_C0 * STEP_C0;
+ inc1 := inc1 * (2 * STEP_C1) + STEP_C1 * STEP_C1;
+ inc2 := inc2 * (2 * STEP_C2) + STEP_C2 * STEP_C2;
+ { Now loop over all cells in box, updating distance per Thomas method }
+ bptr := @bestdist[0];
+ cptr := @bestcolor[0];
+ xx0 := inc0;
+ for ic0 := BOX_C0_ELEMS-1 downto 0 do
+ begin
+ dist1 := dist0;
+ xx1 := inc1;
+ for ic1 := BOX_C1_ELEMS-1 downto 0 do
+ begin
+ dist2 := dist1;
+ xx2 := inc2;
+ for ic2 := BOX_C2_ELEMS-1 downto 0 do
+ begin
+ if (dist2 < bptr^) then
+ begin
+ bptr^ := dist2;
+ cptr^ := JSAMPLE (icolor);
+ end;
+ Inc(dist2, xx2);
+ Inc(xx2, 2 * STEP_C2 * STEP_C2);
+ Inc(bptr);
+ Inc(cptr);
+ end;
+ Inc(dist1, xx1);
+ Inc(xx1, 2 * STEP_C1 * STEP_C1);
+ end;
+ Inc(dist0, xx0);
+ Inc(xx0, 2 * STEP_C0 * STEP_C0);
+ end;
+ end;
+end;
+
+
+{LOCAL}
+procedure fill_inverse_cmap (cinfo : j_decompress_ptr;
+ c0 : int; c1 : int; c2 : int);
+{ Fill the inverse-colormap entries in the update box that contains }
+{ histogram cell c0/c1/c2. (Only that one cell MUST be filled, but }
+{ we can fill as many others as we wish.) }
+var
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ minc0, minc1, minc2 : int; { lower left corner of update box }
+ ic0, ic1, ic2 : int;
+ {register} cptr : JSAMPLE_PTR; { pointer into bestcolor[] array }
+ {register} cachep : histptr; { pointer into main cache array }
+ { This array lists the candidate colormap indexes. }
+ colorlist : array[0..MAXNUMCOLORS-1] of JSAMPLE;
+ numcolors : int; { number of candidate colors }
+ { This array holds the actually closest colormap index for each cell. }
+ bestcolor : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of JSAMPLE;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+
+ { Convert cell coordinates to update box ID }
+ c0 := c0 shr BOX_C0_LOG;
+ c1 := c1 shr BOX_C1_LOG;
+ c2 := c2 shr BOX_C2_LOG;
+
+ { Compute true coordinates of update box's origin corner.
+ Actually we compute the coordinates of the center of the corner
+ histogram cell, which are the lower bounds of the volume we care about.}
+
+ minc0 := (c0 shl BOX_C0_SHIFT) + ((1 shl C0_SHIFT) shr 1);
+ minc1 := (c1 shl BOX_C1_SHIFT) + ((1 shl C1_SHIFT) shr 1);
+ minc2 := (c2 shl BOX_C2_SHIFT) + ((1 shl C2_SHIFT) shr 1);
+
+ { Determine which colormap entries are close enough to be candidates
+ for the nearest entry to some cell in the update box. }
+
+ numcolors := find_nearby_colors(cinfo, minc0, minc1, minc2, colorlist);
+
+ { Determine the actually nearest colors. }
+ find_best_colors(cinfo, minc0, minc1, minc2, numcolors, colorlist,
+ bestcolor);
+
+ { Save the best color numbers (plus 1) in the main cache array }
+ c0 := c0 shl BOX_C0_LOG; { convert ID back to base cell indexes }
+ c1 := c1 shl BOX_C1_LOG;
+ c2 := c2 shl BOX_C2_LOG;
+ cptr := @(bestcolor[0]);
+ for ic0 := 0 to pred(BOX_C0_ELEMS) do
+ for ic1 := 0 to pred(BOX_C1_ELEMS) do
+ begin
+ cachep := @(histogram^[c0+ic0]^[c1+ic1][c2]);
+ for ic2 := 0 to pred(BOX_C2_ELEMS) do
+ begin
+ cachep^ := histcell (GETJSAMPLE(cptr^) + 1);
+ Inc(cachep);
+ Inc(cptr);
+ end;
+ end;
+end;
+
+
+{ Map some rows of pixels to the output colormapped representation. }
+
+{METHODDEF}
+procedure pass2_no_dither (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ This version performs no dithering }
+var
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ {register} inptr : RGBptr;
+ outptr : JSAMPLE_PTR;
+ {register} cachep : histptr;
+ {register} c0, c1, c2 : int;
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+ width := cinfo^.output_width;
+
+ for row := 0 to pred(num_rows) do
+ begin
+ inptr := RGBptr(input_buf^[row]);
+ outptr := JSAMPLE_PTR(output_buf^[row]);
+ for col := pred(width) downto 0 do
+ begin
+ { get pixel value and index into the cache }
+ c0 := GETJSAMPLE(inptr^.r) shr C0_SHIFT;
+ c1 := GETJSAMPLE(inptr^.g) shr C1_SHIFT;
+ c2 := GETJSAMPLE(inptr^.b) shr C2_SHIFT;
+ Inc(inptr);
+ cachep := @(histogram^[c0]^[c1][c2]);
+ { If we have not seen this color before, find nearest colormap entry }
+ { and update the cache }
+ if (cachep^ = 0) then
+ fill_inverse_cmap(cinfo, c0,c1,c2);
+ { Now emit the colormap index for this cell }
+ outptr^ := JSAMPLE (cachep^ - 1);
+ Inc(outptr);
+ end;
+ end;
+end;
+
+
+{METHODDEF}
+procedure pass2_fs_dither (cinfo : j_decompress_ptr;
+ input_buf : JSAMPARRAY;
+ output_buf : JSAMPARRAY;
+ num_rows : int);
+{ This version performs Floyd-Steinberg dithering }
+var
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ {register} cur : LOCRGB_FSERROR; { current error or pixel value }
+ belowerr : LOCRGB_FSERROR; { error for pixel below cur }
+ bpreverr : LOCRGB_FSERROR; { error for below/prev col }
+ prev_errorptr,
+ {register} errorptr : RGB_FSERROR_PTR; { => fserrors[] at column before current }
+ inptr : RGBptr; { => current input pixel }
+ outptr : JSAMPLE_PTR; { => current output pixel }
+ cachep : histptr;
+ dir : int; { +1 or -1 depending on direction }
+ row : int;
+ col : JDIMENSION;
+ width : JDIMENSION;
+ range_limit : range_limit_table_ptr;
+ error_limit : error_limit_ptr;
+ colormap0 : JSAMPROW;
+ colormap1 : JSAMPROW;
+ colormap2 : JSAMPROW;
+ {register} pixcode : int;
+ {register} bnexterr, delta : LOCFSERROR;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+ width := cinfo^.output_width;
+ range_limit := cinfo^.sample_range_limit;
+ error_limit := cquantize^.error_limiter;
+ colormap0 := cinfo^.colormap^[0];
+ colormap1 := cinfo^.colormap^[1];
+ colormap2 := cinfo^.colormap^[2];
+
+ for row := 0 to pred(num_rows) do
+ begin
+ inptr := RGBptr(input_buf^[row]);
+ outptr := JSAMPLE_PTR(output_buf^[row]);
+ errorptr := RGB_FSERROR_PTR(cquantize^.fserrors); { => entry before first real column }
+ if (cquantize^.on_odd_row) then
+ begin
+ { work right to left in this row }
+ Inc(inptr, (width-1)); { so point to rightmost pixel }
+ Inc(outptr, width-1);
+ dir := -1;
+ Inc(errorptr, (width+1)); { => entry after last column }
+ cquantize^.on_odd_row := FALSE; { flip for next time }
+ end
+ else
+ begin
+ { work left to right in this row }
+ dir := 1;
+ cquantize^.on_odd_row := TRUE; { flip for next time }
+ end;
+
+ { Preset error values: no error propagated to first pixel from left }
+ cur.r := 0;
+ cur.g := 0;
+ cur.b := 0;
+ { and no error propagated to row below yet }
+ belowerr.r := 0;
+ belowerr.g := 0;
+ belowerr.b := 0;
+ bpreverr.r := 0;
+ bpreverr.g := 0;
+ bpreverr.b := 0;
+
+ for col := pred(width) downto 0 do
+ begin
+ prev_errorptr := errorptr;
+ Inc(errorptr, dir); { advance errorptr to current column }
+
+ { curN holds the error propagated from the previous pixel on the
+ current line. Add the error propagated from the previous line
+ to form the complete error correction term for this pixel, and
+ round the error term (which is expressed * 16) to an integer.
+ RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct
+ for either sign of the error value.
+ Note: prev_errorptr points to *previous* column's array entry. }
+
+ { Nomssi Note: Borland Pascal SHR is unsigned }
+ cur.r := (cur.r + errorptr^.r + 8) div 16;
+ cur.g := (cur.g + errorptr^.g + 8) div 16;
+ cur.b := (cur.b + errorptr^.b + 8) div 16;
+ { Limit the error using transfer function set by init_error_limit.
+ See comments with init_error_limit for rationale. }
+
+ cur.r := error_limit^[cur.r];
+ cur.g := error_limit^[cur.g];
+ cur.b := error_limit^[cur.b];
+ { Form pixel value + error, and range-limit to 0..MAXJSAMPLE.
+ The maximum error is +- MAXJSAMPLE (or less with error limiting);
+ this sets the required size of the range_limit array. }
+
+ Inc(cur.r, GETJSAMPLE(inptr^.r));
+ Inc(cur.g, GETJSAMPLE(inptr^.g));
+ Inc(cur.b, GETJSAMPLE(inptr^.b));
+
+ cur.r := GETJSAMPLE(range_limit^[cur.r]);
+ cur.g := GETJSAMPLE(range_limit^[cur.g]);
+ cur.b := GETJSAMPLE(range_limit^[cur.b]);
+ { Index into the cache with adjusted pixel value }
+ cachep := @(histogram^[cur.r shr C0_SHIFT]^
+ [cur.g shr C1_SHIFT][cur.b shr C2_SHIFT]);
+ { If we have not seen this color before, find nearest colormap }
+ { entry and update the cache }
+ if (cachep^ = 0) then
+ fill_inverse_cmap(cinfo, cur.r shr C0_SHIFT,
+ cur.g shr C1_SHIFT,
+ cur.b shr C2_SHIFT);
+ { Now emit the colormap index for this cell }
+
+ pixcode := cachep^ - 1;
+ outptr^ := JSAMPLE (pixcode);
+
+ { Compute representation error for this pixel }
+ Dec(cur.r, GETJSAMPLE(colormap0^[pixcode]));
+ Dec(cur.g, GETJSAMPLE(colormap1^[pixcode]));
+ Dec(cur.b, GETJSAMPLE(colormap2^[pixcode]));
+
+ { Compute error fractions to be propagated to adjacent pixels.
+ Add these into the running sums, and simultaneously shift the
+ next-line error sums left by 1 column. }
+
+ bnexterr := cur.r; { Process component 0 }
+ delta := cur.r * 2;
+ Inc(cur.r, delta); { form error * 3 }
+ prev_errorptr^.r := FSERROR (bpreverr.r + cur.r);
+ Inc(cur.r, delta); { form error * 5 }
+ bpreverr.r := belowerr.r + cur.r;
+ belowerr.r := bnexterr;
+ Inc(cur.r, delta); { form error * 7 }
+ bnexterr := cur.g; { Process component 1 }
+ delta := cur.g * 2;
+ Inc(cur.g, delta); { form error * 3 }
+ prev_errorptr^.g := FSERROR (bpreverr.g + cur.g);
+ Inc(cur.g, delta); { form error * 5 }
+ bpreverr.g := belowerr.g + cur.g;
+ belowerr.g := bnexterr;
+ Inc(cur.g, delta); { form error * 7 }
+ bnexterr := cur.b; { Process component 2 }
+ delta := cur.b * 2;
+ Inc(cur.b, delta); { form error * 3 }
+ prev_errorptr^.b := FSERROR (bpreverr.b + cur.b);
+ Inc(cur.b, delta); { form error * 5 }
+ bpreverr.b := belowerr.b + cur.b;
+ belowerr.b := bnexterr;
+ Inc(cur.b, delta); { form error * 7 }
+
+ { At this point curN contains the 7/16 error value to be propagated
+ to the next pixel on the current line, and all the errors for the
+ next line have been shifted over. We are therefore ready to move on.}
+
+ Inc(inptr, dir); { Advance pixel pointers to next column }
+ Inc(outptr, dir);
+ end;
+ { Post-loop cleanup: we must unload the final error values into the
+ final fserrors[] entry. Note we need not unload belowerrN because
+ it is for the dummy column before or after the actual array. }
+
+ errorptr^.r := FSERROR (bpreverr.r); { unload prev errs into array }
+ errorptr^.g := FSERROR (bpreverr.g);
+ errorptr^.b := FSERROR (bpreverr.b);
+ end;
+end;
+
+
+{ Initialize the error-limiting transfer function (lookup table).
+ The raw F-S error computation can potentially compute error values of up to
+ +- MAXJSAMPLE. But we want the maximum correction applied to a pixel to be
+ much less, otherwise obviously wrong pixels will be created. (Typical
+ effects include weird fringes at color-area boundaries, isolated bright
+ pixels in a dark area, etc.) The standard advice for avoiding this problem
+ is to ensure that the "corners" of the color cube are allocated as output
+ colors; then repeated errors in the same direction cannot cause cascading
+ error buildup. However, that only prevents the error from getting
+ completely out of hand; Aaron Giles reports that error limiting improves
+ the results even with corner colors allocated.
+ A simple clamping of the error values to about +- MAXJSAMPLE/8 works pretty
+ well, but the smoother transfer function used below is even better. Thanks
+ to Aaron Giles for this idea. }
+
+{LOCAL}
+procedure init_error_limit (cinfo : j_decompress_ptr);
+const
+ STEPSIZE = ((MAXJSAMPLE+1) div 16);
+{ Allocate and fill in the error_limiter table }
+var
+ cquantize : my_cquantize_ptr;
+ table : error_limit_ptr;
+ inp, out : int;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ table := error_limit_ptr (cinfo^.mem^.alloc_small
+ (j_common_ptr (cinfo), JPOOL_IMAGE, (MAXJSAMPLE*2+1) * SIZEOF(int)));
+ { not needed: Inc(table, MAXJSAMPLE);
+ so can index -MAXJSAMPLE .. +MAXJSAMPLE }
+ cquantize^.error_limiter := table;
+ { Map errors 1:1 up to +- MAXJSAMPLE/16 }
+ out := 0;
+ for inp := 0 to pred(STEPSIZE) do
+ begin
+ table^[inp] := out;
+ table^[-inp] := -out;
+ Inc(out);
+ end;
+ { Map errors 1:2 up to +- 3*MAXJSAMPLE/16 }
+ inp := STEPSIZE; { Nomssi: avoid problems with Delphi2 optimizer }
+ while (inp < STEPSIZE*3) do
+ begin
+ table^[inp] := out;
+ table^[-inp] := -out;
+ Inc(inp);
+ if Odd(inp) then
+ Inc(out);
+ end;
+ { Clamp the rest to final out value (which is (MAXJSAMPLE+1)/8) }
+ inp := STEPSIZE*3; { Nomssi: avoid problems with Delphi 2 optimizer }
+ while inp <= MAXJSAMPLE do
+ begin
+ table^[inp] := out;
+ table^[-inp] := -out;
+ Inc(inp);
+ end;
+end;
+
+{ Finish up at the end of each pass. }
+
+{METHODDEF}
+procedure finish_pass1 (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+
+ { Select the representative colors and fill in cinfo^.colormap }
+ cinfo^.colormap := cquantize^.sv_colormap;
+ select_colors(cinfo, cquantize^.desired);
+ { Force next pass to zero the color index table }
+ cquantize^.needs_zeroed := TRUE;
+end;
+
+
+{METHODDEF}
+procedure finish_pass2 (cinfo : j_decompress_ptr);
+begin
+ { no work }
+end;
+
+
+{ Initialize for each processing pass. }
+
+{METHODDEF}
+procedure start_pass_2_quant (cinfo : j_decompress_ptr;
+ is_pre_scan : boolean);
+var
+ cquantize : my_cquantize_ptr;
+ histogram : hist3d;
+ i : int;
+var
+ arraysize : size_t;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+ histogram := cquantize^.histogram;
+ { Only F-S dithering or no dithering is supported. }
+ { If user asks for ordered dither, give him F-S. }
+ if (cinfo^.dither_mode <> JDITHER_NONE) then
+ cinfo^.dither_mode := JDITHER_FS;
+
+ if (is_pre_scan) then
+ begin
+ { Set up method pointers }
+ cquantize^.pub.color_quantize := prescan_quantize;
+ cquantize^.pub.finish_pass := finish_pass1;
+ cquantize^.needs_zeroed := TRUE; { Always zero histogram }
+ end
+ else
+ begin
+ { Set up method pointers }
+ if (cinfo^.dither_mode = JDITHER_FS) then
+ cquantize^.pub.color_quantize := pass2_fs_dither
+ else
+ cquantize^.pub.color_quantize := pass2_no_dither;
+ cquantize^.pub.finish_pass := finish_pass2;
+
+ { Make sure color count is acceptable }
+ i := cinfo^.actual_number_of_colors;
+ if (i < 1) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, 1);
+ if (i > MAXNUMCOLORS) then
+ ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS);
+
+ if (cinfo^.dither_mode = JDITHER_FS) then
+ begin
+ arraysize := size_t ((cinfo^.output_width + 2) *
+ (3 * SIZEOF(FSERROR)));
+ { Allocate Floyd-Steinberg workspace if we didn't already. }
+ if (cquantize^.fserrors = NIL) then
+ cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large
+ (j_common_ptr(cinfo), JPOOL_IMAGE, arraysize));
+ { Initialize the propagated errors to zero. }
+ jzero_far(cquantize^.fserrors, arraysize);
+ { Make the error-limit table if we didn't already. }
+ if (cquantize^.error_limiter = NIL) then
+ init_error_limit(cinfo);
+ cquantize^.on_odd_row := FALSE;
+ end;
+
+ end;
+ { Zero the histogram or inverse color map, if necessary }
+ if (cquantize^.needs_zeroed) then
+ begin
+ for i := 0 to pred(HIST_C0_ELEMS) do
+ begin
+ jzero_far( histogram^[i],
+ HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell));
+ end;
+ cquantize^.needs_zeroed := FALSE;
+ end;
+end;
+
+
+{ Switch to a new external colormap between output passes. }
+
+{METHODDEF}
+procedure new_color_map_2_quant (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+begin
+ cquantize := my_cquantize_ptr (cinfo^.cquantize);
+
+ { Reset the inverse color map }
+ cquantize^.needs_zeroed := TRUE;
+end;
+
+
+{ Module initialization routine for 2-pass color quantization. }
+
+
+{GLOBAL}
+procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr);
+var
+ cquantize : my_cquantize_ptr;
+ i : int;
+var
+ desired : int;
+begin
+ cquantize := my_cquantize_ptr(
+ cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE,
+ SIZEOF(my_cquantizer)));
+ cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize);
+ cquantize^.pub.start_pass := start_pass_2_quant;
+ cquantize^.pub.new_color_map := new_color_map_2_quant;
+ cquantize^.fserrors := NIL; { flag optional arrays not allocated }
+ cquantize^.error_limiter := NIL;
+
+ { Make sure jdmaster didn't give me a case I can't handle }
+ if (cinfo^.out_color_components <> 3) then
+ ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL);
+
+ { Allocate the histogram/inverse colormap storage }
+ cquantize^.histogram := hist3d (cinfo^.mem^.alloc_small
+ (j_common_ptr (cinfo), JPOOL_IMAGE, HIST_C0_ELEMS * SIZEOF(hist2d)));
+ for i := 0 to pred(HIST_C0_ELEMS) do
+ begin
+ cquantize^.histogram^[i] := hist2d (cinfo^.mem^.alloc_large
+ (j_common_ptr (cinfo), JPOOL_IMAGE,
+ HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell)));
+ end;
+ cquantize^.needs_zeroed := TRUE; { histogram is garbage now }
+
+ { Allocate storage for the completed colormap, if required.
+ We do this now since it is FAR storage and may affect
+ the memory manager's space calculations. }
+
+ if (cinfo^.enable_2pass_quant) then
+ begin
+ { Make sure color count is acceptable }
+ desired := cinfo^.desired_number_of_colors;
+ { Lower bound on # of colors ... somewhat arbitrary as long as > 0 }
+ if (desired < 8) then
+ ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_FEW_COLORS, 8);
+ { Make sure colormap indexes can be represented by JSAMPLEs }
+ if (desired > MAXNUMCOLORS) then
+ ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS);
+ cquantize^.sv_colormap := cinfo^.mem^.alloc_sarray
+ (j_common_ptr (cinfo),JPOOL_IMAGE, JDIMENSION(desired), JDIMENSION(3));
+ cquantize^.desired := desired;
+ end
+ else
+ cquantize^.sv_colormap := NIL;
+
+ { Only F-S dithering or no dithering is supported. }
+ { If user asks for ordered dither, give him F-S. }
+ if (cinfo^.dither_mode <> JDITHER_NONE) then
+ cinfo^.dither_mode := JDITHER_FS;
+
+ { Allocate Floyd-Steinberg workspace if necessary.
+ This isn't really needed until pass 2, but again it is FAR storage.
+ Although we will cope with a later change in dither_mode,
+ we do not promise to honor max_memory_to_use if dither_mode changes. }
+
+ if (cinfo^.dither_mode = JDITHER_FS) then
+ begin
+ cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large
+ (j_common_ptr(cinfo), JPOOL_IMAGE,
+ size_t ((cinfo^.output_width + 2) * (3 * SIZEOF(FSERROR))) ) );
+ { Might as well create the error-limiting table too. }
+ init_error_limit(cinfo);
+ end;
+end;
+{ QUANT_2PASS_SUPPORTED }
+end.
diff --git a/src/lib/vampimg/JpegLib/imjutils.pas b/src/lib/vampimg/JpegLib/imjutils.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/JpegLib/readme.txt b/src/lib/vampimg/JpegLib/readme.txt
--- /dev/null
@@ -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
+_____________________________________________________________________________
diff --git a/src/lib/vampimg/ZLib/dzlib.pas b/src/lib/vampimg/ZLib/dzlib.pas
--- /dev/null
@@ -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 Byte;
+ 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 PAnsiChar = (
+ '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 Byte;
+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.
diff --git a/src/lib/vampimg/ZLib/imadler.pas b/src/lib/vampimg/ZLib/imadler.pas
--- /dev/null
@@ -0,0 +1,113 @@
+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.
diff --git a/src/lib/vampimg/ZLib/iminfblock.pas b/src/lib/vampimg/ZLib/iminfblock.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/ZLib/iminfcodes.pas b/src/lib/vampimg/ZLib/iminfcodes.pas
--- /dev/null
@@ -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 '+AnsiChar(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.
diff --git a/src/lib/vampimg/ZLib/iminffast.pas b/src/lib/vampimg/ZLib/iminffast.pas
--- /dev/null
@@ -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 '+AnsiChar(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 '+AnsiChar(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.
diff --git a/src/lib/vampimg/ZLib/iminftrees.pas b/src/lib/vampimg/ZLib/iminftrees.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/ZLib/iminfutil.pas b/src/lib/vampimg/ZLib/iminfutil.pas
--- /dev/null
@@ -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.
diff --git a/src/lib/vampimg/ZLib/impaszlib.pas b/src/lib/vampimg/ZLib/impaszlib.pas
--- /dev/null
@@ -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 : AnsiString);
+ {$ENDIF}
+
+ procedure Trace(x : AnsiString);
+ procedure Tracev(x : AnsiString);
+ procedure Tracevv(x : AnsiString);
+ procedure Tracevvv(x : AnsiString);
+ procedure Tracec(c : boolean; x : AnsiString);
+ procedure Tracecv(c : boolean; x : AnsiString);
+
+function zlibVersion : AnsiString;
+{ 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) : AnsiString;
+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: AnsiString;
+ Stream_size: LongInt): LongInt;
+function inflateInit_(var Stream: z_stream; const Version: AnsiString;
+ 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: AnsiString;
+ Stream_size: LongInt): LongInt;
+begin
+ Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size);
+end;
+
+function inflateInit_(var Stream: z_stream; const Version: AnsiString;
+ Stream_size: Longint): LongInt;
+begin
+ Result := imzinflate.inflateInit_(@Stream, Version, Stream_size);
+end;
+
+function zError(err : int) : AnsiString;
+begin
+ zError := z_errmsg[Z_NEED_DICT-err];
+end;
+
+function zlibVersion : AnsiString;
+begin
+ zlibVersion := ZLIB_VERSION;
+end;
+
+procedure z_error (m : AnsiString);
+begin
+ WriteLn(output, m);
+ Write('Zlib - Halt...');
+ ReadLn;
+ Halt(1);
+end;
+
+procedure Assert(cond : boolean; msg : AnsiString);
+begin
+ if not cond then
+ z_error(msg);
+end;
+
+procedure Trace(x : AnsiString);
+begin
+ WriteLn(x);
+end;
+
+procedure Tracev(x : AnsiString);
+begin
+ if (z_verbose>0) then
+ WriteLn(x);
+end;
+
+procedure Tracevv(x : AnsiString);
+begin
+ if (z_verbose>1) then
+ WriteLn(x);
+end;
+
+procedure Tracevvv(x : AnsiString);
+begin
+ if (z_verbose>2) then
+ WriteLn(x);
+end;
+
+procedure Tracec(c : boolean; x : AnsiString);
+begin
+ if (z_verbose>0) and (c) then
+ WriteLn(x);
+end;
+
+procedure Tracecv(c : boolean; x : AnsiString);
+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.
diff --git a/src/lib/vampimg/ZLib/imtrees.pas b/src/lib/vampimg/ZLib/imtrees.pas
--- /dev/null
@@ -0,0 +1,2249 @@
+Unit imtrees;
+
+{$T-}
+{$define ORG_DEBUG}
+{
+ trees.c -- output deflated data using Huffman coding
+ Copyright (C) 1995-1998 Jean-loup Gailly
+
+ Pascal tranlastion
+ Copyright (C) 1998 by Jacques Nomssi Nzali
+ For conditions of distribution and use, see copyright notice in readme.txt
+}
+
+{
+ * ALGORITHM
+ *
+ * The "deflation" process uses several Huffman trees. The more
+ * common source values are represented by shorter bit sequences.
+ *
+ * Each code tree is stored in a compressed form which is itself
+ * a Huffman encoding of the lengths of all the code strings (in
+ * ascending order by source values). The actual code strings are
+ * reconstructed from the lengths in the inflate process, as described
+ * in the deflate specification.
+ *
+ * REFERENCES
+ *
+ * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
+ * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
+ *
+ * Storer, James A.
+ * Data Compression: Methods and Theory, pp. 49-50.
+ * Computer Science Press, 1988. ISBN 0-7167-8156-5.
+ *
+ * Sedgewick, R.
+ * Algorithms, p290.
+ * Addison-Wesley, 1983. ISBN 0-201-06672-6.
+ }
+
+interface
+
+{$I imzconf.inc}
+
+uses
+ {$ifdef DEBUG}
+ SysUtils, strutils,
+ {$ENDIF}
+ imzutil, impaszlib;
+
+{ ===========================================================================
+ Internal compression state. }
+
+const
+ LENGTH_CODES = 29;
+{ number of length codes, not counting the special END_BLOCK code }
+
+ LITERALS = 256;
+{ number of literal bytes 0..255 }
+
+ L_CODES = (LITERALS+1+LENGTH_CODES);
+{ number of Literal or Length codes, including the END_BLOCK code }
+
+ D_CODES = 30;
+{ number of distance codes }
+
+ BL_CODES = 19;
+{ number of codes used to transfer the bit lengths }
+
+ HEAP_SIZE = (2*L_CODES+1);
+{ maximum heap size }
+
+ MAX_BITS = 15;
+{ All codes must not exceed MAX_BITS bits }
+
+const
+ INIT_STATE = 42;
+ BUSY_STATE = 113;
+ FINISH_STATE = 666;
+{ Stream status }
+
+
+{ Data structure describing a single value and its code string. }
+type
+ ct_data_ptr = ^ct_data;
+ ct_data = record
+ fc : record
+ case byte of
+ 0:(freq : ush); { frequency count }
+ 1:(code : ush); { bit string }
+ end;
+ dl : record
+ case byte of
+ 0:(dad : ush); { father node in Huffman tree }
+ 1:(len : ush); { length of bit string }
+ end;
+ end;
+
+{ Freq = fc.freq
+ Code = fc.code
+ Dad = dl.dad
+ Len = dl.len }
+
+type
+ ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree }
+ dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree }
+ htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths }
+ { generic tree type }
+ tree_type = array[0..(MaxInt div SizeOf(ct_data))-1] of ct_data;
+
+ tree_ptr = ^tree_type;
+ ltree_ptr = ^ltree_type;
+ dtree_ptr = ^dtree_type;
+ htree_ptr = ^htree_type;
+
+
+type
+ static_tree_desc_ptr = ^static_tree_desc;
+ static_tree_desc =
+ record
+ {const} static_tree : tree_ptr; { static tree or NIL }
+ {const} extra_bits : pzIntfArray; { extra bits for each code or NIL }
+ extra_base : int; { base index for extra_bits }
+ elems : int; { max number of elements in the tree }
+ max_length : int; { max bit length for the codes }
+ end;
+
+ tree_desc_ptr = ^tree_desc;
+ tree_desc = record
+ dyn_tree : tree_ptr; { the dynamic tree }
+ max_code : int; { largest code with non zero frequency }
+ stat_desc : static_tree_desc_ptr; { the corresponding static tree }
+ end;
+
+type
+ Pos = ush;
+ Posf = Pos; {FAR}
+ IPos = uInt;
+
+ pPosf = ^Posf;
+
+ zPosfArray = array[0..(MaxInt div SizeOf(Posf))-1] of Posf;
+ pzPosfArray = ^zPosfArray;
+
+{ A Pos is an index in the character window. We use short instead of int to
+ save space in the various tables. IPos is used only for parameter passing.}
+
+type
+ deflate_state_ptr = ^deflate_state;
+ deflate_state = record
+ strm : z_streamp; { pointer back to this zlib stream }
+ status : int; { as the name implies }
+ pending_buf : pzByteArray; { output still pending }
+ pending_buf_size : ulg; { size of pending_buf }
+ pending_out : pBytef; { next pending byte to output to the stream }
+ pending : int; { nb of bytes in the pending buffer }
+ noheader : int; { suppress zlib header and adler32 }
+ data_type : Byte; { UNKNOWN, BINARY or ASCII }
+ method : Byte; { STORED (for zip only) or DEFLATED }
+ last_flush : int; { value of flush param for previous deflate call }
+
+ { used by deflate.pas: }
+
+ w_size : uInt; { LZ77 window size (32K by default) }
+ w_bits : uInt; { log2(w_size) (8..16) }
+ w_mask : uInt; { w_size - 1 }
+
+ window : pzByteArray;
+ { Sliding window. Input bytes are read into the second half of the window,
+ and move to the first half later to keep a dictionary of at least wSize
+ bytes. With this organization, matches are limited to a distance of
+ wSize-MAX_MATCH bytes, but this ensures that IO is always
+ performed with a length multiple of the block size. Also, it limits
+ the window size to 64K, which is quite useful on MSDOS.
+ To do: use the user input buffer as sliding window. }
+
+ window_size : ulg;
+ { Actual size of window: 2*wSize, except when the user input buffer
+ is directly used as sliding window. }
+
+ prev : pzPosfArray;
+ { Link to older string with same hash index. To limit the size of this
+ array to 64K, this link is maintained only for the last 32K strings.
+ An index in this array is thus a window index modulo 32K. }
+
+ head : pzPosfArray; { Heads of the hash chains or NIL. }
+
+ ins_h : uInt; { hash index of string to be inserted }
+ hash_size : uInt; { number of elements in hash table }
+ hash_bits : uInt; { log2(hash_size) }
+ hash_mask : uInt; { hash_size-1 }
+
+ hash_shift : uInt;
+ { Number of bits by which ins_h must be shifted at each input
+ step. It must be such that after MIN_MATCH steps, the oldest
+ byte no longer takes part in the hash key, that is:
+ hash_shift * MIN_MATCH >= hash_bits }
+
+ block_start : long;
+ { Window position at the beginning of the current output block. Gets
+ negative when the window is moved backwards. }
+
+ match_length : uInt; { length of best match }
+ prev_match : IPos; { previous match }
+ match_available : boolean; { set if previous match exists }
+ strstart : uInt; { start of string to insert }
+ match_start : uInt; { start of matching string }
+ lookahead : uInt; { number of valid bytes ahead in window }
+
+ prev_length : uInt;
+ { Length of the best match at previous step. Matches not greater than this
+ are discarded. This is used in the lazy match evaluation. }
+
+ max_chain_length : uInt;
+ { To speed up deflation, hash chains are never searched beyond this
+ length. A higher limit improves compression ratio but degrades the
+ speed. }
+
+ { moved to the end because Borland Pascal won't accept the following:
+ max_lazy_match : uInt;
+ max_insert_length : uInt absolute max_lazy_match;
+ }
+
+ level : int; { compression level (1..9) }
+ strategy : int; { favor or force Huffman coding}
+
+ good_match : uInt;
+ { Use a faster search when the previous match is longer than this }
+
+ nice_match : int; { Stop searching when current match exceeds this }
+
+ { used by trees.pas: }
+ { Didn't use ct_data typedef below to supress compiler warning }
+ dyn_ltree : ltree_type; { literal and length tree }
+ dyn_dtree : dtree_type; { distance tree }
+ bl_tree : htree_type; { Huffman tree for bit lengths }
+
+ l_desc : tree_desc; { desc. for literal tree }
+ d_desc : tree_desc; { desc. for distance tree }
+ bl_desc : tree_desc; { desc. for bit length tree }
+
+ bl_count : array[0..MAX_BITS+1-1] of ush;
+ { number of codes at each bit length for an optimal tree }
+
+ heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees }
+ heap_len : int; { number of elements in the heap }
+ heap_max : int; { element of largest frequency }
+ { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
+ The same heap array is used to build all trees. }
+
+ depth : array[0..2*L_CODES+1-1] of uch;
+ { Depth of each subtree used as tie breaker for trees of equal frequency }
+
+
+ l_buf : puchfArray; { buffer for literals or lengths }
+
+ lit_bufsize : uInt;
+ { Size of match buffer for literals/lengths. There are 4 reasons for
+ limiting lit_bufsize to 64K:
+ - frequencies can be kept in 16 bit counters
+ - if compression is not successful for the first block, all input
+ data is still in the window so we can still emit a stored block even
+ when input comes from standard input. (This can also be done for
+ all blocks if lit_bufsize is not greater than 32K.)
+ - if compression is not successful for a file smaller than 64K, we can
+ even emit a stored file instead of a stored block (saving 5 bytes).
+ This is applicable only for zip (not gzip or zlib).
+ - creating new Huffman trees less frequently may not provide fast
+ adaptation to changes in the input data statistics. (Take for
+ example a binary file with poorly compressible code followed by
+ a highly compressible string table.) Smaller buffer sizes give
+ fast adaptation but have of course the overhead of transmitting
+ trees more frequently.
+ - I can't count above 4 }
+
+
+ last_lit : uInt; { running index in l_buf }
+
+ d_buf : pushfArray;
+ { Buffer for distances. To simplify the code, d_buf and l_buf have
+ the same number of elements. To use different lengths, an extra flag
+ array would be necessary. }
+
+ opt_len : ulg; { bit length of current block with optimal trees }
+ static_len : ulg; { bit length of current block with static trees }
+ compressed_len : ulg; { total bit length of compressed file }
+ matches : uInt; { number of string matches in current block }
+ last_eob_len : int; { bit length of EOB code for last block }
+
+{$ifdef DEBUG}
+ bits_sent : ulg; { bit length of the compressed data }
+{$endif}
+
+ bi_buf : ush;
+ { Output buffer. bits are inserted starting at the bottom (least
+ significant bits). }
+
+ bi_valid : int;
+ { Number of valid bits in bi_buf. All bits above the last valid bit
+ are always zero. }
+
+ case byte of
+ 0:(max_lazy_match : uInt);
+ { Attempt to find a better match only when the current match is strictly
+ smaller than this value. This mechanism is used only for compression
+ levels >= 4. }
+
+ 1:(max_insert_length : uInt);
+ { Insert new strings in the hash table only if the match length is not
+ greater than this length. This saves time but degrades compression.
+ max_insert_length is used only for compression levels <= 3. }
+ end;
+
+procedure _tr_init (var s : deflate_state);
+
+function _tr_tally (var s : deflate_state;
+ dist : unsigned;
+ lc : unsigned) : boolean;
+
+function _tr_flush_block (var s : deflate_state;
+ buf : pcharf;
+ stored_len : ulg;
+ eof : boolean) : ulg;
+
+procedure _tr_align(var s : deflate_state);
+
+procedure _tr_stored_block(var s : deflate_state;
+ buf : pcharf;
+ stored_len : ulg;
+ eof : boolean);
+
+implementation
+
+{ #define GEN_TREES_H }
+
+{$ifndef GEN_TREES_H}
+{ header created automatically with -DGEN_TREES_H }
+
+const
+ DIST_CODE_LEN = 512; { see definition of array dist_code below }
+
+{ The static literal tree. Since the bit lengths are imposed, there is no
+ need for the L_CODES extra codes used during heap construction. However
+ The codes 286 and 287 are needed to build a canonical tree (see _tr_init
+ below). }
+var
+ static_ltree : array[0..L_CODES+2-1] of ct_data = (
+{ fc:(freq, code) dl:(dad,len) }
+(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)),
+(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)),
+(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)),
+(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)),
+(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)),
+(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)),
+(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)),
+(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)),
+(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)),
+(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)),
+(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)),
+(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)),
+(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)),
+(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)),
+(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)),
+(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)),
+(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)),
+(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)),
+(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)),
+(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)),
+(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)),
+(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)),
+(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)),
+(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)),
+(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)),
+(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)),
+(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)),
+(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)),
+(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)),
+(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)),
+(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)),
+(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)),
+(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)),
+(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)),
+(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)),
+(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)),
+(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)),
+(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)),
+(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)),
+(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)),
+(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)),
+(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)),
+(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)),
+(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)),
+(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)),
+(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)),
+(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)),
+(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)),
+(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)),
+(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)),
+(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)),
+(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)),
+(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)),
+(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)),
+(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)),
+(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)),
+(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)),
+(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)),
+(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)),
+(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)),
+(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)),
+(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)),
+(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)),
+(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)),
+(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)),
+(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)),
+(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)),
+(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)),
+(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)),
+(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)),
+(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)),
+(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)),
+(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)),
+(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)),
+(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)),
+(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)),
+(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)),
+(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)),
+(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)),
+(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)),
+(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)),
+(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)),
+(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)),
+(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)),
+(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)),
+(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)),
+(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)),
+(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)),
+(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)),
+(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)),
+(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)),
+(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)),
+(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)),
+(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)),
+(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)),
+(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8))
+);
+
+
+{ The static distance tree. (Actually a trivial tree since all lens use
+ 5 bits.) }
+ static_dtree : array[0..D_CODES-1] of ct_data = (
+(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)),
+(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)),
+(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)),
+(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)),
+(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)),
+(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)),
+(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)),
+(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)),
+(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)),
+(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5))
+);
+
+{ Distance codes. The first 256 values correspond to the distances
+ 3 .. 258, the last 256 values correspond to the top 8 bits of
+ the 15 bit distances. }
+ _dist_code : array[0..DIST_CODE_LEN-1] of uch = (
+ 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
+ 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,
+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,
+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
+);
+
+{ length code for each normalized match length (0 == MIN_MATCH) }
+ _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = (
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,
+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
+);
+
+
+{ First normalized length for each code (0 = MIN_MATCH) }
+ base_length : array[0..LENGTH_CODES-1] of int = (
+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
+64, 80, 96, 112, 128, 160, 192, 224, 0
+);
+
+
+{ First normalized distance for each code (0 = distance of 1) }
+ base_dist : array[0..D_CODES-1] of int = (
+ 0, 1, 2, 3, 4, 6, 8, 12, 16, 24,
+ 32, 48, 64, 96, 128, 192, 256, 384, 512, 768,
+ 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576
+);
+{$endif}
+
+{ Output a byte on the stream.
+ IN assertion: there is enough room in pending_buf.
+macro put_byte(s, c)
+begin
+ s^.pending_buf^[s^.pending] := (c);
+ Inc(s^.pending);
+end
+}
+
+const
+ MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1);
+{ Minimum amount of lookahead, except at the end of the input file.
+ See deflate.c for comments about the MIN_MATCH+1. }
+
+{macro d_code(dist)
+ if (dist) < 256 then
+ := _dist_code[dist]
+ else
+ := _dist_code[256+((dist) shr 7)]);
+ Mapping from a distance to a distance code. dist is the distance - 1 and
+ must not have side effects. _dist_code[256] and _dist_code[257] are never
+ used. }
+
+{$ifndef ORG_DEBUG}
+{ Inline versions of _tr_tally for speed: }
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+ extern uch _length_code[];
+ extern uch _dist_code[];
+#else
+ extern const uch _length_code[];
+ extern const uch _dist_code[];
+#endif
+
+macro _tr_tally_lit(s, c, flush)
+var
+ cc : uch;
+begin
+ cc := (c);
+ s^.d_buf[s^.last_lit] := 0;
+ s^.l_buf[s^.last_lit] := cc;
+ Inc(s^.last_lit);
+ Inc(s^.dyn_ltree[cc].fc.Freq);
+ flush := (s^.last_lit = s^.lit_bufsize-1);
+end;
+
+macro _tr_tally_dist(s, distance, length, flush) \
+var
+ len : uch;
+ dist : ush;
+begin
+ len := (length);
+ dist := (distance);
+ s^.d_buf[s^.last_lit] := dist;
+ s^.l_buf[s^.last_lit] = len;
+ Inc(s^.last_lit);
+ Dec(dist);
+ Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq);
+ Inc(s^.dyn_dtree[d_code(dist)].Freq);
+ flush := (s^.last_lit = s^.lit_bufsize-1);
+end;
+
+{$endif}
+
+{ ===========================================================================
+ Constants }
+
+const
+ MAX_BL_BITS = 7;
+{ Bit length codes must not exceed MAX_BL_BITS bits }
+
+const
+ END_BLOCK = 256;
+{ end of block literal code }
+
+const
+ REP_3_6 = 16;
+{ repeat previous bit length 3-6 times (2 bits of repeat count) }
+
+const
+ REPZ_3_10 = 17;
+{ repeat a zero length 3-10 times (3 bits of repeat count) }
+
+const
+ REPZ_11_138 = 18;
+{ repeat a zero length 11-138 times (7 bits of repeat count) }
+
+{local}
+const
+ extra_lbits : array[0..LENGTH_CODES-1] of int
+ { extra bits for each length code }
+ = (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);
+
+{local}
+const
+ extra_dbits : array[0..D_CODES-1] of int
+ { extra bits for each distance code }
+ = (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);
+
+{local}
+const
+ extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code }
+ = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7);
+
+{local}
+const
+ bl_order : array[0..BL_CODES-1] of uch
+ = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15);
+{ The lengths of the bit length codes are sent in order of decreasing
+ probability, to avoid transmitting the lengths for unused bit length codes.
+ }
+
+const
+ Buf_size = (8 * 2*sizeof(uch));
+{ Number of bits used within bi_buf. (bi_buf might be implemented on
+ more than 16 bits on some systems.) }
+
+{ ===========================================================================
+ Local data. These are initialized only once. }
+
+
+{$ifdef GEN_TREES_H)}
+{ non ANSI compilers may not accept trees.h }
+
+const
+ DIST_CODE_LEN = 512; { see definition of array dist_code below }
+
+{local}
+var
+ static_ltree : array[0..L_CODES+2-1] of ct_data;
+{ The static literal tree. Since the bit lengths are imposed, there is no
+ need for the L_CODES extra codes used during heap construction. However
+ The codes 286 and 287 are needed to build a canonical tree (see _tr_init
+ below). }
+
+{local}
+ static_dtree : array[0..D_CODES-1] of ct_data;
+{ The static distance tree. (Actually a trivial tree since all codes use
+ 5 bits.) }
+
+ _dist_code : array[0..DIST_CODE_LEN-1] of uch;
+{ Distance codes. The first 256 values correspond to the distances
+ 3 .. 258, the last 256 values correspond to the top 8 bits of
+ the 15 bit distances. }
+
+ _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch;
+{ length code for each normalized match length (0 == MIN_MATCH) }
+
+{local}
+ base_length : array[0..LENGTH_CODES-1] of int;
+{ First normalized length for each code (0 = MIN_MATCH) }
+
+{local}
+ base_dist : array[0..D_CODES-1] of int;
+{ First normalized distance for each code (0 = distance of 1) }
+
+{$endif} { GEN_TREES_H }
+
+{local}
+const
+ static_l_desc : static_tree_desc =
+ (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data }
+ extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int }
+ extra_base: LITERALS+1;
+ elems: L_CODES;
+ max_length: MAX_BITS);
+
+{local}
+const
+ static_d_desc : static_tree_desc =
+ (static_tree: {tree_ptr}(@(static_dtree));
+ extra_bits: {pzIntfArray}(@(extra_dbits));
+ extra_base : 0;
+ elems: D_CODES;
+ max_length: MAX_BITS);
+
+{local}
+const
+ static_bl_desc : static_tree_desc =
+ (static_tree: {tree_ptr}(NIL);
+ extra_bits: {pzIntfArray}@(extra_blbits);
+ extra_base : 0;
+ elems: BL_CODES;
+ max_length: MAX_BL_BITS);
+
+(* ===========================================================================
+ Local (static) routines in this file. }
+
+procedure tr_static_init;
+procedure init_block(var deflate_state);
+procedure pqdownheap(var s : deflate_state;
+ var tree : ct_data;
+ k : int);
+procedure gen_bitlen(var s : deflate_state;
+ var desc : tree_desc);
+procedure gen_codes(var tree : ct_data;
+ max_code : int;
+ bl_count : pushf);
+procedure build_tree(var s : deflate_state;
+ var desc : tree_desc);
+procedure scan_tree(var s : deflate_state;
+ var tree : ct_data;
+ max_code : int);
+procedure send_tree(var s : deflate_state;
+ var tree : ct_data;
+ max_code : int);
+function build_bl_tree(var deflate_state) : int;
+procedure send_all_trees(var deflate_state;
+ lcodes : int;
+ dcodes : int;
+ blcodes : int);
+procedure compress_block(var s : deflate_state;
+ var ltree : ct_data;
+ var dtree : ct_data);
+procedure set_data_type(var s : deflate_state);
+function bi_reverse(value : unsigned;
+ length : int) : unsigned;
+procedure bi_windup(var deflate_state);
+procedure bi_flush(var deflate_state);
+procedure copy_block(var deflate_state;
+ buf : pcharf;
+ len : unsigned;
+ header : int);
+*)
+
+{$ifdef GEN_TREES_H}
+{local}
+procedure gen_trees_header;
+{$endif}
+
+(*
+{ ===========================================================================
+ Output a short LSB first on the stream.
+ IN assertion: there is enough room in pendingBuf. }
+
+macro put_short(s, w)
+begin
+ {put_byte(s, (uch)((w) & 0xff));}
+ s.pending_buf^[s.pending] := uch((w) and $ff);
+ Inc(s.pending);
+
+ {put_byte(s, (uch)((ush)(w) >> 8));}
+ s.pending_buf^[s.pending] := uch(ush(w) shr 8);;
+ Inc(s.pending);
+end
+*)
+
+{ ===========================================================================
+ Send a value on a given number of bits.
+ IN assertion: length <= 16 and value fits in length bits. }
+
+{$ifdef ORG_DEBUG}
+
+{local}
+procedure send_bits(var s : deflate_state;
+ value : int; { value to send }
+ length : int); { number of bits }
+begin
+ {$ifdef DEBUG}
+ Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value));
+ Assert((length > 0) and (length <= 15), 'invalid length');
+ Inc(s.bits_sent, ulg(length));
+ {$ENDIF}
+
+ { If not enough room in bi_buf, use (valid) bits from bi_buf and
+ (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
+ unused bits in value. }
+ {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF}
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
+ if (s.bi_valid > int(Buf_size) - length) then
+ begin
+ s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
+ {put_short(s, s.bi_buf);}
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
+ Inc(s.pending);
+
+ s.bi_buf := ush(value) shr (Buf_size - s.bi_valid);
+ Inc(s.bi_valid, length - Buf_size);
+ end
+ else
+ begin
+ s.bi_buf := s.bi_buf or int(value shl s.bi_valid);
+ Inc(s.bi_valid, length);
+ end;
+ {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF}
+ {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF}
+end;
+
+{$else} { !DEBUG }
+
+
+macro send_code(s, c, tree)
+begin
+ send_bits(s, tree[c].Code, tree[c].Len);
+ { Send a code of the given tree. c and tree must not have side effects }
+end
+
+macro send_bits(s, value, length) \
+begin int len := length;\
+ if (s^.bi_valid > (int)Buf_size - len) begin\
+ int val := value;\
+ s^.bi_buf |= (val << s^.bi_valid);\
+ {put_short(s, s.bi_buf);}
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
+ Inc(s.pending);
+
+ s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\
+ s^.bi_valid += len - Buf_size;\
+ end else begin\
+ s^.bi_buf |= (value) << s^.bi_valid;\
+ s^.bi_valid += len;\
+ end\
+end;
+{$endif} { DEBUG }
+
+{ ===========================================================================
+ Reverse the first len bits of a code, using straightforward code (a faster
+ method would use a table)
+ IN assertion: 1 <= len <= 15 }
+
+{local}
+function bi_reverse(code : unsigned; { the value to invert }
+ len : int) : unsigned; { its bit length }
+
+var
+ res : unsigned; {register}
+begin
+ res := 0;
+ repeat
+ res := res or (code and 1);
+ code := code shr 1;
+ res := res shl 1;
+ Dec(len);
+ until (len <= 0);
+ bi_reverse := res shr 1;
+end;
+
+{ ===========================================================================
+ Generate the codes for a given tree and bit counts (which need not be
+ optimal).
+ IN assertion: the array bl_count contains the bit length statistics for
+ the given tree and the field len is set for all tree elements.
+ OUT assertion: the field code is set for all tree elements of non
+ zero code length. }
+
+{local}
+procedure gen_codes(tree : tree_ptr; { the tree to decorate }
+ max_code : int; { largest code with non zero frequency }
+ var bl_count : array of ushf); { number of codes at each bit length }
+
+var
+ next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length }
+ code : ush; { running code value }
+ bits : int; { bit index }
+ n : int; { code index }
+var
+ len : int;
+begin
+ code := 0;
+
+ { The distribution counts are first used to generate the code values
+ without bit reversal. }
+
+ for bits := 1 to MAX_BITS do
+ begin
+ code := ((code + bl_count[bits-1]) shl 1);
+ next_code[bits] := code;
+ end;
+ { Check that the bit counts in bl_count are consistent. The last code
+ must be all ones. }
+
+ {$IFDEF DEBUG}
+ Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1,
+ 'inconsistent bit counts');
+ Tracev(#13'gen_codes: max_code '+IntToStr(max_code));
+ {$ENDIF}
+
+ for n := 0 to max_code do
+ begin
+ len := tree^[n].dl.Len;
+ if (len = 0) then
+ continue;
+ { Now reverse the bits }
+ tree^[n].fc.Code := bi_reverse(next_code[len], len);
+ Inc(next_code[len]);
+ {$ifdef DEBUG}
+ if (n>31) and (n<128) then
+ Tracecv(tree <> tree_ptr(@static_ltree),
+ (^M'n #'+IntToStr(n)+' '+AnsiChar(n)+' l '+IntToStr(len)+' c '+
+ IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))
+ else
+ Tracecv(tree <> tree_ptr(@static_ltree),
+ (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+
+ IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'));
+ {$ENDIF}
+ end;
+end;
+
+{ ===========================================================================
+ Genererate the file trees.h describing the static trees. }
+{$ifdef GEN_TREES_H}
+
+macro SEPARATOR(i, last, width)
+ if (i) = (last) then
+ ( ^M');'^M^M
+ else \
+ if (i) mod (width) = (width)-1 then
+ ','^M
+ else
+ ', '
+
+procedure gen_trees_header;
+var
+ header : system.text;
+ i : int;
+begin
+ system.assign(header, 'trees.inc');
+ {$I-}
+ ReWrite(header);
+ {$I+}
+ Assert (IOresult <> 0, 'Can''t open trees.h');
+ WriteLn(header,
+ '{ header created automatically with -DGEN_TREES_H }'^M);
+
+ WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := (');
+ for i := 0 to L_CODES+2-1 do
+ begin
+ WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code,
+ static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
+ end;
+
+ WriteLn(header, 'local const ct_data static_dtree[D_CODES] := (');
+ for i := 0 to D_CODES-1 do
+ begin
+ WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code,
+ static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
+ end;
+
+ WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := (');
+ for i := 0 to DIST_CODE_LEN-1 do
+ begin
+ WriteLn(header, '%2u%s', _dist_code[i],
+ SEPARATOR(i, DIST_CODE_LEN-1, 20));
+ end;
+
+ WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= (');
+ for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do
+ begin
+ WriteLn(header, '%2u%s', _length_code[i],
+ SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
+ end;
+
+ WriteLn(header, 'local const int base_length[LENGTH_CODES] := (');
+ for i := 0 to LENGTH_CODES-1 do
+ begin
+ WriteLn(header, '%1u%s', base_length[i],
+ SEPARATOR(i, LENGTH_CODES-1, 20));
+ end;
+
+ WriteLn(header, 'local const int base_dist[D_CODES] := (');
+ for i := 0 to D_CODES-1 do
+ begin
+ WriteLn(header, '%5u%s', base_dist[i],
+ SEPARATOR(i, D_CODES-1, 10));
+ end;
+
+ close(header);
+end;
+{$endif} { GEN_TREES_H }
+
+
+{ ===========================================================================
+ Initialize the various 'constant' tables. }
+
+{local}
+procedure tr_static_init;
+
+{$ifdef GEN_TREES_H}
+const
+ static_init_done : boolean = FALSE;
+var
+ n : int; { iterates over tree elements }
+ bits : int; { bit counter }
+ length : int; { length value }
+ code : int; { code value }
+ dist : int; { distance index }
+ bl_count : array[0..MAX_BITS+1-1] of ush;
+ { number of codes at each bit length for an optimal tree }
+begin
+ if (static_init_done) then
+ exit;
+
+ { Initialize the mapping length (0..255) -> length code (0..28) }
+ length := 0;
+ for code := 0 to LENGTH_CODES-1-1 do
+ begin
+ base_length[code] := length;
+ for n := 0 to (1 shl extra_lbits[code])-1 do
+ begin
+ _length_code[length] := uch(code);
+ Inc(length);
+ end;
+ end;
+ Assert (length = 256, 'tr_static_init: length <> 256');
+ { Note that the length 255 (match length 258) can be represented
+ in two different ways: code 284 + 5 bits or code 285, so we
+ overwrite length_code[255] to use the best encoding: }
+
+ _length_code[length-1] := uch(code);
+
+ { Initialize the mapping dist (0..32K) -> dist code (0..29) }
+ dist := 0;
+ for code := 0 to 16-1 do
+ begin
+ base_dist[code] := dist;
+ for n := 0 to (1 shl extra_dbits[code])-1 do
+ begin
+ _dist_code[dist] := uch(code);
+ Inc(dist);
+ end;
+ end;
+ Assert (dist = 256, 'tr_static_init: dist <> 256');
+ dist := dist shr 7; { from now on, all distances are divided by 128 }
+ for code := 16 to D_CODES-1 do
+ begin
+ base_dist[code] := dist shl 7;
+ for n := 0 to (1 shl (extra_dbits[code]-7))-1 do
+ begin
+ _dist_code[256 + dist] := uch(code);
+ Inc(dist);
+ end;
+ end;
+ Assert (dist = 256, 'tr_static_init: 256+dist <> 512');
+
+ { Construct the codes of the static literal tree }
+ for bits := 0 to MAX_BITS do
+ bl_count[bits] := 0;
+ n := 0;
+ while (n <= 143) do
+ begin
+ static_ltree[n].dl.Len := 8;
+ Inc(n);
+ Inc(bl_count[8]);
+ end;
+ while (n <= 255) do
+ begin
+ static_ltree[n].dl.Len := 9;
+ Inc(n);
+ Inc(bl_count[9]);
+ end;
+ while (n <= 279) do
+ begin
+ static_ltree[n].dl.Len := 7;
+ Inc(n);
+ Inc(bl_count[7]);
+ end;
+ while (n <= 287) do
+ begin
+ static_ltree[n].dl.Len := 8;
+ Inc(n);
+ Inc(bl_count[8]);
+ end;
+
+ { Codes 286 and 287 do not exist, but we must include them in the
+ tree construction to get a canonical Huffman tree (longest code
+ all ones) }
+
+ gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count);
+
+ { The static distance tree is trivial: }
+ for n := 0 to D_CODES-1 do
+ begin
+ static_dtree[n].dl.Len := 5;
+ static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5);
+ end;
+ static_init_done := TRUE;
+
+ gen_trees_header; { save to include file }
+{$else}
+begin
+{$endif} { GEN_TREES_H) }
+end;
+
+{ ===========================================================================
+ Initialize a new block. }
+{local}
+
+procedure init_block(var s : deflate_state);
+var
+ n : int; { iterates over tree elements }
+begin
+ { Initialize the trees. }
+ for n := 0 to L_CODES-1 do
+ s.dyn_ltree[n].fc.Freq := 0;
+ for n := 0 to D_CODES-1 do
+ s.dyn_dtree[n].fc.Freq := 0;
+ for n := 0 to BL_CODES-1 do
+ s.bl_tree[n].fc.Freq := 0;
+
+ s.dyn_ltree[END_BLOCK].fc.Freq := 1;
+ s.static_len := Long(0);
+ s.opt_len := Long(0);
+ s.matches := 0;
+ s.last_lit := 0;
+end;
+
+const
+ SMALLEST = 1;
+{ Index within the heap array of least frequent node in the Huffman tree }
+
+{ ===========================================================================
+ Initialize the tree data structures for a new zlib stream. }
+procedure _tr_init(var s : deflate_state);
+begin
+ tr_static_init;
+
+ s.compressed_len := Long(0);
+
+ s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree);
+ s.l_desc.stat_desc := @static_l_desc;
+
+ s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree);
+ s.d_desc.stat_desc := @static_d_desc;
+
+ s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree);
+ s.bl_desc.stat_desc := @static_bl_desc;
+
+ s.bi_buf := 0;
+ s.bi_valid := 0;
+ s.last_eob_len := 8; { enough lookahead for inflate }
+{$ifdef DEBUG}
+ s.bits_sent := Long(0);
+{$endif}
+
+ { Initialize the first block of the first file: }
+ init_block(s);
+end;
+
+{ ===========================================================================
+ Remove the smallest element from the heap and recreate the heap with
+ one less element. Updates heap and heap_len.
+
+macro pqremove(s, tree, top)
+begin
+ top := s.heap[SMALLEST];
+ s.heap[SMALLEST] := s.heap[s.heap_len];
+ Dec(s.heap_len);
+ pqdownheap(s, tree, SMALLEST);
+end
+}
+
+{ ===========================================================================
+ Compares to subtrees, using the tree depth as tie breaker when
+ the subtrees have equal frequency. This minimizes the worst case length.
+
+macro smaller(tree, n, m, depth)
+ ( (tree[n].Freq < tree[m].Freq) or
+ ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) )
+}
+
+{ ===========================================================================
+ Restore the heap property by moving down the tree starting at node k,
+ exchanging a node with the smallest of its two sons if necessary, stopping
+ when the heap property is re-established (each father smaller than its
+ two sons). }
+{local}
+
+procedure pqdownheap(var s : deflate_state;
+ var tree : tree_type; { the tree to restore }
+ k : int); { node to move down }
+var
+ v : int;
+ j : int;
+begin
+ v := s.heap[k];
+ j := k shl 1; { left son of k }
+ while (j <= s.heap_len) do
+ begin
+ { Set j to the smallest of the two sons: }
+ if (j < s.heap_len) and
+ {smaller(tree, s.heap[j+1], s.heap[j], s.depth)}
+ ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or
+ ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and
+ (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then
+ begin
+ Inc(j);
+ end;
+ { Exit if v is smaller than both sons }
+ if {(smaller(tree, v, s.heap[j], s.depth))}
+ ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or
+ ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and
+ (s.depth[v] <= s.depth[s.heap[j]])) ) then
+ break;
+ { Exchange v with the smallest son }
+ s.heap[k] := s.heap[j];
+ k := j;
+
+ { And continue down the tree, setting j to the left son of k }
+ j := j shl 1;
+ end;
+ s.heap[k] := v;
+end;
+
+{ ===========================================================================
+ Compute the optimal bit lengths for a tree and update the total bit length
+ for the current block.
+ IN assertion: the fields freq and dad are set, heap[heap_max] and
+ above are the tree nodes sorted by increasing frequency.
+ OUT assertions: the field len is set to the optimal bit length, the
+ array bl_count contains the frequencies for each bit length.
+ The length opt_len is updated; static_len is also updated if stree is
+ not null. }
+
+{local}
+procedure gen_bitlen(var s : deflate_state;
+ var desc : tree_desc); { the tree descriptor }
+var
+ tree : tree_ptr;
+ max_code : int;
+ stree : tree_ptr; {const}
+ extra : pzIntfArray; {const}
+ base : int;
+ max_length : int;
+ h : int; { heap index }
+ n, m : int; { iterate over the tree elements }
+ bits : int; { bit length }
+ xbits : int; { extra bits }
+ f : ush; { frequency }
+ overflow : int; { number of elements with bit length too large }
+begin
+ tree := desc.dyn_tree;
+ max_code := desc.max_code;
+ stree := desc.stat_desc^.static_tree;
+ extra := desc.stat_desc^.extra_bits;
+ base := desc.stat_desc^.extra_base;
+ max_length := desc.stat_desc^.max_length;
+ overflow := 0;
+
+ for bits := 0 to MAX_BITS do
+ s.bl_count[bits] := 0;
+
+ { In a first pass, compute the optimal bit lengths (which may
+ overflow in the case of the bit length tree). }
+
+ tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap }
+
+ for h := s.heap_max+1 to HEAP_SIZE-1 do
+ begin
+ n := s.heap[h];
+ bits := tree^[tree^[n].dl.Dad].dl.Len + 1;
+ if (bits > max_length) then
+ begin
+ bits := max_length;
+ Inc(overflow);
+ end;
+ tree^[n].dl.Len := ush(bits);
+ { We overwrite tree[n].dl.Dad which is no longer needed }
+
+ if (n > max_code) then
+ continue; { not a leaf node }
+
+ Inc(s.bl_count[bits]);
+ xbits := 0;
+ if (n >= base) then
+ xbits := extra^[n-base];
+ f := tree^[n].fc.Freq;
+ Inc(s.opt_len, ulg(f) * (bits + xbits));
+ if (stree <> NIL) then
+ Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits));
+ end;
+ if (overflow = 0) then
+ exit;
+ {$ifdef DEBUG}
+ Tracev(^M'bit length overflow');
+ {$endif}
+ { This happens for example on obj2 and pic of the Calgary corpus }
+
+ { Find the first bit length which could increase: }
+ repeat
+ bits := max_length-1;
+ while (s.bl_count[bits] = 0) do
+ Dec(bits);
+ Dec(s.bl_count[bits]); { move one leaf down the tree }
+ Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother }
+ Dec(s.bl_count[max_length]);
+ { The brother of the overflow item also moves one step up,
+ but this does not affect bl_count[max_length] }
+
+ Dec(overflow, 2);
+ until (overflow <= 0);
+
+ { Now recompute all bit lengths, scanning in increasing frequency.
+ h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
+ lengths instead of fixing only the wrong ones. This idea is taken
+ from 'ar' written by Haruhiko Okumura.) }
+ h := HEAP_SIZE; { Delphi3: compiler warning w/o this }
+ for bits := max_length downto 1 do
+ begin
+ n := s.bl_count[bits];
+ while (n <> 0) do
+ begin
+ Dec(h);
+ m := s.heap[h];
+ if (m > max_code) then
+ continue;
+ if (tree^[m].dl.Len <> unsigned(bits)) then
+ begin
+ {$ifdef DEBUG}
+ Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len)
+ +'.'+IntToStr(bits));
+ {$ENDIF}
+ Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len))
+ * long(tree^[m].fc.Freq) );
+ tree^[m].dl.Len := ush(bits);
+ end;
+ Dec(n);
+ end;
+ end;
+end;
+
+{ ===========================================================================
+ Construct one Huffman tree and assigns the code bit strings and lengths.
+ Update the total bit length for the current block.
+ IN assertion: the field freq is set for all tree elements.
+ OUT assertions: the fields len and code are set to the optimal bit length
+ and corresponding code. The length opt_len is updated; static_len is
+ also updated if stree is not null. The field max_code is set. }
+
+{local}
+procedure build_tree(var s : deflate_state;
+ var desc : tree_desc); { the tree descriptor }
+
+var
+ tree : tree_ptr;
+ stree : tree_ptr; {const}
+ elems : int;
+ n, m : int; { iterate over heap elements }
+ max_code : int; { largest code with non zero frequency }
+ node : int; { new node being created }
+begin
+ tree := desc.dyn_tree;
+ stree := desc.stat_desc^.static_tree;
+ elems := desc.stat_desc^.elems;
+ max_code := -1;
+
+ { Construct the initial heap, with least frequent element in
+ heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
+ heap[0] is not used. }
+ s.heap_len := 0;
+ s.heap_max := HEAP_SIZE;
+
+ for n := 0 to elems-1 do
+ begin
+ if (tree^[n].fc.Freq <> 0) then
+ begin
+ max_code := n;
+ Inc(s.heap_len);
+ s.heap[s.heap_len] := n;
+ s.depth[n] := 0;
+ end
+ else
+ begin
+ tree^[n].dl.Len := 0;
+ end;
+ end;
+
+ { The pkzip format requires that at least one distance code exists,
+ and that at least one bit should be sent even if there is only one
+ possible code. So to avoid special checks later on we force at least
+ two codes of non zero frequency. }
+
+ while (s.heap_len < 2) do
+ begin
+ Inc(s.heap_len);
+ if (max_code < 2) then
+ begin
+ Inc(max_code);
+ s.heap[s.heap_len] := max_code;
+ node := max_code;
+ end
+ else
+ begin
+ s.heap[s.heap_len] := 0;
+ node := 0;
+ end;
+ tree^[node].fc.Freq := 1;
+ s.depth[node] := 0;
+ Dec(s.opt_len);
+ if (stree <> NIL) then
+ Dec(s.static_len, stree^[node].dl.Len);
+ { node is 0 or 1 so it does not have extra bits }
+ end;
+ desc.max_code := max_code;
+
+ { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
+ establish sub-heaps of increasing lengths: }
+
+ for n := s.heap_len div 2 downto 1 do
+ pqdownheap(s, tree^, n);
+
+ { Construct the Huffman tree by repeatedly combining the least two
+ frequent nodes. }
+
+ node := elems; { next internal node of the tree }
+ repeat
+ {pqremove(s, tree, n);} { n := node of least frequency }
+ n := s.heap[SMALLEST];
+ s.heap[SMALLEST] := s.heap[s.heap_len];
+ Dec(s.heap_len);
+ pqdownheap(s, tree^, SMALLEST);
+
+ m := s.heap[SMALLEST]; { m := node of next least frequency }
+
+ Dec(s.heap_max);
+ s.heap[s.heap_max] := n; { keep the nodes sorted by frequency }
+ Dec(s.heap_max);
+ s.heap[s.heap_max] := m;
+
+ { Create a new node father of n and m }
+ tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq;
+ { maximum }
+ if (s.depth[n] >= s.depth[m]) then
+ s.depth[node] := uch (s.depth[n] + 1)
+ else
+ s.depth[node] := uch (s.depth[m] + 1);
+
+ tree^[m].dl.Dad := ush(node);
+ tree^[n].dl.Dad := ush(node);
+{$ifdef DUMP_BL_TREE}
+ if (tree = tree_ptr(@s.bl_tree)) then
+ begin
+ WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n,
+ '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')');
+ end;
+{$endif}
+ { and insert the new node in the heap }
+ s.heap[SMALLEST] := node;
+ Inc(node);
+ pqdownheap(s, tree^, SMALLEST);
+
+ until (s.heap_len < 2);
+
+ Dec(s.heap_max);
+ s.heap[s.heap_max] := s.heap[SMALLEST];
+
+ { At this point, the fields freq and dad are set. We can now
+ generate the bit lengths. }
+
+ gen_bitlen(s, desc);
+
+ { The field len is now set, we can generate the bit codes }
+ gen_codes (tree, max_code, s.bl_count);
+end;
+
+{ ===========================================================================
+ Scan a literal or distance tree to determine the frequencies of the codes
+ in the bit length tree. }
+
+{local}
+procedure scan_tree(var s : deflate_state;
+ var tree : array of ct_data; { the tree to be scanned }
+ max_code : int); { and its largest code of non zero frequency }
+var
+ n : int; { iterates over all tree elements }
+ prevlen : int; { last emitted length }
+ curlen : int; { length of current code }
+ nextlen : int; { length of next code }
+ count : int; { repeat count of the current code }
+ max_count : int; { max repeat count }
+ min_count : int; { min repeat count }
+begin
+ prevlen := -1;
+ nextlen := tree[0].dl.Len;
+ count := 0;
+ max_count := 7;
+ min_count := 4;
+
+ if (nextlen = 0) then
+ begin
+ max_count := 138;
+ min_count := 3;
+ end;
+ tree[max_code+1].dl.Len := ush($ffff); { guard }
+
+ for n := 0 to max_code do
+ begin
+ curlen := nextlen;
+ nextlen := tree[n+1].dl.Len;
+ Inc(count);
+ if (count < max_count) and (curlen = nextlen) then
+ continue
+ else
+ if (count < min_count) then
+ Inc(s.bl_tree[curlen].fc.Freq, count)
+ else
+ if (curlen <> 0) then
+ begin
+ if (curlen <> prevlen) then
+ Inc(s.bl_tree[curlen].fc.Freq);
+ Inc(s.bl_tree[REP_3_6].fc.Freq);
+ end
+ else
+ if (count <= 10) then
+ Inc(s.bl_tree[REPZ_3_10].fc.Freq)
+ else
+ Inc(s.bl_tree[REPZ_11_138].fc.Freq);
+
+ count := 0;
+ prevlen := curlen;
+ if (nextlen = 0) then
+ begin
+ max_count := 138;
+ min_count := 3;
+ end
+ else
+ if (curlen = nextlen) then
+ begin
+ max_count := 6;
+ min_count := 3;
+ end
+ else
+ begin
+ max_count := 7;
+ min_count := 4;
+ end;
+ end;
+end;
+
+{ ===========================================================================
+ Send a literal or distance tree in compressed form, using the codes in
+ bl_tree. }
+
+{local}
+procedure send_tree(var s : deflate_state;
+ var tree : array of ct_data; { the tree to be scanned }
+ max_code : int); { and its largest code of non zero frequency }
+
+var
+ n : int; { iterates over all tree elements }
+ prevlen : int; { last emitted length }
+ curlen : int; { length of current code }
+ nextlen : int; { length of next code }
+ count : int; { repeat count of the current code }
+ max_count : int; { max repeat count }
+ min_count : int; { min repeat count }
+begin
+ prevlen := -1;
+ nextlen := tree[0].dl.Len;
+ count := 0;
+ max_count := 7;
+ min_count := 4;
+
+ { tree[max_code+1].dl.Len := -1; } { guard already set }
+ if (nextlen = 0) then
+ begin
+ max_count := 138;
+ min_count := 3;
+ end;
+
+ for n := 0 to max_code do
+ begin
+ curlen := nextlen;
+ nextlen := tree[n+1].dl.Len;
+ Inc(count);
+ if (count < max_count) and (curlen = nextlen) then
+ continue
+ else
+ if (count < min_count) then
+ begin
+ repeat
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(curlen));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
+ Dec(count);
+ until (count = 0);
+ end
+ else
+ if (curlen <> 0) then
+ begin
+ if (curlen <> prevlen) then
+ begin
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(curlen));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len);
+ Dec(count);
+ end;
+ {$IFDEF DEBUG}
+ Assert((count >= 3) and (count <= 6), ' 3_6?');
+ {$ENDIF}
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(REP_3_6));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len);
+ send_bits(s, count-3, 2);
+ end
+ else
+ if (count <= 10) then
+ begin
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(REPZ_3_10));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len);
+ send_bits(s, count-3, 3);
+ end
+ else
+ begin
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(REPZ_11_138));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len);
+ send_bits(s, count-11, 7);
+ end;
+ count := 0;
+ prevlen := curlen;
+ if (nextlen = 0) then
+ begin
+ max_count := 138;
+ min_count := 3;
+ end
+ else
+ if (curlen = nextlen) then
+ begin
+ max_count := 6;
+ min_count := 3;
+ end
+ else
+ begin
+ max_count := 7;
+ min_count := 4;
+ end;
+ end;
+end;
+
+{ ===========================================================================
+ Construct the Huffman tree for the bit lengths and return the index in
+ bl_order of the last bit length code to send. }
+
+{local}
+function build_bl_tree(var s : deflate_state) : int;
+var
+ max_blindex : int; { index of last bit length code of non zero freq }
+begin
+ { Determine the bit length frequencies for literal and distance trees }
+ scan_tree(s, s.dyn_ltree, s.l_desc.max_code);
+ scan_tree(s, s.dyn_dtree, s.d_desc.max_code);
+
+ { Build the bit length tree: }
+ build_tree(s, s.bl_desc);
+ { opt_len now includes the length of the tree representations, except
+ the lengths of the bit lengths codes and the 5+5+4 bits for the counts. }
+
+ { Determine the number of bit length codes to send. The pkzip format
+ requires that at least 4 bit length codes be sent. (appnote.txt says
+ 3 but the actual value used is 4.) }
+
+ for max_blindex := BL_CODES-1 downto 3 do
+ begin
+ if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then
+ break;
+ end;
+ { Update opt_len to include the bit length tree and counts }
+ Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4);
+ {$ifdef DEBUG}
+ Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}');
+ {$ENDIF}
+
+ build_bl_tree := max_blindex;
+end;
+
+{ ===========================================================================
+ Send the header for a block using dynamic Huffman trees: the counts, the
+ lengths of the bit length codes, the literal tree and the distance tree.
+ IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. }
+
+{local}
+procedure send_all_trees(var s : deflate_state;
+ lcodes : int;
+ dcodes : int;
+ blcodes : int); { number of codes for each tree }
+var
+ rank : int; { index in bl_order }
+begin
+ {$IFDEF DEBUG}
+ Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4),
+ 'not enough codes');
+ Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES)
+ and (blcodes <= BL_CODES), 'too many codes');
+ Tracev(^M'bl counts: ');
+ {$ENDIF}
+ send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt }
+ send_bits(s, dcodes-1, 5);
+ send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt }
+ for rank := 0 to blcodes-1 do
+ begin
+ {$ifdef DEBUG}
+ Tracev(^M'bl code '+IntToStr(bl_order[rank]));
+ {$ENDIF}
+ send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3);
+ end;
+ {$ifdef DEBUG}
+ Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent));
+ {$ENDIF}
+
+ send_tree(s, s.dyn_ltree, lcodes-1); { literal tree }
+ {$ifdef DEBUG}
+ Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent));
+ {$ENDIF}
+
+ send_tree(s, s.dyn_dtree, dcodes-1); { distance tree }
+ {$ifdef DEBUG}
+ Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent));
+ {$ENDIF}
+end;
+
+{ ===========================================================================
+ Flush the bit buffer and align the output on a byte boundary }
+
+{local}
+procedure bi_windup(var s : deflate_state);
+begin
+ if (s.bi_valid > 8) then
+ begin
+ {put_short(s, s.bi_buf);}
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
+ Inc(s.pending);
+ end
+ else
+ if (s.bi_valid > 0) then
+ begin
+ {put_byte(s, (Byte)s^.bi_buf);}
+ s.pending_buf^[s.pending] := Byte(s.bi_buf);
+ Inc(s.pending);
+ end;
+ s.bi_buf := 0;
+ s.bi_valid := 0;
+{$ifdef DEBUG}
+ s.bits_sent := (s.bits_sent+7) and (not 7);
+{$endif}
+end;
+
+{ ===========================================================================
+ Copy a stored block, storing first the length and its
+ one's complement if requested. }
+
+{local}
+procedure copy_block(var s : deflate_state;
+ buf : pcharf; { the input data }
+ len : unsigned; { its length }
+ header : boolean); { true if block header must be written }
+begin
+ bi_windup(s); { align on byte boundary }
+ s.last_eob_len := 8; { enough lookahead for inflate }
+
+ if (header) then
+ begin
+ {put_short(s, (ush)len);}
+ s.pending_buf^[s.pending] := uch(ush(len) and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(len) shr 8);;
+ Inc(s.pending);
+ {put_short(s, (ush)~len);}
+ s.pending_buf^[s.pending] := uch(ush(not len) and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(not len) shr 8);;
+ Inc(s.pending);
+
+{$ifdef DEBUG}
+ Inc(s.bits_sent, 2*16);
+{$endif}
+ end;
+{$ifdef DEBUG}
+ Inc(s.bits_sent, ulg(len shl 3));
+{$endif}
+ while (len <> 0) do
+ begin
+ Dec(len);
+ {put_byte(s, *buf++);}
+ s.pending_buf^[s.pending] := buf^;
+ Inc(buf);
+ Inc(s.pending);
+ end;
+end;
+
+
+{ ===========================================================================
+ Send a stored block }
+
+procedure _tr_stored_block(var s : deflate_state;
+ buf : pcharf; { input block }
+ stored_len : ulg; { length of input block }
+ eof : boolean); { true if this is the last block for a file }
+
+begin
+ send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type }
+ s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7));
+ Inc(s.compressed_len, (stored_len + 4) shl 3);
+
+ copy_block(s, buf, unsigned(stored_len), TRUE); { with header }
+end;
+
+{ ===========================================================================
+ Flush the bit buffer, keeping at most 7 bits in it. }
+
+{local}
+procedure bi_flush(var s : deflate_state);
+begin
+ if (s.bi_valid = 16) then
+ begin
+ {put_short(s, s.bi_buf);}
+ s.pending_buf^[s.pending] := uch(s.bi_buf and $ff);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);;
+ Inc(s.pending);
+
+ s.bi_buf := 0;
+ s.bi_valid := 0;
+ end
+ else
+ if (s.bi_valid >= 8) then
+ begin
+ {put_byte(s, (Byte)s^.bi_buf);}
+ s.pending_buf^[s.pending] := Byte(s.bi_buf);
+ Inc(s.pending);
+
+ s.bi_buf := s.bi_buf shr 8;
+ Dec(s.bi_valid, 8);
+ end;
+end;
+
+
+{ ===========================================================================
+ Send one empty static block to give enough lookahead for inflate.
+ This takes 10 bits, of which 7 may remain in the bit buffer.
+ The current inflate code requires 9 bits of lookahead. If the
+ last two codes for the previous block (real code plus EOB) were coded
+ on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode
+ the last real code. In this case we send two empty static blocks instead
+ of one. (There are no problems if the previous block is stored or fixed.)
+ To simplify the code, we assume the worst case of last real code encoded
+ on one bit only. }
+
+procedure _tr_align(var s : deflate_state);
+begin
+ send_bits(s, STATIC_TREES shl 1, 3);
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));
+ {$ENDIF}
+ send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);
+ Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB }
+ bi_flush(s);
+ { Of the 10 bits for the empty block, we have already sent
+ (10 - bi_valid) bits. The lookahead for the last real code (before
+ the EOB of the previous block) was thus at least one plus the length
+ of the EOB plus what we have just sent of the empty static block. }
+ if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then
+ begin
+ send_bits(s, STATIC_TREES shl 1, 3);
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));
+ {$ENDIF}
+ send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len);
+ Inc(s.compressed_len, Long(10));
+ bi_flush(s);
+ end;
+ s.last_eob_len := 7;
+end;
+
+{ ===========================================================================
+ Set the data type to ASCII or BINARY, using a crude approximation:
+ binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise.
+ IN assertion: the fields freq of dyn_ltree are set and the total of all
+ frequencies does not exceed 64K (to fit in an int on 16 bit machines). }
+
+{local}
+procedure set_data_type(var s : deflate_state);
+var
+ n : int;
+ ascii_freq : unsigned;
+ bin_freq : unsigned;
+begin
+ n := 0;
+ ascii_freq := 0;
+ bin_freq := 0;
+
+ while (n < 7) do
+ begin
+ Inc(bin_freq, s.dyn_ltree[n].fc.Freq);
+ Inc(n);
+ end;
+ while (n < 128) do
+ begin
+ Inc(ascii_freq, s.dyn_ltree[n].fc.Freq);
+ Inc(n);
+ end;
+ while (n < LITERALS) do
+ begin
+ Inc(bin_freq, s.dyn_ltree[n].fc.Freq);
+ Inc(n);
+ end;
+ if (bin_freq > (ascii_freq shr 2)) then
+ s.data_type := Byte(Z_BINARY)
+ else
+ s.data_type := Byte(Z_ASCII);
+end;
+
+{ ===========================================================================
+ Send the block data compressed using the given Huffman trees }
+
+{local}
+procedure compress_block(var s : deflate_state;
+ var ltree : array of ct_data; { literal tree }
+ var dtree : array of ct_data); { distance tree }
+var
+ dist : unsigned; { distance of matched string }
+ lc : int; { match length or unmatched char (if dist == 0) }
+ lx : unsigned; { running index in l_buf }
+ code : unsigned; { the code to send }
+ extra : int; { number of extra bits to send }
+begin
+ lx := 0;
+ if (s.last_lit <> 0) then
+ repeat
+ dist := s.d_buf^[lx];
+ lc := s.l_buf^[lx];
+ Inc(lx);
+ if (dist = 0) then
+ begin
+ { send a literal byte }
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(lc));
+ Tracecv((lc > 31) and (lc < 128), ' '+AnsiChar(lc)+' ');
+ {$ENDIF}
+ send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len);
+ end
+ else
+ begin
+ { Here, lc is the match length - MIN_MATCH }
+ code := _length_code[lc];
+ { send the length code }
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(code+LITERALS+1));
+ {$ENDIF}
+ send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len);
+ extra := extra_lbits[code];
+ if (extra <> 0) then
+ begin
+ Dec(lc, base_length[code]);
+ send_bits(s, lc, extra); { send the extra length bits }
+ end;
+ Dec(dist); { dist is now the match distance - 1 }
+ {code := d_code(dist);}
+ if (dist < 256) then
+ code := _dist_code[dist]
+ else
+ code := _dist_code[256+(dist shr 7)];
+
+ {$IFDEF DEBUG}
+ Assert (code < D_CODES, 'bad d_code');
+ {$ENDIF}
+
+ { send the distance code }
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(code));
+ {$ENDIF}
+ send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len);
+ extra := extra_dbits[code];
+ if (extra <> 0) then
+ begin
+ Dec(dist, base_dist[code]);
+ send_bits(s, dist, extra); { send the extra distance bits }
+ end;
+ end; { literal or match pair ? }
+
+ { Check that the overlay between pending_buf and d_buf+l_buf is ok: }
+ {$IFDEF DEBUG}
+ Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow');
+ {$ENDIF}
+ until (lx >= s.last_lit);
+
+ {$ifdef DEBUG}
+ Tracevvv(#13'cd '+IntToStr(END_BLOCK));
+ {$ENDIF}
+ send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len);
+ s.last_eob_len := ltree[END_BLOCK].dl.Len;
+end;
+
+
+{ ===========================================================================
+ Determine the best encoding for the current block: dynamic trees, static
+ trees or store, and output the encoded block to the zip file. This function
+ returns the total compressed length for the file so far. }
+
+function _tr_flush_block (var s : deflate_state;
+ buf : pcharf; { input block, or NULL if too old }
+ stored_len : ulg; { length of input block }
+ eof : boolean) : ulg; { true if this is the last block for a file }
+var
+ opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes }
+ max_blindex : int; { index of last bit length code of non zero freq }
+begin
+ max_blindex := 0;
+
+ { Build the Huffman trees unless a stored block is forced }
+ if (s.level > 0) then
+ begin
+ { Check if the file is ascii or binary }
+ if (s.data_type = Z_UNKNOWN) then
+ set_data_type(s);
+
+ { Construct the literal and distance trees }
+ build_tree(s, s.l_desc);
+ {$ifdef DEBUG}
+ Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}');
+ {$ENDIF}
+
+ build_tree(s, s.d_desc);
+ {$ifdef DEBUG}
+ Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}');
+ {$ENDIF}
+ { At this point, opt_len and static_len are the total bit lengths of
+ the compressed block data, excluding the tree representations. }
+
+ { Build the bit length tree for the above two trees, and get the index
+ in bl_order of the last bit length code to send. }
+ max_blindex := build_bl_tree(s);
+
+ { Determine the best encoding. Compute first the block length in bytes}
+ opt_lenb := (s.opt_len+3+7) shr 3;
+ static_lenb := (s.static_len+3+7) shr 3;
+
+ {$ifdef DEBUG}
+ Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+
+ '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+
+ 's.last_lit}');
+ {$ENDIF}
+
+ if (static_lenb <= opt_lenb) then
+ opt_lenb := static_lenb;
+
+ end
+ else
+ begin
+ {$IFDEF DEBUG}
+ Assert(buf <> pcharf(NIL), 'lost buf');
+ {$ENDIF}
+ static_lenb := stored_len + 5;
+ opt_lenb := static_lenb; { force a stored block }
+ end;
+
+ { If compression failed and this is the first and last block,
+ and if the .zip file can be seeked (to rewrite the local header),
+ the whole file is transformed into a stored file: }
+
+{$ifdef STORED_FILE_OK}
+{$ifdef FORCE_STORED_FILE}
+ if eof and (s.compressed_len = Long(0)) then
+ begin { force stored file }
+{$else}
+ if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0))
+ and seekable()) do
+ begin
+{$endif}
+ { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: }
+ if (buf = pcharf(0)) then
+ error ('block vanished');
+
+ copy_block(buf, unsigned(stored_len), 0); { without header }
+ s.compressed_len := stored_len shl 3;
+ s.method := STORED;
+ end
+ else
+{$endif} { STORED_FILE_OK }
+
+{$ifdef FORCE_STORED}
+ if (buf <> pcharf(0)) then
+ begin { force stored block }
+{$else}
+ if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then
+ begin
+ { 4: two words for the lengths }
+{$endif}
+ { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE.
+ Otherwise we can't have processed more than WSIZE input bytes since
+ the last block flush, because compression would have been
+ successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
+ transform a block into a stored block. }
+
+ _tr_stored_block(s, buf, stored_len, eof);
+
+{$ifdef FORCE_STATIC}
+ end
+ else
+ if (static_lenb >= 0) then
+ begin { force static trees }
+{$else}
+ end
+ else
+ if (static_lenb = opt_lenb) then
+ begin
+{$endif}
+ send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3);
+ compress_block(s, static_ltree, static_dtree);
+ Inc(s.compressed_len, 3 + s.static_len);
+ end
+ else
+ begin
+ send_bits(s, (DYN_TREES shl 1)+ord(eof), 3);
+ send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1,
+ max_blindex+1);
+ compress_block(s, s.dyn_ltree, s.dyn_dtree);
+ Inc(s.compressed_len, 3 + s.opt_len);
+ end;
+ {$ifdef DEBUG}
+ Assert (s.compressed_len = s.bits_sent, 'bad compressed size');
+ {$ENDIF}
+ init_block(s);
+
+ if (eof) then
+ begin
+ bi_windup(s);
+ Inc(s.compressed_len, 7); { align on byte boundary }
+ end;
+ {$ifdef DEBUG}
+ Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+
+ 's.compressed_len-7*ord(eof)}');
+ {$ENDIF}
+
+ _tr_flush_block := s.compressed_len shr 3;
+end;
+
+
+{ ===========================================================================
+ Save the match info and tally the frequency counts. Return true if
+ the current block must be flushed. }
+
+function _tr_tally (var s : deflate_state;
+ dist : unsigned; { distance of matched string }
+ lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) }
+var
+ {$IFDEF DEBUG}
+ MAX_DIST : ush;
+ {$ENDIF}
+ code : ush;
+{$ifdef TRUNCATE_BLOCK}
+var
+ out_length : ulg;
+ in_length : ulg;
+ dcode : int;
+{$endif}
+begin
+ s.d_buf^[s.last_lit] := ush(dist);
+ s.l_buf^[s.last_lit] := uch(lc);
+ Inc(s.last_lit);
+ if (dist = 0) then
+ begin
+ { lc is the unmatched char }
+ Inc(s.dyn_ltree[lc].fc.Freq);
+ end
+ else
+ begin
+ Inc(s.matches);
+ { Here, lc is the match length - MIN_MATCH }
+ Dec(dist); { dist := match distance - 1 }
+
+ {macro d_code(dist)}
+ if (dist) < 256 then
+ code := _dist_code[dist]
+ else
+ code := _dist_code[256+(dist shr 7)];
+ {$IFDEF DEBUG}
+{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD)
+ In order to simplify the code, particularly on 16 bit machines, match
+ distances are limited to MAX_DIST instead of WSIZE. }
+ MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD);
+ Assert((dist < ush(MAX_DIST)) and
+ (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and
+ (ush(code) < ush(D_CODES)), '_tr_tally: bad match');
+ {$ENDIF}
+ Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq);
+ {s.dyn_dtree[d_code(dist)].Freq++;}
+ Inc(s.dyn_dtree[code].fc.Freq);
+ end;
+
+{$ifdef TRUNCATE_BLOCK}
+ { Try to guess if it is profitable to stop the current block here }
+ if (s.last_lit and $1fff = 0) and (s.level > 2) then
+ begin
+ { Compute an upper bound for the compressed length }
+ out_length := ulg(s.last_lit)*Long(8);
+ in_length := ulg(long(s.strstart) - s.block_start);
+ for dcode := 0 to D_CODES-1 do
+ begin
+ Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq *
+ (Long(5)+extra_dbits[dcode])) );
+ end;
+ out_length := out_length shr 3;
+ {$ifdef DEBUG}
+ Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) ');
+ { s.last_lit, in_length, out_length,
+ Long(100) - out_length*Long(100) div in_length)); }
+ {$ENDIF}
+ if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then
+ begin
+ _tr_tally := TRUE;
+ exit;
+ end;
+ end;
+{$endif}
+ _tr_tally := (s.last_lit = s.lit_bufsize-1);
+ { We avoid equality with lit_bufsize because of wraparound at 64K
+ on 16 bit machines and because stored blocks are restricted to
+ 64K-1 bytes. }
+end;
+
+end.
diff --git a/src/lib/vampimg/ZLib/imzconf.inc b/src/lib/vampimg/ZLib/imzconf.inc
--- /dev/null
@@ -0,0 +1,23 @@
+{ -------------------------------------------------------------------- }
+
+{$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}
+{ -------------------------------------------------------------------- }
diff --git a/src/lib/vampimg/ZLib/imzdeflate.pas b/src/lib/vampimg/ZLib/imzdeflate.pas
--- /dev/null
@@ -0,0 +1,2129 @@
+Unit imzdeflate;
+
+{ Orginal: deflate.h -- internal compression state
+ deflate.c -- compress data using the deflation algorithm
+ Copyright (C) 1995-1996 Jean-loup Gailly.
+
+ Pascal tranlastion
+ Copyright (C) 1998 by Jacques Nomssi Nzali
+ For conditions of distribution and use, see copyright notice in readme.txt
+}
+
+
+{ ALGORITHM
+
+ The "deflation" process depends on being able to identify portions
+ of the input text which are identical to earlier input (within a
+ sliding window trailing behind the input currently being processed).
+
+ The most straightforward technique turns out to be the fastest for
+ most input files: try all possible matches and select the longest.
+ The key feature of this algorithm is that insertions into the string
+ dictionary are very simple and thus fast, and deletions are avoided
+ completely. Insertions are performed at each input character, whereas
+ string matches are performed only when the previous match ends. So it
+ is preferable to spend more time in matches to allow very fast string
+ insertions and avoid deletions. The matching algorithm for small
+ strings is inspired from that of Rabin & Karp. A brute force approach
+ is used to find longer strings when a small match has been found.
+ A similar algorithm is used in comic (by Jan-Mark Wams) and freeze
+ (by Leonid Broukhis).
+ A previous version of this file used a more sophisticated algorithm
+ (by Fiala and Greene) which is guaranteed to run in linear amortized
+ time, but has a larger average cost, uses more memory and is patented.
+ However the F&G algorithm may be faster for some highly redundant
+ files if the parameter max_chain_length (described below) is too large.
+
+ ACKNOWLEDGEMENTS
+
+ The idea of lazy evaluation of matches is due to Jan-Mark Wams, and
+ I found it in 'freeze' written by Leonid Broukhis.
+ Thanks to many people for bug reports and testing.
+
+ REFERENCES
+
+ Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
+ Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
+
+ A description of the Rabin and Karp algorithm is given in the book
+ "Algorithms" by R. Sedgewick, Addison-Wesley, p252.
+
+ Fiala,E.R., and Greene,D.H.
+ Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595}
+
+interface
+
+{$I imzconf.inc}
+
+uses
+ imzutil, impaszlib;
+
+
+function deflateInit_(strm : z_streamp;
+ level : int;
+ const version : AnsiString;
+ stream_size : int) : int;
+
+
+function deflateInit (var strm : z_stream; level : int) : int;
+
+{ Initializes the internal stream state for compression. The fields
+ zalloc, zfree and opaque must be initialized before by the caller.
+ If zalloc and zfree are set to Z_NULL, deflateInit updates them to
+ use default allocation functions.
+
+ The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:
+ 1 gives best speed, 9 gives best compression, 0 gives no compression at
+ all (the input data is simply copied a block at a time).
+ Z_DEFAULT_COMPRESSION requests a default compromise between speed and
+ compression (currently equivalent to level 6).
+
+ deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if level is not a valid compression level,
+ Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible
+ with the version assumed by the caller (ZLIB_VERSION).
+ msg is set to null if there is no error message. deflateInit does not
+ perform any compression: this will be done by deflate(). }
+
+
+{EXPORT}
+function deflate (var strm : z_stream; flush : int) : int;
+
+{ Performs one or both of the following actions:
+
+ - Compress 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 and avail_in are updated and
+ processing will resume at this point for the next call of deflate().
+
+ - Provide more output starting at next_out and update next_out and avail_out
+ accordingly. This action is forced if the parameter flush is non zero.
+ Forcing flush frequently degrades the compression ratio, so this parameter
+ should be set only when necessary (in interactive applications).
+ Some output may be provided even if flush is not set.
+
+ Before the call of deflate(), the application should ensure that at least
+ one of the actions is possible, by providing more input and/or consuming
+ more output, and updating avail_in or avail_out accordingly; avail_out
+ should never be zero before the call. The application can consume the
+ compressed output when it wants, for example when the output buffer is full
+ (avail_out == 0), or after each call of deflate(). If deflate 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_PARTIAL_FLUSH, the current compression
+ block is terminated and flushed to the output buffer so that the
+ decompressor can get all input data available so far. For method 9, a future
+ variant on method 8, the current block will be flushed but not terminated.
+ Z_SYNC_FLUSH has the same effect as partial flush except that the compressed
+ output is byte aligned (the compressor can clear its internal bit buffer)
+ and the current block is always terminated; this can be useful if the
+ compressor has to be restarted from scratch after an interruption (in which
+ case the internal state of the compressor may be lost).
+ If flush is set to Z_FULL_FLUSH, the compression block is terminated, a
+ special marker is output and the compression dictionary is discarded; this
+ is useful to allow the decompressor to synchronize if one compressed block
+ has been damaged (see inflateSync below). Flushing degrades compression and
+ so should be used only when necessary. Using Z_FULL_FLUSH too often can
+ seriously degrade the compression. If deflate returns with avail_out == 0,
+ this function must be called again with the same value of the flush
+ parameter and more output space (updated avail_out), until the flush is
+ complete (deflate returns with non-zero avail_out).
+
+ If the parameter flush is set to Z_FINISH, all pending input is processed,
+ all pending output is flushed and deflate returns with Z_STREAM_END if there
+ was enough output space; if deflate returns with Z_OK, this function must be
+ called again with Z_FINISH and more output space (updated avail_out) but no
+ more input data, until it returns with Z_STREAM_END or an error. After
+ deflate has returned Z_STREAM_END, the only possible operations on the
+ stream are deflateReset or deflateEnd.
+
+ Z_FINISH can be used immediately after deflateInit if all the compression
+ is to be done in a single step. In this case, avail_out must be at least
+ 0.1% larger than avail_in plus 12 bytes. If deflate does not return
+ Z_STREAM_END, then it must be called again as described above.
+
+ deflate() may update data_type if it can make a good guess about
+ the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered
+ binary. This field is only for information purposes and does not affect
+ the compression algorithm in any manner.
+
+ deflate() returns Z_OK if some progress has been made (more input
+ processed or more output produced), Z_STREAM_END if all input has been
+ consumed and all output has been produced (only when flush is set to
+ Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example
+ if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. }
+
+
+function deflateEnd (var strm : 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.
+
+ deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the
+ stream state was inconsistent, Z_DATA_ERROR if the stream was freed
+ prematurely (some input or output was discarded). In the error case,
+ msg may be set but then points to a static string (which must not be
+ deallocated). }
+
+
+
+
+ { Advanced functions }
+
+{ The following functions are needed only in some special applications. }
+
+
+{EXPORT}
+function deflateInit2 (var strm : z_stream;
+ level : int;
+ method : int;
+ windowBits : int;
+ memLevel : int;
+ strategy : int) : int;
+
+{ This is another version of deflateInit with more compression options. The
+ fields next_in, zalloc, zfree and opaque must be initialized before by
+ the caller.
+
+ The method parameter is the compression method. It must be Z_DEFLATED in
+ this version of the library. (Method 9 will allow a 64K history buffer and
+ partial block flushes.)
+
+ The windowBits parameter is the base two logarithm of the window size
+ (the size of the history buffer). It should be in the range 8..15 for this
+ version of the library (the value 16 will be allowed for method 9). Larger
+ values of this parameter result in better compression at the expense of
+ memory usage. The default value is 15 if deflateInit is used instead.
+
+ The memLevel parameter specifies how much memory should be allocated
+ for the internal compression state. memLevel=1 uses minimum memory but
+ is slow and reduces compression ratio; memLevel=9 uses maximum memory
+ for optimal speed. The default value is 8. See zconf.h for total memory
+ usage as a function of windowBits and memLevel.
+
+ The strategy parameter is used to tune the compression algorithm. Use the
+ value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a
+ filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no
+ string match). Filtered data consists mostly of small values with a
+ somewhat random distribution. In this case, the compression algorithm is
+ tuned to compress them better. The effect of Z_FILTERED is to force more
+ Huffman coding and less string matching; it is somewhat intermediate
+ between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects
+ the compression ratio but not the correctness of the compressed output even
+ if it is not set appropriately.
+
+ If next_in is not null, the library will use this buffer to hold also
+ some history information; the buffer must either hold the entire input
+ data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in
+ is null, the library will allocate its own history buffer (and leave next_in
+ null). next_out need not be provided here but must be provided by the
+ application for the next call of deflate().
+
+ If the history buffer is provided by the application, next_in must
+ must never be changed by the application since the compressor maintains
+ information inside this buffer from call to call; the application
+ must provide more input only by increasing avail_in. next_in is always
+ reset by the library in this case.
+
+ deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was
+ not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as
+ an invalid method). msg is set to null if there is no error message.
+ deflateInit2 does not perform any compression: this will be done by
+ deflate(). }
+
+
+{EXPORT}
+function deflateSetDictionary (var strm : z_stream;
+ dictionary : pBytef; {const bytes}
+ dictLength : uint) : int;
+
+{ Initializes the compression dictionary (history buffer) from the given
+ byte sequence without producing any compressed output. This function must
+ be called immediately after deflateInit or deflateInit2, before any call
+ of deflate. The compressor and decompressor must use exactly the same
+ dictionary (see inflateSetDictionary).
+ The dictionary should consist of strings (byte sequences) that are likely
+ to be encountered later in the data to be compressed, with the most commonly
+ used strings preferably put towards the end of the dictionary. Using a
+ dictionary is most useful when the data to be compressed is short and
+ can be predicted with good accuracy; the data can then be compressed better
+ than with the default empty dictionary. In this version of the library,
+ only the last 32K bytes of the dictionary are used.
+ Upon return of this function, strm->adler is set to the Adler32 value
+ of the dictionary; the decompressor may later use this value to determine
+ which dictionary has been used by the compressor. (The Adler32 value
+ applies to the whole dictionary even if only a subset of the dictionary is
+ actually used by the compressor.)
+
+ deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a
+ parameter is invalid (such as NULL dictionary) or the stream state
+ is inconsistent (for example if deflate has already been called for this
+ stream). deflateSetDictionary does not perform any compression: this will
+ be done by deflate(). }
+
+{EXPORT}
+function deflateCopy (dest : z_streamp;
+ source : z_streamp) : int;
+
+{ Sets the destination stream as a complete copy of the source stream. If
+ the source stream is using an application-supplied history buffer, a new
+ buffer is allocated for the destination stream. The compressed output
+ buffer is always application-supplied. It's the responsibility of the
+ application to provide the correct values of next_out and avail_out for the
+ next call of deflate.
+
+ This function can be useful when several compression strategies will be
+ tried, for example when there are several ways of pre-processing the input
+ data with a filter. The streams that will be discarded should then be freed
+ by calling deflateEnd. Note that deflateCopy duplicates the internal
+ compression state which can be quite large, so this strategy is slow and
+ can consume lots of memory.
+
+ deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+ (such as zalloc being NULL). msg is left unchanged in both source and
+ destination. }
+
+{EXPORT}
+function deflateReset (var strm : z_stream) : int;
+
+{ This function is equivalent to deflateEnd followed by deflateInit,
+ but does not free and reallocate all the internal compression state.
+ The stream will keep the same compression level and any other attributes
+ that may have been set by deflateInit2.
+
+ deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being NIL). }
+
+
+{EXPORT}
+function deflateParams (var strm : z_stream; level : int; strategy : int) : int;
+
+{ Dynamically update the compression level and compression strategy.
+ This can be used to switch between compression and straight copy of
+ the input data, or to switch to a different kind of input data requiring
+ a different strategy. If the compression level is changed, the input
+ available so far is compressed with the old level (and may be flushed);
+ the new level will take effect only at the next call of deflate().
+
+ Before the call of deflateParams, the stream state must be set as for
+ a call of deflate(), since the currently available input may have to
+ be compressed and flushed. In particular, strm->avail_out must be non-zero.
+
+ deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source
+ stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR
+ if strm->avail_out was zero. }
+
+
+const
+ deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly ';
+
+{ 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. }
+
+implementation
+
+uses
+ imtrees, imadler;
+
+{ ===========================================================================
+ Function prototypes. }
+
+type
+ block_state = (
+ need_more, { block not completed, need more input or more output }
+ block_done, { block flush performed }
+ finish_started, { finish started, need only more output at next deflate }
+ finish_done); { finish done, accept no more input or output }
+
+{ Compression function. Returns the block state after the call. }
+type
+ compress_func = function(var s : deflate_state; flush : int) : block_state;
+
+{local}
+procedure fill_window(var s : deflate_state); forward;
+{local}
+function deflate_stored(var s : deflate_state; flush : int) : block_state; forward;
+{local}
+function deflate_fast(var s : deflate_state; flush : int) : block_state; forward;
+{local}
+function deflate_slow(var s : deflate_state; flush : int) : block_state; forward;
+{local}
+procedure lm_init(var s : deflate_state); forward;
+
+{local}
+procedure putShortMSB(var s : deflate_state; b : uInt); forward;
+{local}
+procedure flush_pending (var strm : z_stream); forward;
+{local}
+function read_buf(strm : z_streamp;
+ buf : pBytef;
+ size : unsigned) : int; forward;
+{$ifdef ASMV}
+procedure match_init; { asm code initialization }
+function longest_match(var deflate_state; cur_match : IPos) : uInt; forward;
+{$else}
+{local}
+function longest_match(var s : deflate_state; cur_match : IPos) : uInt;
+ forward;
+{$endif}
+
+{$ifdef DEBUG}
+{local}
+procedure check_match(var s : deflate_state;
+ start, match : IPos;
+ length : int); forward;
+{$endif}
+
+{ ==========================================================================
+ local data }
+
+const
+ ZNIL = 0;
+{ Tail of hash chains }
+
+const
+ TOO_FAR = 4096;
+{ Matches of length 3 are discarded if their distance exceeds TOO_FAR }
+
+const
+ MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1);
+{ Minimum amount of lookahead, except at the end of the input file.
+ See deflate.c for comments about the MIN_MATCH+1. }
+
+{macro MAX_DIST(var s : deflate_state) : uInt;
+begin
+ MAX_DIST := (s.w_size - MIN_LOOKAHEAD);
+end;
+ In order to simplify the code, particularly on 16 bit machines, match
+ distances are limited to MAX_DIST instead of WSIZE. }
+
+
+{ Values for max_lazy_match, good_match and max_chain_length, depending on
+ the desired pack level (0..9). The values given below have been tuned to
+ exclude worst case performance for pathological files. Better values may be
+ found for specific files. }
+
+type
+ config = record
+ good_length : ush; { reduce lazy search above this match length }
+ max_lazy : ush; { do not perform lazy search above this match length }
+ nice_length : ush; { quit search above this match length }
+ max_chain : ush;
+ func : compress_func;
+ end;
+
+{local}
+const
+ configuration_table : array[0..10-1] of config = (
+{ good lazy nice chain }
+{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only }
+{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches }
+{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast),
+{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast),
+
+{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches }
+{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow),
+{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow),
+{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow),
+{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow),
+{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression }
+
+{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4
+ For deflate_fast() (levels <= 3) good is ignored and lazy has a different
+ meaning. }
+
+const
+ EQUAL = 0;
+{ result of memcmp for equal strings }
+
+{ ==========================================================================
+ Update a hash value with the given input byte
+ IN assertion: all calls to to UPDATE_HASH are made with consecutive
+ input characters, so that a running hash key can be computed from the
+ previous key instead of complete recalculation each time.
+
+macro UPDATE_HASH(s,h,c)
+ h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask;
+}
+
+{ ===========================================================================
+ Insert string str in the dictionary and set match_head to the previous head
+ of the hash chain (the most recent string with same hash key). Return
+ the previous length of the hash chain.
+ If this file is compiled with -DFASTEST, the compression level is forced
+ to 1, and no hash chains are maintained.
+ IN assertion: all calls to to INSERT_STRING are made with consecutive
+ input characters and the first MIN_MATCH bytes of str are valid
+ (except for the last MIN_MATCH-1 bytes of the input file). }
+
+procedure INSERT_STRING(var s : deflate_state;
+ str : uInt;
+ var match_head : IPos);
+begin
+{$ifdef FASTEST}
+ {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])}
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor
+ (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask;
+ match_head := s.head[s.ins_h]
+ s.head[s.ins_h] := Pos(str);
+{$else}
+ {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])}
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor
+ (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask;
+
+ match_head := s.head^[s.ins_h];
+ s.prev^[(str) and s.w_mask] := match_head;
+ s.head^[s.ins_h] := Pos(str);
+{$endif}
+end;
+
+{ =========================================================================
+ Initialize the hash table (avoiding 64K overflow for 16 bit systems).
+ prev[] will be initialized on the fly.
+
+macro CLEAR_HASH(s)
+ s^.head[s^.hash_size-1] := ZNIL;
+ zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0]));
+}
+
+{ ======================================================================== }
+
+function deflateInit2_(var strm : z_stream;
+ level : int;
+ method : int;
+ windowBits : int;
+ memLevel : int;
+ strategy : int;
+ const version : AnsiString;
+ stream_size : int) : int;
+var
+ s : deflate_state_ptr;
+ noheader : int;
+
+ overlay : pushfArray;
+ { We overlay pending_buf and d_buf+l_buf. This works since the average
+ output size for (length,distance) codes is <= 24 bits. }
+begin
+ noheader := 0;
+ if (version = '') or (version[1] <> ZLIB_VERSION[1]) or
+ (stream_size <> sizeof(z_stream)) then
+ begin
+ deflateInit2_ := Z_VERSION_ERROR;
+ exit;
+ end;
+ {
+ if (strm = Z_NULL) then
+ begin
+ deflateInit2_ := Z_STREAM_ERROR;
+ exit;
+ end;
+ }
+ { SetLength(strm.msg, 255); }
+ strm.msg := '';
+ if not Assigned(strm.zalloc) then
+ begin
+ {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE}
+ strm.zalloc := zcalloc;
+ {$ENDIF}
+ strm.opaque := voidpf(0);
+ end;
+ if not Assigned(strm.zfree) then
+ {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE}
+ strm.zfree := zcfree;
+ {$ENDIF}
+
+ if (level = Z_DEFAULT_COMPRESSION) then
+ level := 6;
+{$ifdef FASTEST}
+ level := 1;
+{$endif}
+
+ if (windowBits < 0) then { undocumented feature: suppress zlib header }
+ begin
+ noheader := 1;
+ windowBits := -windowBits;
+ end;
+ if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED)
+ or (windowBits < 8) or (windowBits > 15) or (level < 0)
+ or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then
+ begin
+ deflateInit2_ := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state)));
+ if (s = Z_NULL) then
+ begin
+ deflateInit2_ := Z_MEM_ERROR;
+ exit;
+ end;
+ strm.state := pInternal_state(s);
+ s^.strm := @strm;
+
+ s^.noheader := noheader;
+ s^.w_bits := windowBits;
+ s^.w_size := 1 shl s^.w_bits;
+ s^.w_mask := s^.w_size - 1;
+
+ s^.hash_bits := memLevel + 7;
+ s^.hash_size := 1 shl s^.hash_bits;
+ s^.hash_mask := s^.hash_size - 1;
+ s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH);
+
+ s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte)));
+ s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos)));
+ s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos)));
+
+ s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default }
+
+ overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2));
+ s^.pending_buf := pzByteArray (overlay);
+ s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2));
+
+ if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL)
+ or (s^.pending_buf = Z_NULL) then
+ begin
+ {ERR_MSG(Z_MEM_ERROR);}
+ strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR];
+ deflateEnd (strm);
+ deflateInit2_ := Z_MEM_ERROR;
+ exit;
+ end;
+ s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] );
+ s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] );
+
+ s^.level := level;
+ s^.strategy := strategy;
+ s^.method := Byte(method);
+
+ deflateInit2_ := deflateReset(strm);
+end;
+
+{ ========================================================================= }
+
+function deflateInit2(var strm : z_stream;
+ level : int;
+ method : int;
+ windowBits : int;
+ memLevel : int;
+ strategy : int) : int;
+{ a macro }
+begin
+ deflateInit2 := deflateInit2_(strm, level, method, windowBits,
+ memLevel, strategy, ZLIB_VERSION, sizeof(z_stream));
+end;
+
+{ ========================================================================= }
+
+function deflateInit_(strm : z_streamp;
+ level : int;
+ const version : AnsiString;
+ stream_size : int) : int;
+begin
+ if (strm = Z_NULL) then
+ deflateInit_ := Z_STREAM_ERROR
+ else
+ deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS,
+ DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size);
+ { To do: ignore strm^.next_in if we use it as window }
+end;
+
+{ ========================================================================= }
+
+function deflateInit(var strm : z_stream; level : int) : int;
+{ deflateInit is a macro to allow checking the zlib version
+ and the compiler's view of z_stream: }
+begin
+ deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS,
+ DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream));
+end;
+
+{ ======================================================================== }
+function deflateSetDictionary (var strm : z_stream;
+ dictionary : pBytef;
+ dictLength : uInt) : int;
+var
+ s : deflate_state_ptr;
+ length : uInt;
+ n : uInt;
+ hash_head : IPos;
+var
+ MAX_DIST : uInt; {macro}
+begin
+ length := dictLength;
+ hash_head := 0;
+
+ if {(@strm = Z_NULL) or}
+ (strm.state = Z_NULL) or (dictionary = Z_NULL)
+ or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then
+ begin
+ deflateSetDictionary := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ s := deflate_state_ptr(strm.state);
+ strm.adler := adler32(strm.adler, dictionary, dictLength);
+
+ if (length < MIN_MATCH) then
+ begin
+ deflateSetDictionary := Z_OK;
+ exit;
+ end;
+ MAX_DIST := (s^.w_size - MIN_LOOKAHEAD);
+ if (length > MAX_DIST) then
+ begin
+ length := MAX_DIST;
+{$ifndef USE_DICT_HEAD}
+ Inc(dictionary, dictLength - length); { use the tail of the dictionary }
+{$endif}
+ end;
+
+ zmemcpy( pBytef(s^.window), dictionary, length);
+ s^.strstart := length;
+ s^.block_start := long(length);
+
+ { Insert all strings in the hash table (except for the last two bytes).
+ s^.lookahead stays null, so s^.ins_h will be recomputed at the next
+ call of fill_window. }
+
+ s^.ins_h := s^.window^[0];
+ {UPDATE_HASH(s, s^.ins_h, s^.window[1]);}
+ s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1]))
+ and s^.hash_mask;
+
+ for n := 0 to length - MIN_MATCH do
+ begin
+ INSERT_STRING(s^, n, hash_head);
+ end;
+ {if (hash_head <> 0) then
+ hash_head := 0; - to make compiler happy }
+ deflateSetDictionary := Z_OK;
+end;
+
+{ ======================================================================== }
+function deflateReset (var strm : z_stream) : int;
+var
+ s : deflate_state_ptr;
+begin
+ if {(@strm = Z_NULL) or}
+ (strm.state = Z_NULL)
+ or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then
+ begin
+ deflateReset := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ strm.total_out := 0;
+ strm.total_in := 0;
+ strm.msg := ''; { use zfree if we ever allocate msg dynamically }
+ strm.data_type := Z_UNKNOWN;
+
+ s := deflate_state_ptr(strm.state);
+ s^.pending := 0;
+ s^.pending_out := pBytef(s^.pending_buf);
+
+ if (s^.noheader < 0) then
+ begin
+ s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); }
+ end;
+ if s^.noheader <> 0 then
+ s^.status := BUSY_STATE
+ else
+ s^.status := INIT_STATE;
+ strm.adler := 1;
+ s^.last_flush := Z_NO_FLUSH;
+
+ _tr_init(s^);
+ lm_init(s^);
+
+ deflateReset := Z_OK;
+end;
+
+{ ======================================================================== }
+function deflateParams(var strm : z_stream;
+ level : int;
+ strategy : int) : int;
+var
+ s : deflate_state_ptr;
+ func : compress_func;
+ err : int;
+begin
+ err := Z_OK;
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then
+ begin
+ deflateParams := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ s := deflate_state_ptr(strm.state);
+
+ if (level = Z_DEFAULT_COMPRESSION) then
+ begin
+ level := 6;
+ end;
+ if (level < 0) or (level > 9) or (strategy < 0)
+ or (strategy > Z_HUFFMAN_ONLY) then
+ begin
+ deflateParams := Z_STREAM_ERROR;
+ exit;
+ end;
+ func := configuration_table[s^.level].func;
+
+ if (@func <> @configuration_table[level].func)
+ and (strm.total_in <> 0) then
+ begin
+ { Flush the last buffer: }
+ err := deflate(strm, Z_PARTIAL_FLUSH);
+ end;
+ if (s^.level <> level) then
+ begin
+ s^.level := level;
+ s^.max_lazy_match := configuration_table[level].max_lazy;
+ s^.good_match := configuration_table[level].good_length;
+ s^.nice_match := configuration_table[level].nice_length;
+ s^.max_chain_length := configuration_table[level].max_chain;
+ end;
+ s^.strategy := strategy;
+ deflateParams := err;
+end;
+
+{ =========================================================================
+ Put a short in the pending buffer. The 16-bit value is put in MSB order.
+ IN assertion: the stream state is correct and there is enough room in
+ pending_buf. }
+
+{local}
+procedure putShortMSB (var s : deflate_state; b : uInt);
+begin
+ s.pending_buf^[s.pending] := Byte(b shr 8);
+ Inc(s.pending);
+ s.pending_buf^[s.pending] := Byte(b and $ff);
+ Inc(s.pending);
+end;
+
+{ =========================================================================
+ Flush as much pending output as possible. All deflate() output goes
+ through this function so some applications may wish to modify it
+ to avoid allocating a large strm^.next_out buffer and copying into it.
+ (See also read_buf()). }
+
+{local}
+procedure flush_pending(var strm : z_stream);
+var
+ len : unsigned;
+ s : deflate_state_ptr;
+begin
+ s := deflate_state_ptr(strm.state);
+ len := s^.pending;
+
+ if (len > strm.avail_out) then
+ len := strm.avail_out;
+ if (len = 0) then
+ exit;
+
+ zmemcpy(strm.next_out, s^.pending_out, len);
+ Inc(strm.next_out, len);
+ Inc(s^.pending_out, len);
+ Inc(strm.total_out, len);
+ Dec(strm.avail_out, len);
+ Dec(s^.pending, len);
+ if (s^.pending = 0) then
+ begin
+ s^.pending_out := pBytef(s^.pending_buf);
+ end;
+end;
+
+{ ========================================================================= }
+function deflate (var strm : z_stream; flush : int) : int;
+var
+ old_flush : int; { value of flush param for previous deflate call }
+ s : deflate_state_ptr;
+var
+ header : uInt;
+ level_flags : uInt;
+var
+ bstate : block_state;
+begin
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL)
+ or (flush > Z_FINISH) or (flush < 0) then
+ begin
+ deflate := Z_STREAM_ERROR;
+ exit;
+ end;
+ s := deflate_state_ptr(strm.state);
+
+ if (strm.next_out = Z_NULL) or
+ ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or
+ ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then
+ begin
+ {ERR_RETURN(strm^, Z_STREAM_ERROR);}
+ strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR];
+ deflate := Z_STREAM_ERROR;
+ exit;
+ end;
+ if (strm.avail_out = 0) then
+ begin
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];
+ deflate := Z_BUF_ERROR;
+ exit;
+ end;
+
+ s^.strm := @strm; { just in case }
+ old_flush := s^.last_flush;
+ s^.last_flush := flush;
+
+ { Write the zlib header }
+ if (s^.status = INIT_STATE) then
+ begin
+
+ header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8;
+ level_flags := (s^.level-1) shr 1;
+
+ if (level_flags > 3) then
+ level_flags := 3;
+ header := header or (level_flags shl 6);
+ if (s^.strstart <> 0) then
+ header := header or PRESET_DICT;
+ Inc(header, 31 - (header mod 31));
+
+ s^.status := BUSY_STATE;
+ putShortMSB(s^, header);
+
+ { Save the adler32 of the preset dictionary: }
+ if (s^.strstart <> 0) then
+ begin
+ putShortMSB(s^, uInt(strm.adler shr 16));
+ putShortMSB(s^, uInt(strm.adler and $ffff));
+ end;
+ strm.adler := long(1);
+ end;
+
+ { Flush as much pending output as possible }
+ if (s^.pending <> 0) then
+ begin
+ flush_pending(strm);
+ if (strm.avail_out = 0) then
+ begin
+ { Since avail_out is 0, deflate will be called again with
+ more output space, but possibly with both pending and
+ avail_in equal to zero. There won't be anything to do,
+ but this is not an error situation so make sure we
+ return OK instead of BUF_ERROR at next call of deflate: }
+
+ s^.last_flush := -1;
+ deflate := Z_OK;
+ exit;
+ end;
+
+ { Make sure there is something to do and avoid duplicate consecutive
+ flushes. For repeated and useless calls with Z_FINISH, we keep
+ returning Z_STREAM_END instead of Z_BUFF_ERROR. }
+
+ end
+ else
+ if (strm.avail_in = 0) and (flush <= old_flush)
+ and (flush <> Z_FINISH) then
+ begin
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];
+ deflate := Z_BUF_ERROR;
+ exit;
+ end;
+
+ { User must not provide more input after the first FINISH: }
+ if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then
+ begin
+ {ERR_RETURN(strm^, Z_BUF_ERROR);}
+ strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR];
+ deflate := Z_BUF_ERROR;
+ exit;
+ end;
+
+ { Start a new block or continue the current one. }
+ if (strm.avail_in <> 0) or (s^.lookahead <> 0)
+ or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then
+ begin
+ bstate := configuration_table[s^.level].func(s^, flush);
+
+ if (bstate = finish_started) or (bstate = finish_done) then
+ s^.status := FINISH_STATE;
+
+ if (bstate = need_more) or (bstate = finish_started) then
+ begin
+ if (strm.avail_out = 0) then
+ s^.last_flush := -1; { avoid BUF_ERROR next call, see above }
+
+ deflate := Z_OK;
+ exit;
+ { If flush != Z_NO_FLUSH && avail_out == 0, the next call
+ of deflate should use the same flush parameter to make sure
+ that the flush is complete. So we don't have to output an
+ empty block here, this will be done at next call. This also
+ ensures that for a very small output buffer, we emit at most
+ one empty block. }
+ end;
+ if (bstate = block_done) then
+ begin
+ if (flush = Z_PARTIAL_FLUSH) then
+ _tr_align(s^)
+ else
+ begin { FULL_FLUSH or SYNC_FLUSH }
+ _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE);
+ { For a full flush, this empty block will be recognized
+ as a special marker by inflate_sync(). }
+
+ if (flush = Z_FULL_FLUSH) then
+ begin
+ {macro CLEAR_HASH(s);} { forget history }
+ s^.head^[s^.hash_size-1] := ZNIL;
+ zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0]));
+ end;
+ end;
+
+ flush_pending(strm);
+ if (strm.avail_out = 0) then
+ begin
+ s^.last_flush := -1; { avoid BUF_ERROR at next call, see above }
+ deflate := Z_OK;
+ exit;
+ end;
+
+ end;
+ end;
+ {$IFDEF DEBUG}
+ Assert(strm.avail_out > 0, 'bug2');
+ {$ENDIF}
+ if (flush <> Z_FINISH) then
+ begin
+ deflate := Z_OK;
+ exit;
+ end;
+
+ if (s^.noheader <> 0) then
+ begin
+ deflate := Z_STREAM_END;
+ exit;
+ end;
+
+ { Write the zlib trailer (adler32) }
+ putShortMSB(s^, uInt(strm.adler shr 16));
+ putShortMSB(s^, uInt(strm.adler and $ffff));
+ flush_pending(strm);
+ { If avail_out is zero, the application will call deflate again
+ to flush the rest. }
+
+ s^.noheader := -1; { write the trailer only once! }
+ if s^.pending <> 0 then
+ deflate := Z_OK
+ else
+ deflate := Z_STREAM_END;
+end;
+
+{ ========================================================================= }
+function deflateEnd (var strm : z_stream) : int;
+var
+ status : int;
+ s : deflate_state_ptr;
+begin
+ if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then
+ begin
+ deflateEnd := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ s := deflate_state_ptr(strm.state);
+ status := s^.status;
+ if (status <> INIT_STATE) and (status <> BUSY_STATE) and
+ (status <> FINISH_STATE) then
+ begin
+ deflateEnd := Z_STREAM_ERROR;
+ exit;
+ end;
+
+ { Deallocate in reverse order of allocations: }
+ TRY_FREE(strm, s^.pending_buf);
+ TRY_FREE(strm, s^.head);
+ TRY_FREE(strm, s^.prev);
+ TRY_FREE(strm, s^.window);
+
+ ZFREE(strm, s);
+ strm.state := Z_NULL;
+
+ if status = BUSY_STATE then
+ deflateEnd := Z_DATA_ERROR
+ else
+ deflateEnd := Z_OK;
+end;
+
+{ =========================================================================
+ Copy the source state to the destination state.
+ To simplify the source, this is not supported for 16-bit MSDOS (which
+ doesn't have enough memory anyway to duplicate compression states). }
+
+
+{ ========================================================================= }
+function deflateCopy (dest, source : z_streamp) : int;
+{$ifndef MAXSEG_64K}
+var
+ ds : deflate_state_ptr;
+ ss : deflate_state_ptr;
+ overlay : pushfArray;
+{$endif}
+begin
+{$ifdef MAXSEG_64K}
+ deflateCopy := Z_STREAM_ERROR;
+ exit;
+{$else}
+
+ if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then
+ begin
+ deflateCopy := Z_STREAM_ERROR;
+ exit;
+ end;
+ ss := deflate_state_ptr(source^.state);
+ dest^ := source^;
+
+ ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) );
+ if (ds = Z_NULL) then
+ begin
+ deflateCopy := Z_MEM_ERROR;
+ exit;
+ end;
+ dest^.state := pInternal_state(ds);
+ ds^ := ss^;
+ ds^.strm := dest;
+
+ ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) );
+ ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) );
+ ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) );
+ overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) );
+ ds^.pending_buf := pzByteArray ( overlay );
+
+ if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL)
+ or (ds^.pending_buf = Z_NULL) then
+ begin
+ deflateEnd (dest^);
+ deflateCopy := Z_MEM_ERROR;
+ exit;
+ end;
+ { following zmemcpy do not work for 16-bit MSDOS }
+ zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte));
+ zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos));
+ zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos));
+ zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size));
+
+ ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)];
+ ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] );
+ ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]);
+
+ ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree);
+ ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree);
+ ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree);
+
+ deflateCopy := Z_OK;
+{$endif}
+end;
+
+
+{ ===========================================================================
+ Read a new buffer from the current input stream, update the adler32
+ and total number of bytes read. All deflate() input goes through
+ this function so some applications may wish to modify it to avoid
+ allocating a large strm^.next_in buffer and copying from it.
+ (See also flush_pending()). }
+
+{local}
+function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int;
+var
+ len : unsigned;
+begin
+ len := strm^.avail_in;
+
+ if (len > size) then
+ len := size;
+ if (len = 0) then
+ begin
+ read_buf := 0;
+ exit;
+ end;
+
+ Dec(strm^.avail_in, len);
+
+ if deflate_state_ptr(strm^.state)^.noheader = 0 then
+ begin
+ strm^.adler := adler32(strm^.adler, strm^.next_in, len);
+ end;
+ zmemcpy(buf, strm^.next_in, len);
+ Inc(strm^.next_in, len);
+ Inc(strm^.total_in, len);
+
+ read_buf := int(len);
+end;
+
+{ ===========================================================================
+ Initialize the "longest match" routines for a new zlib stream }
+
+{local}
+procedure lm_init (var s : deflate_state);
+begin
+ s.window_size := ulg( uLong(2)*s.w_size);
+
+ {macro CLEAR_HASH(s);}
+ s.head^[s.hash_size-1] := ZNIL;
+ zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0]));
+
+ { Set the default configuration parameters: }
+
+ s.max_lazy_match := configuration_table[s.level].max_lazy;
+ s.good_match := configuration_table[s.level].good_length;
+ s.nice_match := configuration_table[s.level].nice_length;
+ s.max_chain_length := configuration_table[s.level].max_chain;
+
+ s.strstart := 0;
+ s.block_start := long(0);
+ s.lookahead := 0;
+ s.prev_length := MIN_MATCH-1;
+ s.match_length := MIN_MATCH-1;
+ s.match_available := FALSE;
+ s.ins_h := 0;
+{$ifdef ASMV}
+ match_init; { initialize the asm code }
+{$endif}
+end;
+
+{ ===========================================================================
+ Set match_start to the longest match starting at the given string and
+ return its length. Matches shorter or equal to prev_length are discarded,
+ in which case the result is equal to prev_length and match_start is
+ garbage.
+ IN assertions: cur_match is the head of the hash chain for the current
+ string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1
+ OUT assertion: the match length is not greater than s^.lookahead. }
+
+
+{$ifndef ASMV}
+{ For 80x86 and 680x0, an optimized version will be provided in match.asm or
+ match.S. The code will be functionally equivalent. }
+
+{$ifndef FASTEST}
+
+{local}
+function longest_match(var s : deflate_state;
+ cur_match : IPos { current match }
+ ) : uInt;
+label
+ nextstep;
+var
+ chain_length : unsigned; { max hash chain length }
+ {register} scan : pBytef; { current string }
+ {register} match : pBytef; { matched string }
+ {register} len : int; { length of current match }
+ best_len : int; { best match length so far }
+ nice_match : int; { stop if match long enough }
+ limit : IPos;
+
+ prev : pzPosfArray;
+ wmask : uInt;
+{$ifdef UNALIGNED_OK}
+ {register} strend : pBytef;
+ {register} scan_start : ush;
+ {register} scan_end : ush;
+{$else}
+ {register} strend : pBytef;
+ {register} scan_end1 : Byte;
+ {register} scan_end : Byte;
+{$endif}
+var
+ MAX_DIST : uInt;
+begin
+ chain_length := s.max_chain_length; { max hash chain length }
+ scan := @(s.window^[s.strstart]);
+ best_len := s.prev_length; { best match length so far }
+ nice_match := s.nice_match; { stop if match long enough }
+
+
+ MAX_DIST := s.w_size - MIN_LOOKAHEAD;
+{In order to simplify the code, particularly on 16 bit machines, match
+distances are limited to MAX_DIST instead of WSIZE. }
+
+ if s.strstart > IPos(MAX_DIST) then
+ limit := s.strstart - IPos(MAX_DIST)
+ else
+ limit := ZNIL;
+ { Stop when cur_match becomes <= limit. To simplify the code,
+ we prevent matches with the string of window index 0. }
+
+ prev := s.prev;
+ wmask := s.w_mask;
+
+{$ifdef UNALIGNED_OK}
+ { Compare two bytes at a time. Note: this is not always beneficial.
+ Try with and without -DUNALIGNED_OK to check. }
+
+ strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1]));
+ scan_start := pushf(scan)^;
+ scan_end := pushfArray(scan)^[best_len-1]; { fix }
+{$else}
+ strend := pBytef(@(s.window^[s.strstart + MAX_MATCH]));
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
+ scan_end1 := pzByteArray(scan)^[best_len-1];
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}
+ scan_end := pzByteArray(scan)^[best_len];
+{$endif}
+
+ { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ It is easy to get rid of this optimization if necessary. }
+ {$IFDEF DEBUG}
+ Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever');
+ {$ENDIF}
+ { Do not waste too much time if we already have a good match: }
+ if (s.prev_length >= s.good_match) then
+ begin
+ chain_length := chain_length shr 2;
+ end;
+
+ { Do not look for matches beyond the end of the input. This is necessary
+ to make deflate deterministic. }
+
+ if (uInt(nice_match) > s.lookahead) then
+ nice_match := s.lookahead;
+ {$IFDEF DEBUG}
+ Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead');
+ {$ENDIF}
+ repeat
+ {$IFDEF DEBUG}
+ Assert(cur_match < s.strstart, 'no future');
+ {$ENDIF}
+ match := @(s.window^[cur_match]);
+
+ { Skip to next match if the match length cannot increase
+ or if the match length is less than 2: }
+
+{$undef DO_UNALIGNED_OK}
+{$ifdef UNALIGNED_OK}
+ {$ifdef MAX_MATCH_IS_258}
+ {$define DO_UNALIGNED_OK}
+ {$endif}
+{$endif}
+
+{$ifdef DO_UNALIGNED_OK}
+ { This code assumes sizeof(unsigned short) = 2. Do not use
+ UNALIGNED_OK if your compiler uses a different size. }
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
+ if (pushfArray(match)^[best_len-1] <> scan_end) or
+ (pushf(match)^ <> scan_start) then
+ goto nextstep; {continue;}
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}
+
+ { It is not necessary to compare scan[2] and match[2] since they are
+ always equal when the other bytes match, given that the hash keys
+ are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at
+ strstart+3, +5, ... up to strstart+257. We check for insufficient
+ lookahead only every 4th comparison; the 128th check will be made
+ at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is
+ necessary to put more guard bytes at the end of the window, or
+ to check more often for insufficient lookahead. }
+ {$IFDEF DEBUG}
+ Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?');
+ {$ENDIF}
+ Inc(scan);
+ Inc(match);
+
+ repeat
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;
+ Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break;
+ until (ptr2int(scan) >= ptr2int(strend));
+ { The funny "do while" generates better code on most compilers }
+
+ { Here, scan <= window+strstart+257 }
+ {$IFDEF DEBUG}
+ {$ifopt R+} {$define RangeCheck} {$endif} {$R-}
+ Assert(ptr2int(scan) <=
+ ptr2int(@(s.window^[unsigned(s.window_size-1)])),
+ 'wild scan');
+ {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif}
+ {$ENDIF}
+ if (scan^ = match^) then
+ Inc(scan);
+
+ len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan));
+ scan := strend;
+ Dec(scan, (MAX_MATCH-1));
+
+{$else} { UNALIGNED_OK }
+
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
+ if (pzByteArray(match)^[best_len] <> scan_end) or
+ (pzByteArray(match)^[best_len-1] <> scan_end1) or
+ (match^ <> scan^) then
+ goto nextstep; {continue;}
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}
+ Inc(match);
+ if (match^ <> pzByteArray(scan)^[1]) then
+ goto nextstep; {continue;}
+
+ { The check at best_len-1 can be removed because it will be made
+ again later. (This heuristic is not always a win.)
+ It is not necessary to compare scan[2] and match[2] since they
+ are always equal when the other bytes match, given that
+ the hash keys are equal and that HASH_BITS >= 8. }
+
+ Inc(scan, 2);
+ Inc(match);
+ {$IFDEF DEBUG}
+ Assert( scan^ = match^, 'match[2]?');
+ {$ENDIF}
+ { We check for insufficient lookahead only every 8th comparison;
+ the 256th check will be made at strstart+258. }
+
+ repeat
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ Inc(scan); Inc(match); if (scan^ <> match^) then break;
+ until (ptr2int(scan) >= ptr2int(strend));
+
+ {$IFDEF DEBUG}
+ Assert(ptr2int(scan) <=
+ ptr2int(@(s.window^[unsigned(s.window_size-1)])),
+ 'wild scan');
+ {$ENDIF}
+
+ len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan));
+ scan := strend;
+ Dec(scan, MAX_MATCH);
+
+{$endif} { UNALIGNED_OK }
+
+ if (len > best_len) then
+ begin
+ s.match_start := cur_match;
+ best_len := len;
+ if (len >= nice_match) then
+ break;
+ {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF}
+{$ifdef UNALIGNED_OK}
+ scan_end := pzByteArray(scan)^[best_len-1];
+{$else}
+ scan_end1 := pzByteArray(scan)^[best_len-1];
+ scan_end := pzByteArray(scan)^[best_len];
+{$endif}
+ {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF}
+ end;
+ nextstep:
+ cur_match := prev^[cur_match and wmask];
+ Dec(chain_length);
+ until (cur_match <= limit) or (chain_length = 0);
+
+ if (uInt(best_len) <= s.lookahead) then
+ longest_match := uInt(best_len)
+ else
+ longest_match := s.lookahead;
+end;
+{$endif} { ASMV }
+
+{$else} { FASTEST }
+{ ---------------------------------------------------------------------------
+ Optimized version for level = 1 only }
+
+{local}
+function longest_match(var s : deflate_state;
+ cur_match : IPos { current match }
+ ) : uInt;
+var
+ {register} scan : pBytef; { current string }
+ {register} match : pBytef; { matched string }
+ {register} len : int; { length of current match }
+ {register} strend : pBytef;
+begin
+ scan := @s.window^[s.strstart];
+ strend := @s.window^[s.strstart + MAX_MATCH];
+
+
+ { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ It is easy to get rid of this optimization if necessary. }
+ {$IFDEF DEBUG}
+ Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever');
+
+ Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead');
+
+ Assert(cur_match < s.strstart, 'no future');
+ {$ENDIF}
+ match := s.window + cur_match;
+
+ { Return failure if the match length is less than 2: }
+
+ if (match[0] <> scan[0]) or (match[1] <> scan[1]) then
+ begin
+ longest_match := MIN_MATCH-1;
+ exit;
+ end;
+
+ { The check at best_len-1 can be removed because it will be made
+ again later. (This heuristic is not always a win.)
+ It is not necessary to compare scan[2] and match[2] since they
+ are always equal when the other bytes match, given that
+ the hash keys are equal and that HASH_BITS >= 8. }
+
+ scan += 2, match += 2;
+ Assert(scan^ = match^, 'match[2]?');
+
+ { We check for insufficient lookahead only every 8th comparison;
+ the 256th check will be made at strstart+258. }
+
+ repeat
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ Inc(scan); Inc(match); if scan^<>match^ then break;
+ until (ptr2int(scan) >= ptr2int(strend));
+
+ Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan');
+
+ len := MAX_MATCH - int(strend - scan);
+
+ if (len < MIN_MATCH) then
+ begin
+ return := MIN_MATCH - 1;
+ exit;
+ end;
+
+ s.match_start := cur_match;
+ if len <= s.lookahead then
+ longest_match := len
+ else
+ longest_match := s.lookahead;
+end;
+{$endif} { FASTEST }
+
+{$ifdef DEBUG}
+{ ===========================================================================
+ Check that the match at match_start is indeed a match. }
+
+{local}
+procedure check_match(var s : deflate_state;
+ start, match : IPos;
+ length : int);
+begin
+ exit;
+ { check that the match is indeed a match }
+ if (zmemcmp(pBytef(@s.window^[match]),
+ pBytef(@s.window^[start]), length) <> EQUAL) then
+ begin
+ WriteLn(' start ',start,', match ',match ,' length ', length);
+ repeat
+ Write(AnsiChar(s.window^[match]), AnsiChar(s.window^[start]));
+ Inc(match);
+ Inc(start);
+ Dec(length);
+ Until (length = 0);
+ z_error('invalid match');
+ end;
+ if (z_verbose > 1) then
+ begin
+ Write('\\[',start-match,',',length,']');
+ repeat
+ Write(AnsiChar(s.window^[start]));
+ Inc(start);
+ Dec(length);
+ Until (length = 0);
+ end;
+end;
+{$endif}
+
+{ ===========================================================================
+ Fill the window when the lookahead becomes insufficient.
+ Updates strstart and lookahead.
+
+ IN assertion: lookahead < MIN_LOOKAHEAD
+ OUT assertions: strstart <= window_size-MIN_LOOKAHEAD
+ At least one byte has been read, or avail_in = 0; reads are
+ performed for at least two bytes (required for the zip translate_eol
+ option -- not supported here). }
+
+{local}
+procedure fill_window(var s : deflate_state);
+var
+ {register} n, m : unsigned;
+ {register} p : pPosf;
+ more : unsigned; { Amount of free space at the end of the window. }
+ wsize : uInt;
+begin
+ wsize := s.w_size;
+ repeat
+ more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart));
+
+ { Deal with !@#$% 64K limit: }
+ if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then
+ more := wsize
+ else
+ if (more = unsigned(-1)) then
+ begin
+ { Very unlikely, but possible on 16 bit machine if strstart = 0
+ and lookahead = 1 (input done one byte at time) }
+ Dec(more);
+
+ { If the window is almost full and there is insufficient lookahead,
+ move the upper half to the lower one to make room in the upper half.}
+ end
+ else
+ if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then
+ begin
+ zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])),
+ unsigned(wsize));
+ Dec(s.match_start, wsize);
+ Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST }
+ Dec(s.block_start, long(wsize));
+
+ { Slide the hash table (could be avoided with 32 bit values
+ at the expense of memory usage). We slide even when level = 0
+ to keep the hash table consistent if we switch back to level > 0
+ later. (Using level 0 permanently is not an optimal usage of
+ zlib, so we don't care about this pathological case.) }
+
+ n := s.hash_size;
+ p := @s.head^[n];
+ repeat
+ Dec(p);
+ m := p^;
+ if (m >= wsize) then
+ p^ := Pos(m-wsize)
+ else
+ p^ := Pos(ZNIL);
+ Dec(n);
+ Until (n=0);
+
+ n := wsize;
+{$ifndef FASTEST}
+ p := @s.prev^[n];
+ repeat
+ Dec(p);
+ m := p^;
+ if (m >= wsize) then
+ p^ := Pos(m-wsize)
+ else
+ p^:= Pos(ZNIL);
+ { If n is not on any hash chain, prev^[n] is garbage but
+ its value will never be used. }
+ Dec(n);
+ Until (n=0);
+{$endif}
+ Inc(more, wsize);
+ end;
+ if (s.strm^.avail_in = 0) then
+ exit;
+
+ {* If there was no sliding:
+ * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 &&
+ * more == window_size - lookahead - strstart
+ * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1)
+ * => more >= window_size - 2*WSIZE + 2
+ * In the BIG_MEM or MMAP case (not yet supported),
+ * window_size == input_size + MIN_LOOKAHEAD &&
+ * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD.
+ * Otherwise, window_size == 2*WSIZE so more >= 2.
+ * If there was sliding, more >= WSIZE. So in all cases, more >= 2. }
+
+ {$IFDEF DEBUG}
+ Assert(more >= 2, 'more < 2');
+ {$ENDIF}
+
+ n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])),
+ more);
+ Inc(s.lookahead, n);
+
+ { Initialize the hash value now that we have some input: }
+ if (s.lookahead >= MIN_MATCH) then
+ begin
+ s.ins_h := s.window^[s.strstart];
+ {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);}
+ s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1])
+ and s.hash_mask;
+{$ifdef MIN_MATCH <> 3}
+ Call UPDATE_HASH() MIN_MATCH-3 more times
+{$endif}
+ end;
+ { If the whole input has less than MIN_MATCH bytes, ins_h is garbage,
+ but this is not important since only literal bytes will be emitted. }
+
+ until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0);
+end;
+
+{ ===========================================================================
+ Flush the current block, with given end-of-file flag.
+ IN assertion: strstart is set to the end of the current match. }
+
+procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro}
+begin
+ if (s.block_start >= Long(0)) then
+ _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]),
+ ulg(long(s.strstart) - s.block_start), eof)
+ else
+ _tr_flush_block(s, pcharf(Z_NULL),
+ ulg(long(s.strstart) - s.block_start), eof);
+
+ s.block_start := s.strstart;
+ flush_pending(s.strm^);
+ {$IFDEF DEBUG}
+ Tracev('[FLUSH]');
+ {$ENDIF}
+end;
+
+{ Same but force premature exit if necessary.
+macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean;
+var
+ result : block_state;
+begin
+ FLUSH_BLOCK_ONLY(s, eof);
+ if (s.strm^.avail_out = 0) then
+ begin
+ if eof then
+ result := finish_started
+ else
+ result := need_more;
+ exit;
+ end;
+end;
+}
+
+{ ===========================================================================
+ Copy without compression as much as possible from the input stream, return
+ the current block state.
+ This function does not insert new strings in the dictionary since
+ uncompressible data is probably not useful. This function is used
+ only for the level=0 compression option.
+ NOTE: this function should be optimized to avoid extra copying from
+ window to pending_buf. }
+
+
+{local}
+function deflate_stored(var s : deflate_state; flush : int) : block_state;
+{ Stored blocks are limited to 0xffff bytes, pending_buf is limited
+ to pending_buf_size, and each stored block has a 5 byte header: }
+var
+ max_block_size : ulg;
+ max_start : ulg;
+begin
+ max_block_size := $ffff;
+ if (max_block_size > s.pending_buf_size - 5) then
+ max_block_size := s.pending_buf_size - 5;
+
+ { Copy as much as possible from input to output: }
+ while TRUE do
+ begin
+ { Fill the window as much as possible: }
+ if (s.lookahead <= 1) then
+ begin
+ {$IFDEF DEBUG}
+ Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or
+ (s.block_start >= long(s.w_size)), 'slide too late');
+ {$ENDIF}
+ fill_window(s);
+ if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then
+ begin
+ deflate_stored := need_more;
+ exit;
+ end;
+
+ if (s.lookahead = 0) then
+ break; { flush the current block }
+ end;
+ {$IFDEF DEBUG}
+ Assert(s.block_start >= long(0), 'block gone');
+ {$ENDIF}
+ Inc(s.strstart, s.lookahead);
+ s.lookahead := 0;
+
+ { Emit a stored block if pending_buf will be full: }
+ max_start := s.block_start + max_block_size;
+ if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then
+ begin
+ { strstart = 0 is possible when wraparound on 16-bit machine }
+ s.lookahead := s.strstart - uInt(max_start);
+ s.strstart := uInt(max_start);
+ {FLUSH_BLOCK(s, FALSE);}
+ FLUSH_BLOCK_ONLY(s, FALSE);
+ if (s.strm^.avail_out = 0) then
+ begin
+ deflate_stored := need_more;
+ exit;
+ end;
+ end;
+
+ { Flush if we may have to slide, otherwise block_start may become
+ negative and the data will be gone: }
+
+ if (s.strstart - uInt(s.block_start) >= {MAX_DIST}
+ s.w_size-MIN_LOOKAHEAD) then
+ begin
+ {FLUSH_BLOCK(s, FALSE);}
+ FLUSH_BLOCK_ONLY(s, FALSE);
+ if (s.strm^.avail_out = 0) then
+ begin
+ deflate_stored := need_more;
+ exit;
+ end;
+ end;
+ end;
+
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);
+ if (s.strm^.avail_out = 0) then
+ begin
+ if flush = Z_FINISH then
+ deflate_stored := finish_started
+ else
+ deflate_stored := need_more;
+ exit;
+ end;
+
+ if flush = Z_FINISH then
+ deflate_stored := finish_done
+ else
+ deflate_stored := block_done;
+end;
+
+{ ===========================================================================
+ Compress as much as possible from the input stream, return the current
+ block state.
+ This function does not perform lazy evaluation of matches and inserts
+ new strings in the dictionary only for unmatched strings or for short
+ matches. It is used only for the fast compression options. }
+
+{local}
+function deflate_fast(var s : deflate_state; flush : int) : block_state;
+var
+ hash_head : IPos; { head of the hash chain }
+ bflush : boolean; { set if current block must be flushed }
+begin
+ hash_head := ZNIL;
+ while TRUE do
+ begin
+ { Make sure that we always have enough lookahead, except
+ at the end of the input file. We need MAX_MATCH bytes
+ for the next match, plus MIN_MATCH bytes to insert the
+ string following the next match. }
+
+ if (s.lookahead < MIN_LOOKAHEAD) then
+ begin
+ fill_window(s);
+ if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then
+ begin
+ deflate_fast := need_more;
+ exit;
+ end;
+
+ if (s.lookahead = 0) then
+ break; { flush the current block }
+ end;
+
+
+ { Insert the string window[strstart .. strstart+2] in the
+ dictionary, and set hash_head to the head of the hash chain: }
+
+ if (s.lookahead >= MIN_MATCH) then
+ begin
+ INSERT_STRING(s, s.strstart, hash_head);
+ end;
+
+ { Find the longest match, discarding those <= prev_length.
+ At this point we have always match_length < MIN_MATCH }
+ if (hash_head <> ZNIL) and
+ (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then
+ begin
+ { To simplify the code, we prevent matches with the string
+ of window index 0 (in particular we have to avoid a match
+ of the string with itself at the start of the input file). }
+ if (s.strategy <> Z_HUFFMAN_ONLY) then
+ begin
+ s.match_length := longest_match (s, hash_head);
+ end;
+ { longest_match() sets match_start }
+ end;
+ if (s.match_length >= MIN_MATCH) then
+ begin
+ {$IFDEF DEBUG}
+ check_match(s, s.strstart, s.match_start, s.match_length);
+ {$ENDIF}
+
+ {_tr_tally_dist(s, s.strstart - s.match_start,
+ s.match_length - MIN_MATCH, bflush);}
+ bflush := _tr_tally(s, s.strstart - s.match_start,
+ s.match_length - MIN_MATCH);
+
+ Dec(s.lookahead, s.match_length);
+
+ { Insert new strings in the hash table only if the match length
+ is not too large. This saves time but degrades compression. }
+
+{$ifndef FASTEST}
+ if (s.match_length <= s.max_insert_length)
+ and (s.lookahead >= MIN_MATCH) then
+ begin
+ Dec(s.match_length); { string at strstart already in hash table }
+ repeat
+ Inc(s.strstart);
+ INSERT_STRING(s, s.strstart, hash_head);
+ { strstart never exceeds WSIZE-MAX_MATCH, so there are
+ always MIN_MATCH bytes ahead. }
+ Dec(s.match_length);
+ until (s.match_length = 0);
+ Inc(s.strstart);
+ end
+ else
+{$endif}
+
+ begin
+ Inc(s.strstart, s.match_length);
+ s.match_length := 0;
+ s.ins_h := s.window^[s.strstart];
+ {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);}
+ s.ins_h := (( s.ins_h shl s.hash_shift) xor
+ s.window^[s.strstart+1]) and s.hash_mask;
+if MIN_MATCH <> 3 then { the linker removes this }
+begin
+ {Call UPDATE_HASH() MIN_MATCH-3 more times}
+end;
+
+ { If lookahead < MIN_MATCH, ins_h is garbage, but it does not
+ matter since it will be recomputed at next deflate call. }
+
+ end;
+ end
+ else
+ begin
+ { No match, output a literal byte }
+ {$IFDEF DEBUG}
+ Tracevv(AnsiChar(s.window^[s.strstart]));
+ {$ENDIF}
+ {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);}
+ bflush := _tr_tally (s, 0, s.window^[s.strstart]);
+
+ Dec(s.lookahead);
+ Inc(s.strstart);
+ end;
+ if bflush then
+ begin {FLUSH_BLOCK(s, FALSE);}
+ FLUSH_BLOCK_ONLY(s, FALSE);
+ if (s.strm^.avail_out = 0) then
+ begin
+ deflate_fast := need_more;
+ exit;
+ end;
+ end;
+ end;
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);
+ if (s.strm^.avail_out = 0) then
+ begin
+ if flush = Z_FINISH then
+ deflate_fast := finish_started
+ else
+ deflate_fast := need_more;
+ exit;
+ end;
+
+ if flush = Z_FINISH then
+ deflate_fast := finish_done
+ else
+ deflate_fast := block_done;
+end;
+
+{ ===========================================================================
+ Same as above, but achieves better compression. We use a lazy
+ evaluation for matches: a match is finally adopted only if there is
+ no better match at the next window position. }
+
+{local}
+function deflate_slow(var s : deflate_state; flush : int) : block_state;
+var
+ hash_head : IPos; { head of hash chain }
+ bflush : boolean; { set if current block must be flushed }
+var
+ max_insert : uInt;
+begin
+ hash_head := ZNIL;
+
+ { Process the input block. }
+ while TRUE do
+ begin
+ { Make sure that we always have enough lookahead, except
+ at the end of the input file. We need MAX_MATCH bytes
+ for the next match, plus MIN_MATCH bytes to insert the
+ string following the next match. }
+
+ if (s.lookahead < MIN_LOOKAHEAD) then
+ begin
+ fill_window(s);
+ if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then
+ begin
+ deflate_slow := need_more;
+ exit;
+ end;
+
+ if (s.lookahead = 0) then
+ break; { flush the current block }
+ end;
+
+ { Insert the string window[strstart .. strstart+2] in the
+ dictionary, and set hash_head to the head of the hash chain: }
+
+ if (s.lookahead >= MIN_MATCH) then
+ begin
+ INSERT_STRING(s, s.strstart, hash_head);
+ end;
+
+ { Find the longest match, discarding those <= prev_length. }
+
+ s.prev_length := s.match_length;
+ s.prev_match := s.match_start;
+ s.match_length := MIN_MATCH-1;
+
+ if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and
+ (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then
+ begin
+ { To simplify the code, we prevent matches with the string
+ of window index 0 (in particular we have to avoid a match
+ of the string with itself at the start of the input file). }
+
+ if (s.strategy <> Z_HUFFMAN_ONLY) then
+ begin
+ s.match_length := longest_match (s, hash_head);
+ end;
+ { longest_match() sets match_start }
+
+ if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or
+ ((s.match_length = MIN_MATCH) and
+ (s.strstart - s.match_start > TOO_FAR))) then
+ begin
+ { If prev_match is also MIN_MATCH, match_start is garbage
+ but we will ignore the current match anyway. }
+
+ s.match_length := MIN_MATCH-1;
+ end;
+ end;
+ { If there was a match at the previous step and the current
+ match is not better, output the previous match: }
+
+ if (s.prev_length >= MIN_MATCH)
+ and (s.match_length <= s.prev_length) then
+ begin
+ max_insert := s.strstart + s.lookahead - MIN_MATCH;
+ { Do not insert strings in hash table beyond this. }
+ {$ifdef DEBUG}
+ check_match(s, s.strstart-1, s.prev_match, s.prev_length);
+ {$endif}
+
+ {_tr_tally_dist(s, s->strstart -1 - s->prev_match,
+ s->prev_length - MIN_MATCH, bflush);}
+ bflush := _tr_tally(s, s.strstart -1 - s.prev_match,
+ s.prev_length - MIN_MATCH);
+
+ { Insert in hash table all strings up to the end of the match.
+ strstart-1 and strstart are already inserted. If there is not
+ enough lookahead, the last two strings are not inserted in
+ the hash table. }
+
+ Dec(s.lookahead, s.prev_length-1);
+ Dec(s.prev_length, 2);
+ repeat
+ Inc(s.strstart);
+ if (s.strstart <= max_insert) then
+ begin
+ INSERT_STRING(s, s.strstart, hash_head);
+ end;
+ Dec(s.prev_length);
+ until (s.prev_length = 0);
+ s.match_available := FALSE;
+ s.match_length := MIN_MATCH-1;
+ Inc(s.strstart);
+
+ if (bflush) then {FLUSH_BLOCK(s, FALSE);}
+ begin
+ FLUSH_BLOCK_ONLY(s, FALSE);
+ if (s.strm^.avail_out = 0) then
+ begin
+ deflate_slow := need_more;
+ exit;
+ end;
+ end;
+ end
+ else
+ if (s.match_available) then
+ begin
+ { If there was no match at the previous position, output a
+ single literal. If there was a match but the current match
+ is longer, truncate the previous match to a single literal. }
+ {$IFDEF DEBUG}
+ Tracevv(AnsiChar(s.window^[s.strstart-1]));
+ {$ENDIF}
+ bflush := _tr_tally (s, 0, s.window^[s.strstart-1]);
+
+ if bflush then
+ begin
+ FLUSH_BLOCK_ONLY(s, FALSE);
+ end;
+ Inc(s.strstart);
+ Dec(s.lookahead);
+ if (s.strm^.avail_out = 0) then
+ begin
+ deflate_slow := need_more;
+ exit;
+ end;
+ end
+ else
+ begin
+ { There is no previous match to compare with, wait for
+ the next step to decide. }
+
+ s.match_available := TRUE;
+ Inc(s.strstart);
+ Dec(s.lookahead);
+ end;
+ end;
+
+ {$IFDEF DEBUG}
+ Assert (flush <> Z_NO_FLUSH, 'no flush?');
+ {$ENDIF}
+ if (s.match_available) then
+ begin
+ {$IFDEF DEBUG}
+ Tracevv(AnsiChar(s.window^[s.strstart-1]));
+ bflush :=
+ {$ENDIF}
+ _tr_tally (s, 0, s.window^[s.strstart-1]);
+ s.match_available := FALSE;
+ end;
+ {FLUSH_BLOCK(s, flush = Z_FINISH);}
+ FLUSH_BLOCK_ONLY(s, flush = Z_FINISH);
+ if (s.strm^.avail_out = 0) then
+ begin
+ if flush = Z_FINISH then
+ deflate_slow := finish_started
+ else
+ deflate_slow := need_more;
+ exit;
+ end;
+ if flush = Z_FINISH then
+ deflate_slow := finish_done
+ else
+ deflate_slow := block_done;
+end;
+
+end.
diff --git a/src/lib/vampimg/ZLib/imzinflate.pas b/src/lib/vampimg/ZLib/imzinflate.pas
--- /dev/null
@@ -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 : AnsiString;
+ stream_size : int) : int;
+
+
+function inflateInit2_(var z: z_stream;
+ w : int;
+ const version : AnsiString;
+ 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 : AnsiString;
+ 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 : AnsiString;
+ 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.
diff --git a/src/lib/vampimg/ZLib/imzutil.pas b/src/lib/vampimg/ZLib/imzutil.pas
--- /dev/null
@@ -0,0 +1,190 @@
+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.
diff --git a/src/lib/vampimg/ZLib/readme.txt b/src/lib/vampimg/ZLib/readme.txt
--- /dev/null
@@ -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