From: Ketmar Dark Date: Fri, 22 Apr 2016 09:23:10 +0000 (+0300) Subject: added Vampyre Imaging Library; now textures can be in various formats, including... X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=8f815647c61a98e32b85066bf245b262694ac634;p=d2df-sdl.git added Vampyre Imaging Library; now textures can be in various formats, including png, jpeg, psd and even dds --- diff --git a/build.bat b/build.bat index dbb5a2a..b58fbd9 100644 --- a/build.bat +++ b/build.bat @@ -1,5 +1,5 @@ @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 9580d69..d5c317f 100644 --- a/build_headless.bat +++ b/build_headless.bat @@ -1,5 +1,5 @@ @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 diff --git a/src/engine/e_graphics.pas b/src/engine/e_graphics.pas index cdfe09b..d7bced4 100644 --- a/src/engine/e_graphics.pas +++ b/src/engine/e_graphics.pas @@ -65,8 +65,8 @@ procedure e_DrawFillQuad(X1, Y1, X2, Y2: Integer; Red, Green, Blue, Alpha: Byte; 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); @@ -292,7 +292,7 @@ begin 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; @@ -301,8 +301,7 @@ begin 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; @@ -310,7 +309,7 @@ begin 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; @@ -319,7 +318,7 @@ begin 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; diff --git a/src/engine/e_textures.pas b/src/engine/e_textures.pas index e53a3ef..19efb4b 100644 --- a/src/engine/e_textures.pas +++ b/src/engine/e_textures.pas @@ -22,24 +22,19 @@ var 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; @@ -55,6 +50,7 @@ begin end; +{ type TTGAHeader = packed record FileType: Byte; @@ -68,6 +64,8 @@ type 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; @@ -162,380 +160,191 @@ begin 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 ac174d8..1c06249 100644 --- a/src/game/Doom2DF.dpr +++ b/src/game/Doom2DF.dpr @@ -87,7 +87,10 @@ uses {$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 25b1bfe..8445e78 100644 --- a/src/game/g_map.pas +++ b/src/game/g_map.pas @@ -423,7 +423,7 @@ begin 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, @@ -537,7 +537,7 @@ begin 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 62e4e8d..8b3dc31 100644 --- a/src/game/g_menu.pas +++ b/src/game/g_menu.pas @@ -842,7 +842,7 @@ begin 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; diff --git a/src/game/g_playermodel.pas b/src/game/g_playermodel.pas index 7cb1eda..8345e78 100644 --- a/src/game/g_playermodel.pas +++ b/src/game/g_playermodel.pas @@ -231,7 +231,7 @@ end; 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; @@ -358,12 +358,12 @@ begin 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 diff --git a/src/game/g_textures.pas b/src/game/g_textures.pas index fba31e4..bdf6605 100644 --- a/src/game/g_textures.pas +++ b/src/game/g_textures.pas @@ -79,7 +79,7 @@ function g_Frames_CreateWAD(ID: PDWORD; Name: ShortString; Resource: String; 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; @@ -159,7 +159,7 @@ begin 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); @@ -201,7 +201,7 @@ begin 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, @@ -350,7 +350,7 @@ begin 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; @@ -366,7 +366,7 @@ begin 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); @@ -414,7 +414,7 @@ begin 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; @@ -425,10 +425,10 @@ begin 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 new file mode 100644 index 0000000..22d8cb3 --- /dev/null +++ b/src/lib/vampimg/Imaging.pas @@ -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 — the top + becomes the bottom and vice versa.} +function FlipImage(var Image: TImageData): Boolean; +{ Mirrors given image. Reverses the image along its vertical axis — 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 new file mode 100644 index 0000000..943f476 --- /dev/null +++ b/src/lib/vampimg/ImagingBitmap.pas @@ -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 new file mode 100644 index 0000000..0069502 --- /dev/null +++ b/src/lib/vampimg/ImagingCanvases.pas @@ -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 new file mode 100644 index 0000000..c00c105 --- /dev/null +++ b/src/lib/vampimg/ImagingClasses.pas @@ -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 new file mode 100644 index 0000000..22c1c8f --- /dev/null +++ b/src/lib/vampimg/ImagingColors.pas @@ -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 new file mode 100644 index 0000000..3945362 --- /dev/null +++ b/src/lib/vampimg/ImagingComponents.pas @@ -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 new file mode 100644 index 0000000..a2eb09c --- /dev/null +++ b/src/lib/vampimg/ImagingDds.pas @@ -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 new file mode 100644 index 0000000..b3752f8 --- /dev/null +++ b/src/lib/vampimg/ImagingExport.pas @@ -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 new file mode 100644 index 0000000..865e81e --- /dev/null +++ b/src/lib/vampimg/ImagingExtras.pas @@ -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 new file mode 100644 index 0000000..956f491 --- /dev/null +++ b/src/lib/vampimg/ImagingFormats.pas @@ -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 new file mode 100644 index 0000000..0f3d9cd --- /dev/null +++ b/src/lib/vampimg/ImagingGif.pas @@ -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 new file mode 100644 index 0000000..c26b451 --- /dev/null +++ b/src/lib/vampimg/ImagingIO.pas @@ -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 new file mode 100644 index 0000000..f01d183 --- /dev/null +++ b/src/lib/vampimg/ImagingJpeg.pas @@ -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 new file mode 100644 index 0000000..7b2ab93 --- /dev/null +++ b/src/lib/vampimg/ImagingNetworkGraphics.pas @@ -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 new file mode 100644 index 0000000..87851b9 --- /dev/null +++ b/src/lib/vampimg/ImagingOptions.inc @@ -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 new file mode 100644 index 0000000..257ad76 --- /dev/null +++ b/src/lib/vampimg/ImagingPcx.pas @@ -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 new file mode 100644 index 0000000..97e6c4e --- /dev/null +++ b/src/lib/vampimg/ImagingPortableMaps.pas @@ -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 new file mode 100644 index 0000000..a95ce96 --- /dev/null +++ b/src/lib/vampimg/ImagingPsd.pas @@ -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 new file mode 100644 index 0000000..5103f78 --- /dev/null +++ b/src/lib/vampimg/ImagingTarga.pas @@ -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 new file mode 100644 index 0000000..7de0d12 --- /dev/null +++ b/src/lib/vampimg/ImagingTypes.pas @@ -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 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 + 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 + + 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 new file mode 100644 index 0000000..e22ef52 --- /dev/null +++ b/src/lib/vampimg/ImagingUtility.pas @@ -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 } +function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Clamps float value to range } +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 new file mode 100644 index 0000000..cf743d8 --- /dev/null +++ b/src/lib/vampimg/ImagingXpm.pas @@ -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 new file mode 100644 index 0000000..105f574 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcapimin.pas @@ -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 new file mode 100644 index 0000000..bc487a7 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcapistd.pas @@ -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 new file mode 100644 index 0000000..7d6ee6f --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjccoefct.pas @@ -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 new file mode 100644 index 0000000..578706c --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjccolor.pas @@ -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 new file mode 100644 index 0000000..f63569e --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcdctmgr.pas @@ -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 new file mode 100644 index 0000000..66856dc --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjchuff.pas @@ -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 new file mode 100644 index 0000000..9adaee6 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcinit.pas @@ -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 new file mode 100644 index 0000000..983ac83 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcmainct.pas @@ -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 new file mode 100644 index 0000000..35463dc --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcmarker.pas @@ -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 new file mode 100644 index 0000000..1498398 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcmaster.pas @@ -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 new file mode 100644 index 0000000..c58a7ae --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcomapi.pas @@ -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 new file mode 100644 index 0000000..b57c933 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjconfig.inc @@ -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 new file mode 100644 index 0000000..66117ca --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcparam.pas @@ -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 new file mode 100644 index 0000000..3c9dbf7 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcphuff.pas @@ -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 new file mode 100644 index 0000000..9f21e51 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcprepct.pas @@ -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 new file mode 100644 index 0000000..48ea3d8 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjcsample.pas @@ -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 new file mode 100644 index 0000000..726d798 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdapimin.pas @@ -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 new file mode 100644 index 0000000..04afd11 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdapistd.pas @@ -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 new file mode 100644 index 0000000..5024786 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdcoefct.pas @@ -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 new file mode 100644 index 0000000..f27fa5c --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdcolor.pas @@ -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 new file mode 100644 index 0000000..30d3356 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdct.pas @@ -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 new file mode 100644 index 0000000..42ae295 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjddctmgr.pas @@ -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 new file mode 100644 index 0000000..61fe305 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdeferr.pas @@ -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 new file mode 100644 index 0000000..09f0e66 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdhuff.pas @@ -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 new file mode 100644 index 0000000..98347d2 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdinput.pas @@ -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 new file mode 100644 index 0000000..037f099 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdmainct.pas @@ -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 new file mode 100644 index 0000000..c2202c2 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdmarker.pas @@ -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 new file mode 100644 index 0000000..4f233a0 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdmaster.pas @@ -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 new file mode 100644 index 0000000..a99d195 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdmerge.pas @@ -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 new file mode 100644 index 0000000..1ab53d2 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdphuff.pas @@ -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 new file mode 100644 index 0000000..8769550 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdpostct.pas @@ -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 new file mode 100644 index 0000000..ec95e34 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjdsample.pas @@ -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 new file mode 100644 index 0000000..0a61814 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjerror.pas @@ -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 new file mode 100644 index 0000000..1038284 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjfdctflt.pas @@ -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 new file mode 100644 index 0000000..40b2fd1 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjfdctfst.pas @@ -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 new file mode 100644 index 0000000..b676fff --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjfdctint.pas @@ -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 new file mode 100644 index 0000000..a699739 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjidctasm.pas @@ -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 + 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 new file mode 100644 index 0000000..febd244 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjidctflt.pas @@ -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 new file mode 100644 index 0000000..f66c731 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjidctfst.pas @@ -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 new file mode 100644 index 0000000..e51628b --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjidctint.pas @@ -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 new file mode 100644 index 0000000..27a0e43 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjidctred.pas @@ -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 new file mode 100644 index 0000000..dcaa684 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjinclude.pas @@ -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 . + Otherwise, we get them from or ; we may have to + pull in as well. + Note that the core JPEG library does not require ; + 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 .} + + + +{ We need memory copying and zeroing functions, plus strncpy(). + ANSI and System V implementations declare these in . + BSD doesn't have the mem() functions, but it does have bcopy()/bzero(). + Some systems may declare memset and memcpy in . + + 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 new file mode 100644 index 0000000..ca8239d --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjmemmgr.pas @@ -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 new file mode 100644 index 0000000..750fd80 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjmemnobs.pas @@ -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 new file mode 100644 index 0000000..316a9a7 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjmorecfg.pas @@ -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 new file mode 100644 index 0000000..f3f530d --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjpeglib.pas @@ -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 new file mode 100644 index 0000000..c5df360 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjquant1.pas @@ -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 new file mode 100644 index 0000000..5d4e4dc --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjquant2.pas @@ -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 new file mode 100644 index 0000000..fc0eac7 --- /dev/null +++ b/src/lib/vampimg/JpegLib/imjutils.pas @@ -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 new file mode 100644 index 0000000..6df345b --- /dev/null +++ b/src/lib/vampimg/JpegLib/readme.txt @@ -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 + * -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 new file mode 100644 index 0000000..72031aa --- /dev/null +++ b/src/lib/vampimg/ZLib/dzlib.pas @@ -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 new file mode 100644 index 0000000..ff769a2 --- /dev/null +++ b/src/lib/vampimg/ZLib/imadler.pas @@ -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 new file mode 100644 index 0000000..413e9b6 --- /dev/null +++ b/src/lib/vampimg/ZLib/iminfblock.pas @@ -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 new file mode 100644 index 0000000..1396e13 --- /dev/null +++ b/src/lib/vampimg/ZLib/iminfcodes.pas @@ -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 new file mode 100644 index 0000000..936c922 --- /dev/null +++ b/src/lib/vampimg/ZLib/iminffast.pas @@ -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 new file mode 100644 index 0000000..af545a7 --- /dev/null +++ b/src/lib/vampimg/ZLib/iminftrees.pas @@ -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 new file mode 100644 index 0000000..384f0d3 --- /dev/null +++ b/src/lib/vampimg/ZLib/iminfutil.pas @@ -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 new file mode 100644 index 0000000..7827dec --- /dev/null +++ b/src/lib/vampimg/ZLib/impaszlib.pas @@ -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 new file mode 100644 index 0000000..8f1f559 --- /dev/null +++ b/src/lib/vampimg/ZLib/imtrees.pas @@ -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 new file mode 100644 index 0000000..ffb585d --- /dev/null +++ b/src/lib/vampimg/ZLib/imzconf.inc @@ -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 new file mode 100644 index 0000000..e0d8218 --- /dev/null +++ b/src/lib/vampimg/ZLib/imzdeflate.pas @@ -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 new file mode 100644 index 0000000..6376510 --- /dev/null +++ b/src/lib/vampimg/ZLib/imzinflate.pas @@ -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 new file mode 100644 index 0000000..701b5a2 --- /dev/null +++ b/src/lib/vampimg/ZLib/imzutil.pas @@ -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 new file mode 100644 index 0000000..ffd4f89 --- /dev/null +++ b/src/lib/vampimg/ZLib/readme.txt @@ -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 March 24th, 2000