RichEdit

开发平台：

Delphi

GifImage.pas：源码内容

IsLeaf := (Level = ColorBits);
if (IsLeaf) then
begin
Next := nil;
inc(LeafCount);
end else
begin
Next := ReducibleNodes[Level];
ReducibleNodes[Level] := self;
end;
end;
destructor TOctreeNode.Destroy;
var
i : integer;
begin
for i := High(Child) downto Low(Child) do
Child[i].Free;
end;
constructor TColorQuantizer.Create(MaxColors: integer; ColorBits: integer);
var
i : integer;
begin
ASSERT(ColorBits <= 8, 'ColorBits must be 8 or less');
FTree := nil;
FLeafCount := 0;
// Initialize all nodes even though only ColorBits+1 of them are needed
for i := Low(FReducibleNodes) to High(FReducibleNodes) do
FReducibleNodes[i] := nil;
FMaxColors := MaxColors;
FColorBits := ColorBits;
end;
destructor TColorQuantizer.Destroy;
begin
if (FTree <> nil) then
DeleteTree(FTree);
end;
procedure TColorQuantizer.GetColorTable(var RGBQuadArray: TRGBQuadArray);
var
Index : integer;
begin
Index := 0;
GetPaletteColors(FTree, RGBQuadArray, Index);
end;
// Handles passed to ProcessImage should refer to DIB sections, not DDBs.
// In certain cases, specifically when it's called upon to process 1, 4, or
// 8-bit per pixel images on systems with palettized display adapters,
// ProcessImage can produce incorrect results if it's passed a handle to a
// DDB.
function TColorQuantizer.ProcessImage(const DIB: TDIBReader): boolean;
var
i ,
j : integer;
ScanLine : pointer;
Pixel : PRGBTriple;
begin
Result := True;
for j := 0 to DIB.Bitmap.Height-1 do
begin
Scanline := DIB.Scanline[j];
Pixel := ScanLine;
for i := 0 to DIB.Bitmap.Width-1 do
begin
with Pixel^ do
AddColor(FTree, rgbtRed, rgbtGreen, rgbtBlue,
FColorBits, 0, FLeafCount, FReducibleNodes);
while FLeafCount > FMaxColors do
ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
inc(Pixel);
end;
end;
end;
procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
ColorBits: integer; Level: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
const
Mask: array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
var
Index : integer;
Shift : integer;
begin
// If the node doesn't exist, create it.
if (Node = nil) then
Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);
if (Node.IsLeaf) then
begin
inc(Node.PixelCount);
inc(Node.RedSum, r);
inc(Node.GreenSum, g);
inc(Node.BlueSum, b);
end else
begin
// Recurse a level deeper if the node is not a leaf.
Shift := 7 - Level;
Index := (((r and mask[Level]) SHR Shift) SHL 2) or
(((g and mask[Level]) SHR Shift) SHL 1) or
((b and mask[Level]) SHR Shift);
AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
end;
end;
procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
var
i : integer;
begin
for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
if (Node.Child[i] <> nil) then
DeleteTree(Node.Child[i]);
Node.Free;
Node := nil;
end;
procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
var RGBQuadArray: TRGBQuadArray; var Index: integer);
var
i : integer;
begin
if (Node.IsLeaf) then
begin
with RGBQuadArray[Index] do
begin
if (Node.PixelCount <> 0) then
begin
rgbRed := BYTE(Node.RedSum DIV Node.PixelCount);
rgbGreen := BYTE(Node.GreenSum DIV Node.PixelCount);
rgbBlue := BYTE(Node.BlueSum DIV Node.PixelCount);
end else
begin
rgbRed := 0;
rgbGreen := 0;
rgbBlue := 0;
end;
rgbReserved := 0;
end;
inc(Index);
end else
begin
for i := Low(Node.Child) to High(Node.Child) do
if (Node.Child[i] <> nil) then
GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
end;
end;
procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
var
RedSum ,
GreenSum ,
BlueSum : integer;
Children : integer;
i : integer;
Node : TOctreeNode;
begin
// Find the deepest level containing at least one reducible node
i := Colorbits - 1;
while (i > 0) and (ReducibleNodes[i] = nil) do
dec(i);
// Reduce the node most recently added to the list at level i.
Node := ReducibleNodes[i];
ReducibleNodes[i] := Node.Next;
RedSum := 0;
GreenSum := 0;
BlueSum := 0;
Children := 0;
for i := Low(ReducibleNodes) to High(ReducibleNodes) do
if (Node.Child[i] <> nil) then
begin
inc(RedSum, Node.Child[i].RedSum);
inc(GreenSum, Node.Child[i].GreenSum);
inc(BlueSum, Node.Child[i].BlueSum);
inc(Node.PixelCount, Node.Child[i].PixelCount);
Node.Child[i].Free;
Node.Child[i] := nil;
inc(Children);
end;
Node.IsLeaf := TRUE;
Node.RedSum := RedSum;
Node.GreenSum := GreenSum;
Node.BlueSum := BlueSum;
dec(LeafCount, Children-1);
end;
////////////////////////////////////////////////////////////////////////////////
//
// Octree Color Quantization Wrapper
//
////////////////////////////////////////////////////////////////////////////////
// Adapted from Earl F. Glynn's PaletteLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////
// Wrapper for internal use - uses TDIBReader for bitmap access
function doCreateOptimizedPaletteFromSingleBitmap(const DIB: TDIBReader;
Colors, ColorBits: integer; Windows: boolean): hPalette;
var
SystemPalette : HPalette;
ColorQuantizer : TColorQuantizer;
i : integer;
LogicalPalette : TMaxLogPalette;
RGBQuadArray : TRGBQuadArray;
Offset : integer;
begin
LogicalPalette.palVersion := $0300;
LogicalPalette.palNumEntries := Colors;
if (Windows) then
begin
// Get the windows 20 color system palette
SystemPalette := GetStockObject(DEFAULT_PALETTE);
GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);
Colors := 236;
Offset := 10;
LogicalPalette.palNumEntries := 256;
end else
Offset := 0;
// Normally for 24-bit images, use ColorBits of 5 or 6. For 8-bit images
// use ColorBits = 8.
ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
try
ColorQuantizer.ProcessImage(DIB);
ColorQuantizer.GetColorTable(RGBQuadArray);
finally
ColorQuantizer.Free;
end;
for i := 0 to Colors-1 do
with LogicalPalette.palPalEntry[i+Offset] do
begin
peRed := RGBQuadArray[i].rgbRed;
peGreen := RGBQuadArray[i].rgbGreen;
peBlue := RGBQuadArray[i].rgbBlue;
peFlags := RGBQuadArray[i].rgbReserved;
end;
Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;
function CreateOptimizedPaletteFromSingleBitmap(const Bitmap: TBitmap;
Colors, ColorBits: integer; Windows: boolean): hPalette;
var
DIB : TDIBReader;
begin
DIB := TDIBReader.Create(Bitmap, pf24bit);
try
Result := doCreateOptimizedPaletteFromSingleBitmap(DIB, Colors, ColorBits, Windows);
finally
DIB.Free;
end;
end;
function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
Windows: boolean): hPalette;
var
SystemPalette : HPalette;
ColorQuantizer : TColorQuantizer;
i : integer;
LogicalPalette : TMaxLogPalette;
RGBQuadArray : TRGBQuadArray;
Offset : integer;
DIB : TDIBReader;
begin
if (Bitmaps = nil) or (Bitmaps.Count = 0) then
Error(sInvalidBitmapList);
LogicalPalette.palVersion := $0300;
LogicalPalette.palNumEntries := Colors;
if (Windows) then
begin
// Get the windows 20 color system palette
SystemPalette := GetStockObject(DEFAULT_PALETTE);
GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);
Colors := 236;
Offset := 10;
LogicalPalette.palNumEntries := 256;
end else
Offset := 0;
// Normally for 24-bit images, use ColorBits of 5 or 6. For 8-bit images
// use ColorBits = 8.
ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
try
for i := 0 to Bitmaps.Count-1 do
begin
DIB := TDIBReader.Create(TBitmap(Bitmaps[i]), pf24bit);
try
ColorQuantizer.ProcessImage(DIB);
finally
DIB.Free;
end;
end;
ColorQuantizer.GetColorTable(RGBQuadArray);
finally
ColorQuantizer.Free;
end;
for i := 0 to Colors-1 do
with LogicalPalette.palPalEntry[i+Offset] do
begin
peRed := RGBQuadArray[i].rgbRed;
peGreen := RGBQuadArray[i].rgbGreen;
peBlue := RGBQuadArray[i].rgbBlue;
peFlags := RGBQuadArray[i].rgbReserved;
end;
Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;
////////////////////////////////////////////////////////////////////////////////
//
// Color reduction
//
////////////////////////////////////////////////////////////////////////////////
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
//: Reduces the color depth of a bitmap using color quantization and dithering.
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;
var
Palette : hPalette;
ColorLookup : TColorLookup;
Ditherer : TDitherEngine;
Row : Integer;
DIBResult : TDIBWriter;
DIBSource : TDIBReader;
SrcScanLine ,
Src : PRGBTriple;
DstScanLine ,
Dst : PChar;
BGR : TRGBTriple;
{$ifdef DEBUG_DITHERPERFORMANCE}
TimeStart ,
TimeStop : DWORD;
{$endif}
function GrayScalePalette: hPalette;
var
i : integer;
Pal : TMaxLogPalette;
begin
Pal.palVersion := $0300;
Pal.palNumEntries := 256;
for i := 0 to 255 do
begin
with (Pal.palPalEntry[i]) do
begin
peRed := i;
peGreen := i;
peBlue := i;
peFlags := PC_NOCOLLAPSE;
end;
end;
Result := CreatePalette(pLogPalette(@Pal)^);
end;
function MonochromePalette: hPalette;
var
i : integer;
Pal : TMaxLogPalette;
const
Values : array[0..1] of byte
= (0, 255);
begin
Pal.palVersion := $0300;
Pal.palNumEntries := 2;
for i := 0 to 1 do
begin
with (Pal.palPalEntry[i]) do
begin
peRed := Values[i];
peGreen := Values[i];
peBlue := Values[i];
peFlags := PC_NOCOLLAPSE;
end;
end;
Result := CreatePalette(pLogPalette(@Pal)^);
end;
function WindowsGrayScalePalette: hPalette;
var
i : integer;
Pal : TMaxLogPalette;
const
Values : array[0..3] of byte
= (0, 128, 192, 255);
begin
Pal.palVersion := $0300;
Pal.palNumEntries := 4;
for i := 0 to 3 do
begin
with (Pal.palPalEntry[i]) do
begin
peRed := Values[i];
peGreen := Values[i];
peBlue := Values[i];
peFlags := PC_NOCOLLAPSE;
end;
end;
Result := CreatePalette(pLogPalette(@Pal)^);
end;
function WindowsHalftonePalette: hPalette;
var
DC : HDC;
begin
DC := GDICheck(GetDC(0));
try
Result := CreateHalfTonePalette(DC);
finally
ReleaseDC(0, DC);
end;
end;
begin
{$ifdef DEBUG_DITHERPERFORMANCE}
timeBeginPeriod(5);
TimeStart := timeGetTime;
{$endif}
Result := TBitmap.Create;
try
if (ColorReduction = rmNone) then
begin
Result.Assign(Bitmap);
{$ifndef VER9x}
SetPixelFormat(Result, pf24bit);
{$endif}
exit;
end;
{$IFNDEF VER9x}
if (Bitmap.Width*Bitmap.Height > BitmapAllocationThreshold) then
SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}
ColorLookup := nil;
Ditherer := nil;
DIBResult := nil;
DIBSource := nil;
Palette := 0;
try // Protect above resources
// Dithering and color mapper only supports 24 bit bitmaps,
// so we have convert the source bitmap to the appropiate format.
DIBSource := TDIBReader.Create(Bitmap, pf24bit);
// Create a palette based on current options
case (ColorReduction) of
rmQuantize:
Palette := doCreateOptimizedPaletteFromSingleBitmap(DIBSource, 1 SHL ReductionBits, 8, False);
rmQuantizeWindows:
Palette := CreateOptimizedPaletteFromSingleBitmap(Bitmap, 256, 8, True);
rmNetscape:
Palette := WebPalette;
rmGrayScale:
Palette := GrayScalePalette;
rmMonochrome:
Palette := MonochromePalette;
rmWindowsGray:
Palette := WindowsGrayScalePalette;
rmWindows20:
Palette := GetStockObject(DEFAULT_PALETTE);
rmWindows256:
Palette := WindowsHalftonePalette;
rmPalette:
Palette := CopyPalette(CustomPalette);
else
exit;
end;
{ TODO -oanme -cImprovement : Gray scale conversion should be done prior to dithering/mapping. Otherwise corrected values will be converted multiple times. }
// Create a color mapper based on current options
case (ColorReduction) of
// For some strange reason my fast and dirty color lookup
// is more precise that Windows GetNearestPaletteIndex...
// rmWindows20:
// ColorLookup := TSlowColorLookup.Create(Palette);
// rmWindowsGray:
// ColorLookup := TGrayWindowsLookup.Create(Palette);
rmQuantize:
ColorLookup := TFastColorLookup.Create(Palette);
rmNetscape:
ColorLookup := TNetscapeColorLookup.Create(Palette);
rmGrayScale:
ColorLookup := TGrayScaleLookup.Create(Palette);
rmMonochrome:
ColorLookup := TMonochromeLookup.Create(Palette);
else
ColorLookup := TFastColorLookup.Create(Palette);
end;
// Nothing to do if palette doesn't contain any colors
if (ColorLookup.Colors = 0) then
exit;
// Create a ditherer based on current options
case (DitherMode) of
dmNearest:
Ditherer := TDitherEngine.Create(Bitmap.Width, ColorLookup);
dmFloydSteinberg:
Ditherer := TFloydSteinbergDitherer.Create(Bitmap.Width, ColorLookup);
dmStucki:
Ditherer := TStuckiDitherer.Create(Bitmap.Width, ColorLookup);
dmSierra:
Ditherer := TSierraDitherer.Create(Bitmap.Width, ColorLookup);
dmJaJuNI:
Ditherer := TJaJuNIDitherer.Create(Bitmap.Width, ColorLookup);
dmSteveArche:
Ditherer := TSteveArcheDitherer.Create(Bitmap.Width, ColorLookup);
dmBurkes:
Ditherer := TBurkesDitherer.Create(Bitmap.Width, ColorLookup);
else
exit;
end;
// The processed bitmap is returned in pf8bit format
DIBResult := TDIBWriter.Create(Result, pf8bit, Bitmap.Width, Bitmap.Height,
Palette);
// Process the image
Row := 0;
while (Row < Bitmap.Height) do
begin
SrcScanline := DIBSource.ScanLine[Row];
DstScanline := DIBResult.ScanLine[Row];
Src := pointer(longInt(SrcScanLine) + Ditherer.Column*sizeof(TRGBTriple));
Dst := pointer(longInt(DstScanLine) + Ditherer.Column);
while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
begin
BGR := Src^;
// Dither and map a single pixel
Dst^ := Ditherer.Dither(BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue,
BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue);
inc(Src, Ditherer.Direction);
inc(Dst, Ditherer.Direction);
end;
Inc(Row);
Ditherer.NextLine;
end;
finally
if (ColorLookup <> nil) then
ColorLookup.Free;
if (Ditherer <> nil) then
Ditherer.Free;
if (DIBResult <> nil) then
DIBResult.Free;
if (DIBSource <> nil) then
DIBSource.Free;
// Must delete palette after TDIBWriter since TDIBWriter uses palette
if (Palette <> 0) then
DeleteObject(Palette);
end;
except
Result.Free;
raise;
end;
{$ifdef DEBUG_DITHERPERFORMANCE}
TimeStop := timeGetTime;
ShowMessage(format('Dithered %d pixels in %d mS, Rate %d pixels/mS (%d pixels/S)',
[Bitmap.Height*Bitmap.Width, TimeStop-TimeStart,
MulDiv(Bitmap.Height, Bitmap.Width, TimeStop-TimeStart+1),
MulDiv(Bitmap.Height, Bitmap.Width * 1000, TimeStop-TimeStart+1)]));
timeEndPeriod(5);
{$endif}
end;
{$IFDEF R_PLUS}
{$RANGECHECKS ON}
{$UNDEF R_PLUS}
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// TGIFColorMap
//
////////////////////////////////////////////////////////////////////////////////
const
InitColorMapSize = 16;
DeltaColorMapSize = 32;
//: Creates an instance of a TGIFColorMap object.
constructor TGIFColorMap.Create;
begin
inherited Create;
FColorMap := nil;
FCapacity := 0;
FCount := 0;
FOptimized := False;
end;
//: Destroys an instance of a TGIFColorMap object.
destructor TGIFColorMap.Destroy;
begin
Clear;
Changed;
inherited Destroy;
end;
//: Empties the color map.
procedure TGIFColorMap.Clear;
begin
if (FColorMap <> nil) then
FreeMem(FColorMap);
FColorMap := nil;
FCapacity := 0;
FCount := 0;
FOptimized := False;
end;
//: Converts a Windows color value to a RGB value.
class function TGIFColorMap.Color2RGB(Color: TColor): TGIFColor;
begin
Result.Blue := (Color shr 16) and $FF;
Result.Green := (Color shr 8) and $FF;
Result.Red := Color and $FF;
end;
//: Converts a RGB value to a Windows color value.
class function TGIFColorMap.RGB2Color(Color: TGIFColor): TColor;
begin
Result := (Color.Blue SHL 16) OR (Color.Green SHL 8) OR Color.Red;
end;
//: Saves the color map to a stream.
procedure TGIFColorMap.SaveToStream(Stream: TStream);
var
Dummies : integer;
Dummy : TGIFColor;
begin
if (FCount = 0) then
exit;
Stream.WriteBuffer(FColorMap^, FCount*sizeof(TGIFColor));
Dummies := (1 SHL BitsPerPixel)-FCount;
Dummy.Red := 0;
Dummy.Green := 0;
Dummy.Blue := 0;
while (Dummies > 0) do
begin
Stream.WriteBuffer(Dummy, sizeof(TGIFColor));
dec(Dummies);
end;
end;
//: Loads the color map from a stream.
procedure TGIFColorMap.LoadFromStream(Stream: TStream; Count: integer);
begin
Clear;
SetCapacity(Count);
ReadCheck(Stream, FColorMap^, Count*sizeof(TGIFColor));
FCount := Count;
end;
//: Returns the position of a color in the color map.
function TGIFColorMap.IndexOf(Color: TColor): integer;
var
RGB : TGIFColor;
begin
RGB := Color2RGB(Color);
if (FOptimized) then
begin
// Optimized palette has most frequently occuring entries first
Result := 0;
// Reverse search to (hopefully) check latest colors first
while (Result < FCount) do
with (FColorMap^[Result]) do
begin
if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
exit;
Inc(Result);
end;
Result := -1;
end else
begin
Result := FCount-1;
// Reverse search to (hopefully) check latest colors first
while (Result >= 0) do
with (FColorMap^[Result]) do
begin
if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
exit;
Dec(Result);
end;
end;
end;
procedure TGIFColorMap.SetCapacity(Size: integer);
begin
if (Size >= FCapacity) then
begin
if (Size <= InitColorMapSize) then
FCapacity := InitColorMapSize
else
FCapacity := (Size + DeltaColorMapSize - 1) DIV DeltaColorMapSize * DeltaColorMapSize;
if (FCapacity > GIFMaxColors) then
FCapacity := GIFMaxColors;
ReallocMem(FColorMap, FCapacity * sizeof(TGIFColor));
end;
end;
//: Imports a Windows palette into the color map.
procedure TGIFColorMap.ImportPalette(Palette: HPalette);
type
PalArray = array[byte] of TPaletteEntry;
var
Pal : PalArray;
NewCount : integer;
i : integer;
begin
Clear;
NewCount := GetPaletteEntries(Palette, 0, 256, pal);
if (NewCount = 0) then
exit;
SetCapacity(NewCount);
for i := 0 to NewCount-1 do
with FColorMap[i], Pal[i] do
begin
Red := peRed;
Green := peGreen;
Blue := peBlue;
end;
FCount := NewCount;
Changed;
end;
//: Imports a color map structure into the color map.
procedure TGIFColorMap.ImportColorMap(Map: TColorMap; Count: integer);
begin
Clear;
if (Count = 0) then
exit;
SetCapacity(Count);
FCount := Count;
System.Move(Map, FColorMap^, FCount * sizeof(TGIFColor));
Changed;
end;
//: Imports a Windows palette structure into the color map.
procedure TGIFColorMap.ImportColorTable(Pal: pointer; Count: integer);
var
i : integer;
begin
Clear;
if (Count = 0) then
exit;
SetCapacity(Count);
for i := 0 to Count-1 do
with FColorMap[i], PRGBQuadArray(Pal)[i] do
begin
Red := rgbRed;
Green := rgbGreen;
Blue := rgbBlue;
end;
FCount := Count;
Changed;
end;
//: Imports the color table of a DIB into the color map.
procedure TGIFColorMap.ImportDIBColors(Handle: HDC);
var
Pal : Pointer;
NewCount : integer;
begin
Clear;
GetMem(Pal, sizeof(TRGBQuad) * 256);
try
NewCount := GetDIBColorTable(Handle, 0, 256, Pal^);
ImportColorTable(Pal, NewCount);
finally
FreeMem(Pal);
end;
Changed;
end;
//: Creates a Windows palette from the color map.
function TGIFColorMap.ExportPalette: HPalette;
var
Pal : TMaxLogPalette;
i : Integer;
begin
if (Count = 0) then
begin
Result := 0;
exit;
end;
Pal.palVersion := $300;
Pal.palNumEntries := Count;
for i := 0 to Count-1 do
with FColorMap[i], Pal.palPalEntry[i] do
begin
peRed := Red;
peGreen := Green;
peBlue := Blue;
peFlags := PC_NOCOLLAPSE; { TODO -oanme -cImprovement : Verify that PC_NOCOLLAPSE is the correct value to use. }
end;
Result := CreatePalette(PLogPalette(@Pal)^);
end;
//: Adds a color to the color map.
function TGIFColorMap.Add(Color: TColor): integer;
begin
if (FCount >= GIFMaxColors) then
// Color map full
Error(sTooManyColors);
Result := FCount;
if (Result >= FCapacity) then
SetCapacity(FCount+1);
FColorMap^[FCount] := Color2RGB(Color);
inc(FCount);
FOptimized := False;
Changed;
end;
function TGIFColorMap.AddUnique(Color: TColor): integer;
begin
// Look up color before add (same as IndexOf)
Result := IndexOf(Color);
if (Result >= 0) then
// Color already in map
exit;
Result := Add(Color);
end;
//: Removes a color from the color map.
procedure TGIFColorMap.Delete(Index: integer);
begin
if (Index < 0) or (Index >= FCount) then
// Color index out of range
Error(sBadColorIndex);
dec(FCount);
if (Index < FCount) then
System.Move(FColorMap^[Index + 1], FColorMap^[Index], (FCount - Index)* sizeof(TGIFColor));
FOptimized := False;
Changed;
end;
function TGIFColorMap.GetColor(Index: integer): TColor;
begin
if (Index < 0) or (Index >= FCount) then
begin
// Color index out of range
Warning(gsWarning, sBadColorIndex);
// Raise an exception if the color map is empty
if (FCount = 0) then
Error(sEmptyColorMap);
// Default to color index 0
Index := 0;
end;
Result := RGB2Color(FColorMap^[Index]);
end;
procedure TGIFColorMap.SetColor(Index: integer; Value: TColor);
begin
if (Index < 0) or (Index >= FCount) then
// Color index out of range
Error(sBadColorIndex);
FColorMap^[Index] := Color2RGB(Value);
Changed;
end;
function TGIFColorMap.DoOptimize: boolean;
var
Usage : TColormapHistogram;
TempMap : array[0..255] of TGIFColor;
ReverseMap : TColormapReverse;
i : integer;
LastFound : boolean;
NewCount : integer;
T : TUsageCount;
Pivot : integer;
procedure QuickSort(iLo, iHi: Integer);
var
Lo, Hi: Integer;
begin
repeat
Lo := iLo;
Hi := iHi;
Pivot := Usage[(iLo + iHi) SHR 1].Count;
repeat
while (Usage[Lo].Count - Pivot > 0) do inc(Lo);
while (Usage[Hi].Count - Pivot < 0) do dec(Hi);
if (Lo <= Hi) then
begin
T := Usage[Lo];
Usage[Lo] := Usage[Hi];
Usage[Hi] := T;
inc(Lo);
dec(Hi);
end;
until (Lo > Hi);
if (iLo < Hi) then
QuickSort(iLo, Hi);
iLo := Lo;
until (Lo >= iHi);
end;
begin
if (FCount <= 1) then
begin
Result := False;
exit;
end;
FOptimized := True;
Result := True;
BuildHistogram(Usage);
(*
** Sort according to usage count
*)
QuickSort(0, FCount-1);
(*
** Test for table already sorted
*)
for i := 0 to FCount-1 do
if (Usage[i].Index <> i) then
break;
if (i = FCount) then
exit;
(*
** Build old to new map
*)
for i := 0 to FCount-1 do
ReverseMap[Usage[i].Index] := i;
MapImages(ReverseMap);
(*
** Reorder colormap
*)
LastFound := False;
NewCount := FCount;
Move(FColorMap^, TempMap, FCount * sizeof(TGIFColor));
for i := 0 to FCount-1 do
begin
FColorMap^[ReverseMap[i]] := TempMap[i];
// Find last used color index
if (Usage[i].Count = 0) and not(LastFound) then
begin
LastFound := True;
NewCount := i;
end;
end;
FCount := NewCount;
Changed;
end;
function TGIFColorMap.GetBitsPerPixel: integer;
begin
Result := Colors2bpp(FCount);
end;
//: Copies one color map to another.
procedure TGIFColorMap.Assign(Source: TPersistent);
begin
if (Source is TGIFColorMap) then
begin
Clear;
FCapacity := TGIFColorMap(Source).FCapacity;
FCount := TGIFColorMap(Source).FCount;
FOptimized := TGIFColorMap(Source).FOptimized;
FColorMap := AllocMem(FCapacity * sizeof(TGIFColor));
System.Move(TGIFColorMap(Source).FColorMap^, FColorMap^, FCount * sizeof(TGIFColor));
Changed;
end else
inherited Assign(Source);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFItem
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFItem.Create(GIFImage: TGIFImage);
begin
inherited Create;
FGIFImage := GIFImage;
end;
procedure TGIFItem.Warning(Severity: TGIFSeverity; Message: string);
begin
FGIFImage.Warning(self, Severity, Message);
end;
function TGIFItem.GetVersion: TGIFVersion;
begin
Result := gv87a;
end;
procedure TGIFItem.LoadFromFile(const Filename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(Filename, fmOpenRead OR fmShareDenyWrite);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGIFItem.SaveToFile(const Filename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(Filename, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFList
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFList.Create(Image: TGIFImage);
begin
inherited Create;
FImage := Image;
FItems := TList.Create;
end;
destructor TGIFList.Destroy;
begin
Clear;
FItems.Free;
inherited Destroy;
end;
function TGIFList.GetItem(Index: Integer): TGIFItem;
begin
Result := TGIFItem(FItems[Index]);
end;
procedure TGIFList.SetItem(Index: Integer; Item: TGIFItem);
begin
FItems[Index] := Item;
end;
function TGIFList.GetCount: Integer;
begin
Result := FItems.Count;
end;
function TGIFList.Add(Item: TGIFItem): Integer;
begin
Result := FItems.Add(Item);
end;
procedure TGIFList.Clear;
begin
while (FItems.Count > 0) do
Delete(0);
end;
procedure TGIFList.Delete(Index: Integer);
var
Item : TGIFItem;
begin
Item := TGIFItem(FItems[Index]);
// Delete before item is destroyed to avoid recursion
FItems.Delete(Index);
Item.Free;
end;
procedure TGIFList.Exchange(Index1, Index2: Integer);
begin
FItems.Exchange(Index1, Index2);
end;
function TGIFList.First: TGIFItem;
begin
Result := TGIFItem(FItems.First);
end;
function TGIFList.IndexOf(Item: TGIFItem): Integer;
begin
Result := FItems.IndexOf(Item);
end;
procedure TGIFList.Insert(Index: Integer; Item: TGIFItem);
begin
FItems.Insert(Index, Item);
end;
function TGIFList.Last: TGIFItem;
begin
Result := TGIFItem(FItems.Last);
end;
procedure TGIFList.Move(CurIndex, NewIndex: Integer);
begin
FItems.Move(CurIndex, NewIndex);
end;
function TGIFList.Remove(Item: TGIFItem): Integer;
begin
// Note: TGIFList.Remove must not destroy item
Result := FItems.Remove(Item);
end;
procedure TGIFList.SaveToStream(Stream: TStream);
var
i : integer;
begin
for i := 0 to FItems.Count-1 do
TGIFItem(FItems[i]).SaveToStream(Stream);
end;
procedure TGIFList.Warning(Severity: TGIFSeverity; Message: string);
begin
Image.Warning(self, Severity, Message);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFGlobalColorMap
//
////////////////////////////////////////////////////////////////////////////////
type
TGIFGlobalColorMap = class(TGIFColorMap)
private
FHeader : TGIFHeader;
protected
procedure Warning(Severity: TGIFSeverity; Message: string); override;
procedure BuildHistogram(var Histogram: TColormapHistogram); override;
procedure MapImages(var Map: TColormapReverse); override;
public
constructor Create(HeaderItem: TGIFHeader);
function Optimize: boolean; override;
procedure Changed; override;
end;
constructor TGIFGlobalColorMap.Create(HeaderItem: TGIFHeader);
begin
Inherited Create;
FHeader := HeaderItem;
end;
procedure TGIFGlobalColorMap.Warning(Severity: TGIFSeverity; Message: string);
begin
FHeader.Image.Warning(self, Severity, Message);
end;
procedure TGIFGlobalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
var
Pixel ,
LastPixel : PChar;
i : integer;
begin
(*
** Init histogram
*)
for i := 0 to Count-1 do
begin
Histogram[i].Index := i;
Histogram[i].Count := 0;
end;
for i := 0 to FHeader.Image.Images.Count-1 do
if (FHeader.Image.Images[i].ActiveColorMap = self) then
begin
Pixel := FHeader.Image.Images[i].Data;
LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;
(*
** Sum up usage count for each color
*)
while (Pixel < LastPixel) do
begin
inc(Histogram[ord(Pixel^)].Count);
inc(Pixel);
end;
end;
end;
procedure TGIFGlobalColorMap.MapImages(var Map: TColormapReverse);
var
Pixel ,
LastPixel : PChar;
i : integer;
begin
for i := 0 to FHeader.Image.Images.Count-1 do
if (FHeader.Image.Images[i].ActiveColorMap = self) then
begin
Pixel := FHeader.Image.Images[i].Data;
LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;
(*
** Reorder all pixel to new map
*)
while (Pixel < LastPixel) do
begin
Pixel^ := chr(Map[ord(Pixel^)]);
inc(Pixel);
end;
(*
** Reorder transparent colors
*)
if (FHeader.Image.Images[i].Transparent) then
FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex :=
Map[FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex];
end;
end;
function TGIFGlobalColorMap.Optimize: boolean;
begin
{ Optimize with first image, Remove unused colors if only one image }
if (FHeader.Image.Images.Count > 0) then
Result := DoOptimize
else
Result := False;
end;
procedure TGIFGlobalColorMap.Changed;
begin
FHeader.Image.Palette := 0;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFHeader
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFHeader.Create(GIFImage: TGIFImage);
begin
inherited Create(GIFImage);
FColorMap := TGIFGlobalColorMap.Create(self);
Clear;
end;
destructor TGIFHeader.Destroy;
begin
FColorMap.Free;
inherited Destroy;
end;
procedure TGIFHeader.Clear;
begin
FColorMap.Clear;
FLogicalScreenDescriptor.ScreenWidth := 0;
FLogicalScreenDescriptor.ScreenHeight := 0;
FLogicalScreenDescriptor.PackedFields := 0;
FLogicalScreenDescriptor.BackgroundColorIndex := 0;
FLogicalScreenDescriptor.AspectRatio := 0;
end;
procedure TGIFHeader.Assign(Source: TPersistent);
begin
if (Source is TGIFHeader) then
begin
ColorMap.Assign(TGIFHeader(Source).ColorMap);
FLogicalScreenDescriptor := TGIFHeader(Source).FLogicalScreenDescriptor;
end else
if (Source is TGIFColorMap) then
begin
Clear;
ColorMap.Assign(TGIFColorMap(Source));
end else
inherited Assign(Source);
end;
type
TGIFHeaderRec = packed record
Signature: array[0..2] of char; { contains 'GIF' }
Version: TGIFVersionRec; { '87a' or '89a' }
end;
const
{ logical screen descriptor packed field masks }
lsdGlobalColorTable = $80; { set if global color table follows L.S.D. }
lsdColorResolution = $70; { Color resolution - 3 bits }
lsdSort = $08; { set if global color table is sorted - 1 bit }
lsdColorTableSize = $07; { size of global color table - 3 bits }
{ Actual size = 2^value+1 - value is 3 bits }
procedure TGIFHeader.Prepare;
var
pack : BYTE;
begin
Pack := $00;
if (ColorMap.Count > 0) then
begin
Pack := lsdGlobalColorTable;
if (ColorMap.Optimized) then
Pack := Pack OR lsdSort;
end;
// Note: The SHL below was SHL 5 in the original source, but that looks wrong
Pack := Pack OR ((Image.ColorResolution SHL 4) AND lsdColorResolution);
Pack := Pack OR ((Image.BitsPerPixel-1) AND lsdColorTableSize);
FLogicalScreenDescriptor.PackedFields := Pack;
end;
procedure TGIFHeader.SaveToStream(Stream: TStream);
var
GifHeader : TGIFHeaderRec;
v : TGIFVersion;
begin
v := Image.Version;
if (v = gvUnknown) then
Error(sBadVersion);
GifHeader.Signature := 'GIF';
GifHeader.Version := GIFVersions[v];
Prepare;
Stream.Write(GifHeader, sizeof(GifHeader));
Stream.Write(FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));
if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
ColorMap.SaveToStream(Stream);
end;
procedure TGIFHeader.LoadFromStream(Stream: TStream);
var
GifHeader : TGIFHeaderRec;
ColorCount : integer;
Position : integer;
begin
Position := Stream.Position;
ReadCheck(Stream, GifHeader, sizeof(GifHeader));
if (uppercase(GifHeader.Signature) <> 'GIF') then
begin
// Attempt recovery in case we are reading a GIF stored in a form by rxLib
Stream.Position := Position;
// Seek past size stored in stream
Stream.Seek(sizeof(longInt), soFromCurrent);
// Attempt to read signature again
ReadCheck(Stream, GifHeader, sizeof(GifHeader));
if (uppercase(GifHeader.Signature) <> 'GIF') then
Error(sBadSignature);
end;
ReadCheck(Stream, FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));
if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
begin
ColorCount := 2 SHL (FLogicalScreenDescriptor.PackedFields AND lsdColorTableSize);
if (ColorCount < 2) or (ColorCount > 256) then
Error(sScreenBadColorSize);
ColorMap.LoadFromStream(Stream, ColorCount)
end else
ColorMap.Clear;
end;
function TGIFHeader.GetVersion: TGIFVersion;
begin
if (FColorMap.Optimized) or (AspectRatio <> 0) then
Result := gv89a
else
Result := inherited GetVersion;
end;
function TGIFHeader.GetBackgroundColor: TColor;
begin
Result := FColorMap[BackgroundColorIndex];
end;
procedure TGIFHeader.SetBackgroundColor(Color: TColor);
begin
BackgroundColorIndex := FColorMap.AddUnique(Color);
end;
procedure TGIFHeader.SetBackgroundColorIndex(Index: BYTE);
begin
if ((Index >= FColorMap.Count) and (FColorMap.Count > 0)) then
begin
Warning(gsWarning, sBadColorIndex);
Index := 0;
end;
FLogicalScreenDescriptor.BackgroundColorIndex := Index;
end;
function TGIFHeader.GetBitsPerPixel: integer;
begin
Result := FColorMap.BitsPerPixel;
end;
function TGIFHeader.GetColorResolution: integer;
begin
Result := FColorMap.BitsPerPixel-1;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFLocalColorMap
//
////////////////////////////////////////////////////////////////////////////////
type
TGIFLocalColorMap = class(TGIFColorMap)
private
FSubImage : TGIFSubImage;
protected
procedure Warning(Severity: TGIFSeverity; Message: string); override;
procedure BuildHistogram(var Histogram: TColormapHistogram); override;
procedure MapImages(var Map: TColormapReverse); override;
public
constructor Create(SubImage: TGIFSubImage);
function Optimize: boolean; override;
procedure Changed; override;
end;
constructor TGIFLocalColorMap.Create(SubImage: TGIFSubImage);
begin
Inherited Create;
FSubImage := SubImage;
end;
procedure TGIFLocalColorMap.Warning(Severity: TGIFSeverity; Message: string);
begin
FSubImage.Image.Warning(self, Severity, Message);
end;
procedure TGIFLocalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
var
Pixel ,
LastPixel : PChar;
i : integer;
begin
Pixel := FSubImage.Data;
LastPixel := Pixel + FSubImage.Width * FSubImage.Height;
(*
** Init histogram
*)
for i := 0 to Count-1 do
begin
Histogram[i].Index := i;
Histogram[i].Count := 0;
end;
(*
** Sum up usage count for each color
*)
while (Pixel < LastPixel) do
begin
inc(Histogram[ord(Pixel^)].Count);
inc(Pixel);
end;
end;
procedure TGIFLocalColorMap.MapImages(var Map: TColormapReverse);
var
Pixel ,
LastPixel : PChar;
begin
Pixel := FSubImage.Data;
LastPixel := Pixel + FSubImage.Width * FSubImage.Height;
(*
** Reorder all pixel to new map
*)
while (Pixel < LastPixel) do
begin
Pixel^ := chr(Map[ord(Pixel^)]);
inc(Pixel);
end;
(*
** Reorder transparent colors
*)
if (FSubImage.Transparent) then
FSubImage.GraphicControlExtension.TransparentColorIndex :=
Map[FSubImage.GraphicControlExtension.TransparentColorIndex];
end;
function TGIFLocalColorMap.Optimize: boolean;
begin
Result := DoOptimize;
end;
procedure TGIFLocalColorMap.Changed;
begin
FSubImage.Palette := 0;
end;
////////////////////////////////////////////////////////////////////////////////
//
// LZW Decoder
//
////////////////////////////////////////////////////////////////////////////////
const
GIFCodeBits = 12; // Max number of bits per GIF token code
GIFCodeMax = (1 SHL GIFCodeBits)-1;// Max GIF token code
// 12 bits = 4095
StackSize = (2 SHL GIFCodeBits); // Size of decompression stack
TableSize = (1 SHL GIFCodeBits); // Size of decompression table
procedure TGIFSubImage.Decompress(Stream: TStream);
var
table0 : array[0..TableSize-1] of integer;
table1 : array[0..TableSize-1] of integer;
firstcode, oldcode : integer;
buf : array[0..257] of BYTE;
Dest : PChar;
v ,
xpos, ypos, pass : integer;
stack : array[0..StackSize-1] of integer;
Source : ^integer;
BitsPerCode : integer; // number of CodeTableBits/code
InitialBitsPerCode : BYTE;
MaxCode : integer; // maximum code, given BitsPerCode
MaxCodeSize : integer;
ClearCode : integer; // Special code to signal "Clear table"
EOFCode : integer; // Special code to signal EOF
step : integer;
i : integer;
StartBit , // Index of bit buffer start
LastBit , // Index of last bit in buffer
LastByte : integer; // Index of last byte in buffer
get_done ,
return_clear ,
ZeroBlock : boolean;
ClearValue : BYTE;
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
TimeStartDecompress ,
TimeStopDecompress : DWORD;
{$endif}
function nextCode(BitsPerCode: integer): integer;
const
masks: array[0..15] of integer =
($0000, $0001, $0003, $0007,
$000f, $001f, $003f, $007f,
$00ff, $01ff, $03ff, $07ff,
$0fff, $1fff, $3fff, $7fff);
var
StartIndex, EndIndex : integer;
ret : integer;
EndBit : integer;
count : BYTE;
begin
if (return_clear) then
begin
return_clear := False;
Result := ClearCode;
exit;
end;
EndBit := StartBit + BitsPerCode;
if (EndBit >= LastBit) then
begin
if (get_done) then
begin
if (StartBit >= LastBit) then
Warning(gsWarning, sDecodeTooFewBits);
Result := -1;
exit;
end;
buf[0] := buf[LastByte-2];
buf[1] := buf[LastByte-1];
if (Stream.Read(count, 1) <> 1) then
begin
Result := -1;
exit;
end;
if (count = 0) then
begin
ZeroBlock := True;
get_done := TRUE;
end else
begin
// Handle premature end of file
if (Stream.Size - Stream.Position < Count) then
begin
Warning(gsWarning, sOutOfData);
// Not enough data left - Just read as much as we can get
Count := Stream.Size - Stream.Position;
end;
if (Count <> 0) then
ReadCheck(Stream, Buf[2], Count);
end;
LastByte := 2 + count;
StartBit := (StartBit - LastBit) + 16;
LastBit := LastByte * 8;
EndBit := StartBit + BitsPerCode;
end;
EndIndex := EndBit DIV 8;
StartIndex := StartBit DIV 8;
ASSERT(StartIndex <= high(buf), 'StartIndex too large');
if (StartIndex = EndIndex) then
ret := buf[StartIndex]
else
if (StartIndex + 1 = EndIndex) then
ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8)
else
ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8) OR (buf[StartIndex+2] SHL 16);
ret := (ret SHR (StartBit AND $0007)) AND masks[BitsPerCode];
Inc(StartBit, BitsPerCode);
Result := ret;
end;
function NextLZW: integer;
var
code, incode : integer;
i : integer;
b : BYTE;
begin
code := nextCode(BitsPerCode);
while (code >= 0) do
begin
if (code = ClearCode) then
begin
ASSERT(ClearCode < TableSize, 'ClearCode too large');
for i := 0 to ClearCode-1 do
begin
table0[i] := 0;
table1[i] := i;
end;
for i := ClearCode to TableSize-1 do
begin
table0[i] := 0;
table1[i] := 0;
end;
BitsPerCode := InitialBitsPerCode+1;
MaxCodeSize := 2 * ClearCode;
MaxCode := ClearCode + 2;
Source := @stack;
repeat
firstcode := nextCode(BitsPerCode);
oldcode := firstcode;
until (firstcode <> ClearCode);
Result := firstcode;
exit;
end;
if (code = EOFCode) then
begin
Result := -2;
if (ZeroBlock) then
exit;
// Eat rest of data blocks
if (Stream.Read(b, 1) <> 1) then
exit;
while (b <> 0) do
begin
Stream.Seek(b, soFromCurrent);
if (Stream.Read(b, 1) <> 1) then
exit;
end;
exit;
end;
incode := code;
if (code >= MaxCode) then
begin
Source^ := firstcode;
Inc(Source);
code := oldcode;
end;
ASSERT(Code < TableSize, 'Code too large');
while (code >= ClearCode) do
begin
Source^ := table1[code];
Inc(Source);
if (code = table0[code]) then
Error(sDecodeCircular);
code := table0[code];
ASSERT(Code < TableSize, 'Code too large');
end;
firstcode := table1[code];
Source^ := firstcode;
Inc(Source);
code := MaxCode;
if (code <= GIFCodeMax) then
begin
table0[code] := oldcode;
table1[code] := firstcode;
Inc(MaxCode);
if ((MaxCode >= MaxCodeSize) and (MaxCodeSize <= GIFCodeMax)) then
begin
MaxCodeSize := MaxCodeSize * 2;
Inc(BitsPerCode);
end;
end;
oldcode := incode;
if (longInt(Source) > longInt(@stack)) then
begin
Dec(Source);
Result := Source^;
exit;
end
end;
Result := code;
end;
function readLZW: integer;
begin
if (longInt(Source) > longInt(@stack)) then
begin
Dec(Source);
Result := Source^;
end else
Result := NextLZW;
end;
begin
NewImage;
// Clear image data in case decompress doesn't complete
if (Transparent) then
// Clear to transparent color
ClearValue := GraphicControlExtension.GetTransparentColorIndex
else
// Clear to first color
ClearValue := 0;
FillChar(FData^, FDataSize, ClearValue);
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
TimeStartDecompress := timeGetTime;
{$endif}
(*
** Read initial code size in bits from stream
*)
if (Stream.Read(InitialBitsPerCode, 1) <> 1) then
exit;
(*
** Initialize the Compression routines
*)
BitsPerCode := InitialBitsPerCode + 1;
ClearCode := 1 SHL InitialBitsPerCode;
EOFCode := ClearCode + 1;
MaxCodeSize := 2 * ClearCode;
MaxCode := ClearCode + 2;
StartBit := 0;
LastBit := 0;
LastByte := 2;
ZeroBlock := False;
get_done := False;
return_clear := TRUE;
Source := @stack;
try
if (Interlaced) then
begin
ypos := 0;
pass := 0;
step := 8;
for i := 0 to Height-1 do
begin
Dest := FData + Width * ypos;
for xpos := 0 to width-1 do
begin
v := readLZW;
if (v < 0) then
exit;
Dest^ := char(v);
Inc(Dest);
end;
Inc(ypos, step);
if (ypos >= height) then
repeat
if (pass > 0) then
step := step DIV 2;
Inc(pass);
ypos := step DIV 2;
until (ypos < height);
end;
end else
begin
Dest := FData;
for ypos := 0 to (height * width)-1 do
begin
v := readLZW;
if (v < 0) then
exit;
Dest^ := char(v);
Inc(Dest);
end;
end;
finally
if (readLZW >= 0) then
;
// raise GIFException.Create('Too much input data, ignoring extra...');
end;
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
TimeStopDecompress := timeGetTime;
ShowMessage(format('Decompressed %d pixels in %d mS, Rate %d pixels/mS',
[Height*Width, TimeStopDecompress-TimeStartDecompress,
(Height*Width) DIV (TimeStopDecompress-TimeStartDecompress+1)]));
{$endif}
end;
////////////////////////////////////////////////////////////////////////////////
//
// LZW Encoder stuff
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// LZW Encoder THashTable
////////////////////////////////////////////////////////////////////////////////
const
HashKeyBits = 13; // Max number of bits per Hash Key
HashSize = 8009; // Size of hash table
// Must be prime
// Must be > than HashMaxCode
// Must be < than HashMaxKey
HashKeyMax = (1 SHL HashKeyBits)-1;// Max hash key value
// 13 bits = 8191
HashKeyMask = HashKeyMax; // $1FFF
GIFCodeMask = GIFCodeMax; // $0FFF
HashEmpty = $000FFFFF; // 20 bits
type
// A Hash Key is 20 bits wide.
// - The lower 8 bits are the postfix character (the new pixel).
// - The upper 12 bits are the prefix code (the GIF token).
// A KeyInt must be able to represent the integer values -1..(2^20)-1
KeyInt = longInt; // 32 bits
CodeInt = SmallInt; // 16 bits
THashArray = array[0..HashSize-1] of KeyInt;
PHashArray = ^THashArray;
THashTable = class
{$ifdef DEBUG_HASHPERFORMANCE}
CountLookupFound : longInt;
CountMissFound : longInt;
CountLookupNotFound : longInt;
CountMissNotFound : longInt;
{$endif}
HashTable: PHashArray;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Insert(Key: KeyInt; Code: CodeInt);
function Lookup(Key: KeyInt): CodeInt;
end;
function HashKey(Key: KeyInt): CodeInt;
begin
Result := ((Key SHR (GIFCodeBits-8)) XOR Key) MOD HashSize;
end;
function NextHashKey(HKey: CodeInt): CodeInt;
var
disp : CodeInt;
begin
(*
** secondary hash (after G. Knott)
*)
disp := HashSize - HKey;
if (HKey = 0) then
disp := 1;
// disp := 13; // disp should be prime relative to HashSize, but
// it doesn't seem to matter here...
dec(HKey, disp);
if (HKey < 0) then
inc(HKey, HashSize);
Result := HKey;
end;
constructor THashTable.Create;
begin
ASSERT(longInt($FFFFFFFF) = -1, 'TGIFImage implementation assumes $FFFFFFFF = -1');
inherited Create;
GetMem(HashTable, sizeof(THashArray));
Clear;
{$ifdef DEBUG_HASHPERFORMANCE}
CountLookupFound := 0;
CountMissFound := 0;
CountLookupNotFound := 0;
CountMissNotFound := 0;
{$endif}
end;
destructor THashTable.Destroy;
begin
{$ifdef DEBUG_HASHPERFORMANCE}
ShowMessage(
Format('Found: %d HitRate: %.2f',
[CountLookupFound, (CountLookupFound+1)/(CountMissFound+1)])+#13+
Format('Not found: %d HitRate: %.2f',
[CountLookupNotFound, (CountLookupNotFound+1)/(CountMissNotFound+1)]));
{$endif}
FreeMem(HashTable);
inherited Destroy;
end;
// Clear hash table and fill with empty slots (doh!)
procedure THashTable.Clear;
{$ifdef DEBUG_HASHFILLFACTOR}
var
i ,
Count : longInt;
{$endif}
begin
{$ifdef DEBUG_HASHFILLFACTOR}
Count := 0;
for i := 0 to HashSize-1 do
if (HashTable[i] SHR GIFCodeBits <> HashEmpty) then
inc(Count);
ShowMessage(format('Size: %d, Filled: %d, Rate %.4f',
[HashSize, Count, Count/HashSize]));
{$endif}
FillChar(HashTable^, sizeof(THashArray), $FF);
end;
// Insert new key/value pair into hash table
procedure THashTable.Insert(Key: KeyInt; Code: CodeInt);
var
HKey : CodeInt;
begin
// Create hash key from prefix string
HKey := HashKey(Key);
// Scan for empty slot
// while (HashTable[HKey] SHR GIFCodeBits <> HashEmpty) do { Unoptimized }
while (HashTable[HKey] AND (HashEmpty SHL GIFCodeBits) <> (HashEmpty SHL GIFCodeBits)) do { Optimized }
HKey := NextHashKey(HKey);
// Fill slot with key/value pair
HashTable[HKey] := (Key SHL GIFCodeBits) OR (Code AND GIFCodeMask);
end;
// Search for key in hash table.
// Returns value if found or -1 if not
function THashTable.Lookup(Key: KeyInt): CodeInt;
var
HKey : CodeInt;
HTKey : KeyInt;
{$ifdef DEBUG_HASHPERFORMANCE}
n : LongInt;
{$endif}
begin
// Create hash key from prefix string
HKey := HashKey(Key);
{$ifdef DEBUG_HASHPERFORMANCE}
n := 0;
{$endif}
// Scan table for key
// HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
Key := Key SHL GIFCodeBits; { Optimized }
HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
// while (HTKey <> HashEmpty) do { Unoptimized }
while (HTKey <> HashEmpty SHL GIFCodeBits) do { Optimized }
begin
if (Key = HTKey) then
begin
// Extract and return value
Result := HashTable[HKey] AND GIFCodeMask;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(CountLookupFound);
inc(CountMissFound, n);
{$endif}
exit;
end;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(n);
{$endif}
// Try next slot
HKey := NextHashKey(HKey);
// HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
end;
// Found empty slot - key doesn't exist
Result := -1;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(CountLookupNotFound);
inc(CountMissNotFound, n);
{$endif}
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFStream - Abstract GIF block stream
//
// Descendants from TGIFStream either reads or writes data in blocks
// of up to 255 bytes. These blocks are organized as a leading byte
// containing the number of bytes in the block (exclusing the count
// byte itself), followed by the data (up to 254 bytes of data).
////////////////////////////////////////////////////////////////////////////////
type
TGIFStream = class(TStream)
private
FOnWarning : TGIFWarning;
FStream : TStream;
FOnProgress : TNotifyEvent;
FBuffer : array [BYTE] of Char;
FBufferCount : integer;
protected
constructor Create(Stream: TStream);
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure Progress(Sender: TObject); dynamic;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
public
property Warning: TGIFWarning read FOnWarning write FOnWarning;
end;
constructor TGIFStream.Create(Stream: TStream);
begin
inherited Create;
FStream := Stream;
FBufferCount := 1; // Reserve first byte of buffer for length
end;
procedure TGIFStream.Progress(Sender: TObject);
begin
if Assigned(FOnProgress) then
FOnProgress(Sender);
end;
function TGIFStream.Write(const Buffer; Count: Longint): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
function TGIFStream.Read(var Buffer; Count: Longint): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
function TGIFStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFReader - GIF block reader
////////////////////////////////////////////////////////////////////////////////
type
TGIFReader = class(TGIFStream)
public
constructor Create(Stream: TStream);
function Read(var Buffer; Count: Longint): Longint; override;
end;
constructor TGIFReader.Create(Stream: TStream);
begin
inherited Create(Stream);
FBufferCount := 0;
end;
function TGIFReader.Read(var Buffer; Count: Longint): Longint;
var
n : integer;
Dst : PChar;
size : BYTE;
begin
Dst := @Buffer;
Result := 0;
while (Count > 0) do
begin
// Get data from buffer
while (FBufferCount > 0) and (Count > 0) do
begin
if (FBufferCount > Count) then
n := Count
else
n := FBufferCount;
Move(FBuffer, Dst^, n);
dec(FBufferCount, n);
dec(Count, n);
inc(Result, n);
inc(Dst, n);
end;
// Refill buffer when it becomes empty
if (FBufferCount <= 0) then
begin
FStream.Read(size, 1);
{ TODO -oanme -cImprovement : Should be handled as a warning instead of an error. }
if (size >= 255) then
Error('GIF block too large');
FBufferCount := size;
if (FBufferCount > 0) then
begin
n := FStream.Read(FBuffer, size);
if (n = FBufferCount) then
begin
Warning(self, gsWarning, sOutOfData);
break;
end;
end else
break;
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFWriter - GIF block writer
////////////////////////////////////////////////////////////////////////////////
type
TGIFWriter = class(TGIFStream)
private
FOutputDirty : boolean;
protected
procedure FlushBuffer;
public
constructor Create(Stream: TStream);
destructor Destroy; override;
function Write(const Buffer; Count: Longint): Longint; override;
function WriteByte(Value: BYTE): Longint;
end;
constructor TGIFWriter.Create(Stream: TStream);
begin
inherited Create(Stream);
FBufferCount := 1; // Reserve first byte of buffer for length
FOutputDirty := False;
end;
destructor TGIFWriter.Destroy;
begin
inherited Destroy;
if (FOutputDirty) then
FlushBuffer;
end;
procedure TGIFWriter.FlushBuffer;
begin
if (FBufferCount <= 0) then
exit;
FBuffer[0] := char(FBufferCount-1); // Block size excluding the count
FStream.WriteBuffer(FBuffer, FBufferCount);
FBufferCount := 1; // Reserve first byte of buffer for length
FOutputDirty := False;
end;
function TGIFWriter.Write(const Buffer; Count: Longint): Longint;
var
n : integer;
Src : PChar;
begin
Result := Count;
FOutputDirty := True;
Src := @Buffer;
while (Count > 0) do
begin
// Move data to the internal buffer in 255 byte chunks
while (FBufferCount < sizeof(FBuffer)) and (Count > 0) do
begin
n := sizeof(FBuffer) - FBufferCount;
if (n > Count) then
n := Count;
Move(Src^, FBuffer[FBufferCount], n);
inc(Src, n);
inc(FBufferCount, n);
dec(Count, n);
end;
// Flush the buffer when it is full
if (FBufferCount >= sizeof(FBuffer)) then
FlushBuffer;
end;
end;
function TGIFWriter.WriteByte(Value: BYTE): Longint;
begin
Result := Write(Value, 1);
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFEncoder - Abstract encoder
////////////////////////////////////////////////////////////////////////////////
type
TGIFEncoder = class(TObject)
protected
FOnWarning : TGIFWarning;
MaxColor : integer;
BitsPerPixel : BYTE; // Bits per pixel of image
Stream : TStream; // Output stream
Width , // Width of image in pixels
Height : integer; // height of image in pixels
Interlace : boolean; // Interlace flag (True = interlaced image)
Data : PChar; // Pointer to pixel data
GIFStream : TGIFWriter; // Output buffer
OutputBucket : longInt; // Output bit bucket
OutputBits : integer; // Current # of bits in bucket
ClearFlag : Boolean; // True if dictionary has just been cleared
BitsPerCode , // Current # of bits per code
InitialBitsPerCode : integer; // Initial # of bits per code after
// dictionary has been cleared
MaxCode : CodeInt; // maximum code, given BitsPerCode
ClearCode : CodeInt; // Special output code to signal "Clear table"
EOFCode : CodeInt; // Special output code to signal EOF
BaseCode : CodeInt; // ...
Pixel : PChar; // Pointer to current pixel
cX , // Current X counter (Width - X)
Y : integer; // Current Y
Pass : integer; // Interlace pass
function MaxCodesFromBits(Bits: integer): CodeInt;
procedure Output(Value: integer); virtual;
procedure Clear; virtual;
function BumpPixel: boolean;
procedure DoCompress; virtual; abstract;
public
procedure Compress(AStream: TStream; ABitsPerPixel: integer;
AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
property Warning: TGIFWarning read FOnWarning write FOnWarning;
end;
// Calculate the maximum number of codes that a given number of bits can represent
// MaxCodes := (1^bits)-1
function TGIFEncoder.MaxCodesFromBits(Bits: integer): CodeInt;
begin
Result := (CodeInt(1) SHL Bits) - 1;
end;
// Stuff bits (variable sized codes) into a buffer and output them
// a byte at a time
procedure TGIFEncoder.Output(Value: integer);
const
BitBucketMask: array[0..16] of longInt =
($0000,
$0001, $0003, $0007, $000F,
$001F, $003F, $007F, $00FF,
$01FF, $03FF, $07FF, $0FFF,
$1FFF, $3FFF, $7FFF, $FFFF);
begin
if (OutputBits > 0) then
OutputBucket :=
(OutputBucket AND BitBucketMask[OutputBits]) OR (longInt(Value) SHL OutputBits)
else
OutputBucket := Value;
inc(OutputBits, BitsPerCode);
while (OutputBits >= 8) do
begin
GIFStream.WriteByte(OutputBucket AND $FF);
OutputBucket := OutputBucket SHR 8;
dec(OutputBits, 8);
end;
if (Value = EOFCode) then
begin
// At EOF, write the rest of the buffer.
while (OutputBits > 0) do
begin
GIFStream.WriteByte(OutputBucket AND $FF);
OutputBucket := OutputBucket SHR 8;
dec(OutputBits, 8);
end;
end;
end;
procedure TGIFEncoder.Clear;
begin
// just_cleared = 1;
ClearFlag := TRUE;
Output(ClearCode);
end;
// Bump (X,Y) and data pointer to point to the next pixel
function TGIFEncoder.BumpPixel: boolean;
begin
// Bump the current X position
dec(cX);
// If we are at the end of a scan line, set cX back to the beginning
// If we are interlaced, bump Y to the appropriate spot, otherwise,
// just increment it.
if (cX <= 0) then
begin
if not(Interlace) then
begin
// Done - no more data
Result := False;
exit;
end;
cX := Width;
case (Pass) of
0:
begin
inc(Y, 8);
if (Y >= Height) then
begin
inc(Pass);
Y := 4;
end;
end;
1:
begin
inc(Y, 8);
if (Y >= Height) then
begin
inc(Pass);
Y := 2;
end;
end;
2:
begin
inc(Y, 4);
if (Y >= Height) then
begin
inc(Pass);
Y := 1;
end;
end;
3:
inc(Y, 2);
end;
if (Y >= height) then
begin
// Done - No more data
Result := False;
exit;
end;
Pixel := Data + (Y * Width);
end;
Result := True;
end;
procedure TGIFEncoder.Compress(AStream: TStream; ABitsPerPixel: integer;
AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
const
EndBlockByte = $00; // End of block marker
{$ifdef DEBUG_COMPRESSPERFORMANCE}
var
TimeStartCompress ,
TimeStopCompress : DWORD;
{$endif}
begin
MaxColor := AMaxColor;
Stream := AStream;
BitsPerPixel := ABitsPerPixel;
Width := AWidth;
Height := AHeight;
Interlace := AInterlace;
Data := AData;
if (BitsPerPixel <= 1) then
BitsPerPixel := 2;
InitialBitsPerCode := BitsPerPixel + 1;
Stream.Write(BitsPerPixel, 1);
// out_bits_init = init_bits;
BitsPerCode := InitialBitsPerCode;
MaxCode := MaxCodesFromBits(BitsPerCode);
ClearCode := (1 SHL (InitialBitsPerCode - 1));
EOFCode := ClearCode + 1;
BaseCode := EOFCode + 1;
// Clear bit bucket
OutputBucket := 0;
OutputBits := 0;
// Reset pixel counter
if (Interlace) then
cX := Width
else
cX := Width*Height;
// Reset row counter
Y := 0;
Pass := 0;
GIFStream := TGIFWriter.Create(AStream);
try
GIFStream.Warning := Warning;
if (Data <> nil) and (Height > 0) and (Width > 0) then
begin
{$ifdef DEBUG_COMPRESSPERFORMANCE}
TimeStartCompress := timeGetTime;
{$endif}
// Call compress implementation
DoCompress;
{$ifdef DEBUG_COMPRESSPERFORMANCE}
TimeStopCompress := timeGetTime;
ShowMessage(format('Compressed %d pixels in %d mS, Rate %d pixels/mS',
[Height*Width, TimeStopCompress-TimeStartCompress,
DWORD(Height*Width) DIV (TimeStopCompress-TimeStartCompress+1)]));
{$endif}
// Output the final code.
Output(EOFCode);
end else
// Output the final code (and nothing else).
TGIFEncoder(self).Output(EOFCode);
finally
GIFStream.Free;
end;
WriteByte(Stream, EndBlockByte);
end;
////////////////////////////////////////////////////////////////////////////////
// TRLEEncoder - RLE encoder
////////////////////////////////////////////////////////////////////////////////
type
TRLEEncoder = class(TGIFEncoder)
private
MaxCodes : integer;
OutBumpInit ,
OutClearInit : integer;
Prefix : integer; // Current run color
RunLengthTableMax ,
RunLengthTablePixel ,
OutCount ,
OutClear ,
OutBump : integer;
protected
function ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
procedure MaxOutClear;
procedure ResetOutClear;
procedure FlushFromClear(Count: integer);
procedure FlushClearOrRepeat(Count: integer);
procedure FlushWithTable(Count: integer);
procedure Flush(RunLengthCount: integer);
procedure OutputPlain(Value: integer);
procedure Clear; override;
procedure DoCompress; override;
end;
procedure TRLEEncoder.Clear;
begin
OutBump := OutBumpInit;
OutClear := OutClearInit;
OutCount := 0;
RunLengthTableMax := 0;
inherited Clear;
BitsPerCode := InitialBitsPerCode;
end;
procedure TRLEEncoder.OutputPlain(Value: integer);
begin
ClearFlag := False;
Output(Value);
inc(OutCount);
if (OutCount >= OutBump) then
begin
inc(BitsPerCode);
inc(OutBump, 1 SHL (BitsPerCode - 1));
end;
if (OutCount >= OutClear) then
Clear;
end;
function TRLEEncoder.ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
var
PerRepeat : integer;
n : integer;
function iSqrt(x: integer): integer;
var
r, v : integer;
begin
if (x < 2) then
begin
Result := x;
exit;
end else
begin
v := x;
r := 1;
while (v > 0) do
begin
v := v DIV 4;
r := r * 2;
end;
end;
while (True) do
begin
v := ((x DIV r) + r) DIV 2;
if ((v = r) or (v = r+1)) then
begin
Result := r;
exit;
end;
r := v;
end;
end;
begin
Result := 0;
PerRepeat := (nrepcodes * (nrepcodes+1)) DIV 2;
while (Count >= PerRepeat) do
begin
inc(Result, nrepcodes);
dec(Count, PerRepeat);
end;
if (Count > 0) then
begin
n := iSqrt(Count);
while ((n * (n+1)) >= 2*Count) do
dec(n);
while ((n * (n+1)) < 2*Count) do
inc(n);
inc(Result, n);
end;
end;
procedure TRLEEncoder.MaxOutClear;
begin
OutClear := MaxCodes;
end;
procedure TRLEEncoder.ResetOutClear;
begin
OutClear := OutClearInit;
if (OutCount >= OutClear) then
Clear;
end;
procedure TRLEEncoder.FlushFromClear(Count: integer);
var
n : integer;
begin
MaxOutClear;
RunLengthTablePixel := Prefix;
n := 1;
while (Count > 0) do
begin
if (n = 1) then
begin
RunLengthTableMax := 1;
OutputPlain(Prefix);
dec(Count);
end else
if (Count >= n) then
begin
RunLengthTableMax := n;
OutputPlain(BaseCode + n - 2);
dec(Count, n);
end else
if (Count = 1) then
begin
inc(RunLengthTableMax);
OutputPlain(Prefix);
break;
end else
begin
inc(RunLengthTableMax);
OutputPlain(BaseCode + Count - 2);
break;
end;
if (OutCount = 0) then
n := 1
else
inc(n);
end;
ResetOutClear;
end;
procedure TRLEEncoder.FlushClearOrRepeat(Count: integer);
var
WithClear : integer;
begin
WithClear := 1 + ComputeTriangleCount(Count, MaxCodes);
if (WithClear < Count) then
begin
Clear;
FlushFromClear(Count);
end else
while (Count > 0) do
begin
OutputPlain(Prefix);
dec(Count);
end;
end;
procedure TRLEEncoder.FlushWithTable(Count: integer);
var
RepeatMax ,
RepeatLeft ,
LeftOver : integer;
begin
RepeatMax := Count DIV RunLengthTableMax;
LeftOver := Count MOD RunLengthTableMax;
if (LeftOver <> 0) then
RepeatLeft := 1
else
RepeatLeft := 0;
if (OutCount + RepeatMax + RepeatLeft > MaxCodes) then
begin
RepeatMax := MaxCodes - OutCount;
LeftOver := Count - (RepeatMax * RunLengthTableMax);
RepeatLeft := 1 + ComputeTriangleCount(LeftOver, MaxCodes);
end;
if (1 + ComputeTriangleCount(Count, MaxCodes) < RepeatMax + RepeatLeft) then
begin
Clear;
FlushFromClear(Count);
exit;
end;
MaxOutClear;
while (RepeatMax > 0) do
begin
OutputPlain(BaseCode + RunLengthTableMax-2);
dec(RepeatMax);
end;
if (LeftOver > 0) then
begin
if (ClearFlag) then
FlushFromClear(LeftOver)
else if (LeftOver = 1) then
OutputPlain(Prefix)
else
OutputPlain(BaseCode + LeftOver - 2);
end;
ResetOutClear;
end;
procedure TRLEEncoder.Flush(RunLengthCount: integer);
begin
if (RunLengthCount = 1) then
begin
OutputPlain(Prefix);
exit;
end;
if (ClearFlag) then
FlushFromClear(RunLengthCount)
else if ((RunLengthTableMax < 2) or (RunLengthTablePixel <> Prefix)) then
FlushClearOrRepeat(RunLengthCount)
else
FlushWithTable(RunLengthCount);
end;
procedure TRLEEncoder.DoCompress;
var
Color : CodeInt;
RunLengthCount : integer;
begin
OutBumpInit := ClearCode - 1;
// For images with a lot of runs, making OutClearInit larger will
// give better compression.
if (BitsPerPixel <= 3) then
OutClearInit := 9
else
OutClearInit := OutBumpInit - 1;
// max_ocodes = (1 << GIFBITS) - ((1 << (out_bits_init - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (BitsPerCode - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (InitialBitsPerCode - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (ClearCode + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (EOFCode + 2);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (BaseCode + 1);
// <=> MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
Clear;
RunLengthCount := 0;
Pixel := Data;
Prefix := -1; // Dummy value to make Color <> Prefix
repeat
// Fetch the next pixel
Color := CodeInt(Pixel^);
inc(Pixel);
if (Color >= MaxColor) then
Error(sInvalidColor);
if (RunLengthCount > 0) and (Color <> Prefix) then
begin
// End of current run
Flush(RunLengthCount);
RunLengthCount := 0;
end;
if (Color = Prefix) then
// Increment run length
inc(RunLengthCount)
else
begin
// Start new run
Prefix := Color;
RunLengthCount := 1;
end;
until not(BumpPixel);
Flush(RunLengthCount);
end;
////////////////////////////////////////////////////////////////////////////////
// TLZWEncoder - LZW encoder
////////////////////////////////////////////////////////////////////////////////
const
TableMaxMaxCode = (1 SHL GIFCodeBits); //
TableMaxFill = TableMaxMaxCode-1; // Clear table when it fills to
// this point.
// Note: Must be <= GIFCodeMax
type
TLZWEncoder = class(TGIFEncoder)
private
Prefix : CodeInt; // Current run color
FreeEntry : CodeInt; // next unused code in table
HashTable : THashTable;
protected
procedure Output(Value: integer); override;
procedure Clear; override;
procedure DoCompress; override;
end;
procedure TLZWEncoder.Output(Value: integer);
begin
inherited Output(Value);
// If the next entry is going to be too big for the code size,
// then increase it, if possible.
if (FreeEntry > MaxCode) or (ClearFlag) then
begin
if (ClearFlag) then
begin
BitsPerCode := InitialBitsPerCode;
MaxCode := MaxCodesFromBits(BitsPerCode);
ClearFlag := False;
end else
begin
inc(BitsPerCode);
if (BitsPerCode = GIFCodeBits) then
MaxCode := TableMaxMaxCode
else
MaxCode := MaxCodesFromBits(BitsPerCode);
end;
end;
end;
procedure TLZWEncoder.Clear;
begin
inherited Clear;
HashTable.Clear;
FreeEntry := ClearCode + 2;
end;
procedure TLZWEncoder.DoCompress;
var
Color : char;
NewKey : KeyInt;
NewCode : CodeInt;
begin
HashTable := THashTable.Create;
try
// clear hash table and sync decoder
Clear;
Pixel := Data;
Prefix := CodeInt(Pixel^);
inc(Pixel);
if (Prefix >= MaxColor) then
Error(sInvalidColor);
while (BumpPixel) do
begin
// Fetch the next pixel
Color := Pixel^;
inc(Pixel);
if (ord(Color) >= MaxColor) then
Error(sInvalidColor);
// Append Postfix to Prefix and lookup in table...
NewKey := (KeyInt(Prefix) SHL 8) OR ord(Color);
NewCode := HashTable.Lookup(NewKey);
if (NewCode >= 0) then
begin
// ...if found, get next pixel
Prefix := NewCode;
continue;
end;
// ...if not found, output and start over
Output(Prefix);
Prefix := CodeInt(Color);
if (FreeEntry < TableMaxFill) then
begin
HashTable.Insert(NewKey, FreeEntry);
inc(FreeEntry);
end else
Clear;
end;
Output(Prefix);
finally
HashTable.Free;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFSubImage
//
////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////
// TGIFSubImage.Compress
/////////////////////////////////////////////////////////////////////////
procedure TGIFSubImage.Compress(Stream: TStream);
var
Encoder : TGIFEncoder;
BitsPerPixel : BYTE;
MaxColors : integer;
begin
if (ColorMap.Count > 0) then
begin
MaxColors := ColorMap.Count;
BitsPerPixel := ColorMap.BitsPerPixel
end else
begin
BitsPerPixel := Image.BitsPerPixel;
MaxColors := 1 SHL BitsPerPixel;
end;
// Create a RLE or LZW GIF encoder
if (Image.Compression = gcRLE) then
Encoder := TRLEEncoder.Create
else
Encoder := TLZWEncoder.Create;
try
Encoder.Warning := Image.Warning;
Encoder.Compress(Stream, BitsPerPixel, Width, Height, Interlaced, FData, MaxColors);
finally
Encoder.Free;
end;
end;
function TGIFExtensionList.GetExtension(Index: Integer): TGIFExtension;
begin
Result := TGIFExtension(Items[Index]);
end;
procedure TGIFExtensionList.SetExtension(Index: Integer; Extension: TGIFExtension);
begin
Items[Index] := Extension;
end;
procedure TGIFExtensionList.LoadFromStream(Stream: TStream; Parent: TObject);
var
b : BYTE;
Extension : TGIFExtension;
ExtensionClass : TGIFExtensionClass;
begin
// Peek ahead to determine block type
if (Stream.Read(b, 1) <> 1) then
exit;
while not(b in [bsTrailer, bsImageDescriptor]) do
begin
if (b = bsExtensionIntroducer) then
begin
ExtensionClass := TGIFExtension.FindExtension(Stream);
if (ExtensionClass = nil) then
Error(sUnknownExtension);
Stream.Seek(-1, soFromCurrent);
Extension := ExtensionClass.Create(Parent as TGIFSubImage);
try
Extension.LoadFromStream(Stream);
Add(Extension);
except
Extension.Free;
raise;
end;
end else
begin
Warning(gsWarning, sBadExtensionLabel);
break;
end;
if (Stream.Read(b, 1) <> 1) then
exit;
end;
Stream.Seek(-1, soFromCurrent);
end;
const
{ image descriptor bit masks }
idLocalColorTable = $80; { set if a local color table follows }
idInterlaced = $40; { set if image is interlaced }
idSort = $20; { set if color table is sorted }
idReserved = $0C; { reserved - must be set to $00 }
idColorTableSize = $07; { size of color table as above }
constructor TGIFSubImage.Create(GIFImage: TGIFImage);
begin
inherited Create(GIFImage);
FExtensions := TGIFExtensionList.Create(GIFImage);
FColorMap := TGIFLocalColorMap.Create(self);
FImageDescriptor.Separator := bsImageDescriptor;
FImageDescriptor.Left := 0;
FImageDescriptor.Top := 0;
FImageDescriptor.Width := 0;
FImageDescriptor.Height := 0;
FImageDescriptor.PackedFields := 0;
FBitmap := nil;
FMask := 0;
FNeedMask := True;
FData := nil;
FDataSize := 0;
FTransparent := False;
FGCE := nil;
// Remember to synchronize with TGIFSubImage.Clear
end;
destructor TGIFSubImage.Destroy;
begin
if (FGIFImage <> nil) then
FGIFImage.Images.Remove(self);
Clear;
FExtensions.Free;
FColorMap.Free;
if (FLocalPalette <> 0) then
DeleteObject(FLocalPalette);
inherited Destroy;
end;
procedure TGIFSubImage.Clear;
begin
FExtensions.Clear;
FColorMap.Clear;
FreeImage;
Height := 0;
Width := 0;
FTransparent := False;
FGCE := nil;
FreeBitmap;
FreeMask;
// Remember to synchronize with TGIFSubImage.Create
end;
function TGIFSubImage.GetEmpty: Boolean;
begin
Result := ((FData = nil) or (FDataSize = 0) or (Height = 0) or (Width = 0));
end;
function TGIFSubImage.GetPalette: HPALETTE;
begin
if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
// Use bitmaps own palette if possible
Result := FBitmap.Palette
else if (FLocalPalette <> 0) then
// Or a previously exported local palette
Result := FLocalPalette
else if (Image.DoDither) then
begin
// or create a new dither palette
FLocalPalette := WebPalette;
Result := FLocalPalette;
end
else if (ColorMap.Count > 0) then
begin
// or create a new if first time
FLocalPalette := ColorMap.ExportPalette;
Result := FLocalPalette;
end else
// Use global palette if everything else fails
Result := Image.Palette;
end;
procedure TGIFSubImage.SetPalette(Value: HPalette);
var
NeedNewBitmap : boolean;
begin
if (Value <> FLocalPalette) then
begin
// Zap old palette
if (FLocalPalette <> 0) then
DeleteObject(FLocalPalette);
// Zap bitmap unless new palette is same as bitmaps own
NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);
// Use new palette
FLocalPalette := Value;
if (NeedNewBitmap) then
begin
// Need to create new bitmap and repaint
FreeBitmap;
Image.PaletteModified := True;
Image.Changed(Self);
end;
end;
end;
procedure TGIFSubImage.NeedImage;
begin
if (FData = nil) then
NewImage;
if (FDataSize = 0) then
Error(sEmptyImage);
end;
procedure TGIFSubImage.NewImage;
var
NewSize : longInt;
begin
FreeImage;
NewSize := Height * Width;
if (NewSize <> 0) then
begin
GetMem(FData, NewSize);
FillChar(FData^, NewSize, 0);
end else
FData := nil;
FDataSize := NewSize;
end;
procedure TGIFSubImage.FreeImage;
begin
if (FData <> nil) then
FreeMem(FData);
FDataSize := 0;
FData := nil;
end;
function TGIFSubImage.GetHasBitmap: boolean;
begin
Result := (FBitmap <> nil);
end;
procedure TGIFSubImage.SetHasBitmap(Value: boolean);
begin
if (Value <> (FBitmap <> nil)) then
begin
if (Value) then
Bitmap // Referencing Bitmap will automatically create it
else
FreeBitmap;
end;
end;
procedure TGIFSubImage.NewBitmap;
begin
FreeBitmap;
FBitmap := TBitmap.Create;
end;
procedure TGIFSubImage.FreeBitmap;
begin
if (FBitmap <> nil) then
begin
FBitmap.Free;
FBitmap := nil;
end;
end;
procedure TGIFSubImage.FreeMask;
begin
if (FMask <> 0) then
begin
DeleteObject(FMask);
FMask := 0;
end;
FNeedMask := True;
end;
function TGIFSubImage.HasMask: boolean;
begin
if (FNeedMask) and (Transparent) then
begin
// Zap old bitmap
FreeBitmap;
// Create new bitmap and mask
GetBitmap;
end;
Result := (FMask <> 0);
end;
function TGIFSubImage.GetBounds(Index: integer): WORD;
begin
case (Index) of
1: Result := FImageDescriptor.Left;
2: Result := FImageDescriptor.Top;
3: Result := FImageDescriptor.Width;
4: Result := FImageDescriptor.Height;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFSubImage.SetBounds(Index: integer; Value: WORD);
begin
case (Index) of
1: DoSetBounds(Value, FImageDescriptor.Top, FImageDescriptor.Width, FImageDescriptor.Height);
2: DoSetBounds(FImageDescriptor.Left, Value, FImageDescriptor.Width, FImageDescriptor.Height);
3: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, Value, FImageDescriptor.Height);
4: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, FImageDescriptor.Width, Value);
end;
end;
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
function TGIFSubImage.DoGetDitherBitmap: TBitmap;
var
ColorLookup : TColorLookup;
Ditherer : TDitherEngine;
DIBResult : TDIB;
Src : PChar;
Dst : PChar;
Row : integer;
Color : TGIFColor;
ColMap : PColorMap;
Index : byte;
TransparentIndex : byte;
IsTransparent : boolean;
WasTransparent : boolean;
MappedTransparentIndex: char;
MaskBits : PChar;
MaskDest : PChar;
MaskRow : PChar;
MaskRowWidth ,
MaskRowBitWidth : integer;
Bit ,
RightBit : BYTE;
begin
Result := TBitmap.Create;
try
{$IFNDEF VER9x}
if (Width*Height > BitmapAllocationThreshold) then
SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}
if (Empty) then
begin
// Set bitmap width and height
Result.Width := Width;
Result.Height := Height;
// Build and copy palette to bitmap
Result.Palette := CopyPalette(Palette);
exit;
end;
ColorLookup := nil;
Ditherer := nil;
DIBResult := nil;
try // Protect above resources
ColorLookup := TNetscapeColorLookup.Create(Palette);
Ditherer := TFloydSteinbergDitherer.Create(Width, ColorLookup);
// Get DIB buffer for scanline operations
// It is assumed that the source palette is the 216 color Netscape palette
DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
// Determine if this image is transparent
ColMap := ActiveColorMap.Data;
IsTransparent := FNeedMask and Transparent;
WasTransparent := False;
FNeedMask := False;
TransparentIndex := 0;
MappedTransparentIndex := #0;
if (FMask = 0) and (IsTransparent) then
begin
IsTransparent := True;
TransparentIndex := GraphicControlExtension.TransparentColorIndex;
Color := ColMap[ord(TransparentIndex)];
MappedTransparentIndex := char(Color.Blue DIV 51 +
MulDiv(6, Color.Green, 51) + MulDiv(36, Color.Red, 51)+1);
end;
// Allocate bit buffer for transparency mask
MaskDest := nil;
Bit := $00;
if (IsTransparent) then
begin
MaskRowWidth := ((Width+15) DIV 16) * 2;
MaskRowBitWidth := (Width+7) DIV 8;
RightBit := $01 SHL ((8 - (Width AND $0007)) AND $0007);
GetMem(MaskBits, MaskRowWidth * Height);
FillChar(MaskBits^, MaskRowWidth * Height, 0);
end else
begin
MaskBits := nil;
MaskRowWidth := 0;
MaskRowBitWidth := 0;
RightBit := $00;
end;
try
// Process the image
Row := 0;
MaskRow := MaskBits;
Src := FData;
while (Row < Height) do
begin
if ((Row AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(Row, 100, Height),
False, Rect(0,0,0,0), sProgressRendering);
Dst := DIBResult.ScanLine[Row];
if (IsTransparent) then
begin
// Preset all pixels to transparent
FillChar(Dst^, Width, ord(MappedTransparentIndex));
if (Ditherer.Direction = 1) then
begin
MaskDest := MaskRow;
Bit := $80;
end else
begin
MaskDest := MaskRow + MaskRowBitWidth-1;
Bit := RightBit;
end;
end;
inc(Dst, Ditherer.Column);
while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
begin
Index := ord(Src^);
Color := ColMap[ord(Index)];
if (IsTransparent) and (Index = TransparentIndex) then
begin
MaskDest^ := char(byte(MaskDest^) OR Bit);
WasTransparent := True;
Ditherer.NextColumn;
end else
begin
// Dither and map a single pixel
Dst^ := Ditherer.Dither(Color.Red, Color.Green, Color.Blue,
Color.Red, Color.Green, Color.Blue);
end;
if (IsTransparent) then
begin
if (Ditherer.Direction = 1) then
begin
Bit := Bit SHR 1;
if (Bit = $00) then
begin
Bit := $80;
inc(MaskDest, 1);
end;
end else
begin
Bit := Bit SHL 1;
if (Bit = $00) then
begin
Bit := $01;
dec(MaskDest, 1);
end;
end;
end;
inc(Src, Ditherer.Direction);
inc(Dst, Ditherer.Direction);
end;
if (IsTransparent) then
Inc(MaskRow, MaskRowWidth);
Inc(Row);
inc(Src, Width-Ditherer.Direction);
Ditherer.NextLine;
end;
// Transparent paint needs a mask bitmap
if (IsTransparent) and (WasTransparent) then
FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
finally
if (MaskBits <> nil) then
FreeMem(MaskBits);
end;
finally
if (ColorLookup <> nil) then
ColorLookup.Free;
if (Ditherer <> nil) then
Ditherer.Free;
if (DIBResult <> nil) then
DIBResult.Free;
end;
except
Result.Free;
raise;
end;
end;
{$IFDEF R_PLUS}
{$RANGECHECKS ON}
{$UNDEF R_PLUS}
{$ENDIF}
function TGIFSubImage.DoGetBitmap: TBitmap;
var
ScanLineRow : Integer;
DIBResult : TDIB;
DestScanLine ,
Src : PChar;
TransparentIndex : byte;
IsTransparent : boolean;
WasTransparent : boolean;
MaskBits : PChar;
MaskDest : PChar;
MaskRow : PChar;
MaskRowWidth : integer;
Col : integer;
MaskByte : byte;
Bit : byte;
begin
Result := TBitmap.Create;
try
{$IFNDEF VER9x}
if (Width*Height > BitmapAllocationThreshold) then
SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}
if (Empty) then
begin
// Set bitmap width and height
Result.Width := Width;
Result.Height := Height;
// Build and copy palette to bitmap
Result.Palette := CopyPalette(Palette);
exit;
end;
// Get DIB buffer for scanline operations
DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
try
// Determine if this image is transparent
IsTransparent := FNeedMask and Transparent;
WasTransparent := False;
FNeedMask := False;
TransparentIndex := 0;
if (FMask = 0) and (IsTransparent) then
begin
IsTransparent := True;
TransparentIndex := GraphicControlExtension.TransparentColorIndex;
end;
// Allocate bit buffer for transparency mask
if (IsTransparent) then
begin
MaskRowWidth := ((Width+15) DIV 16) * 2;
GetMem(MaskBits, MaskRowWidth * Height);
FillChar(MaskBits^, MaskRowWidth * Height, 0);
IsTransparent := (MaskBits <> nil);
end else
begin
MaskBits := nil;
MaskRowWidth := 0;
end;
try
ScanLineRow := 0;
Src := FData;
MaskRow := MaskBits;
while (ScanLineRow < Height) do
begin
DestScanline := DIBResult.ScanLine[ScanLineRow];
if ((ScanLineRow AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(ScanLineRow, 100, Height),
False, Rect(0,0,0,0), sProgressRendering);
Move(Src^, DestScanline^, Width);
Inc(ScanLineRow);
if (IsTransparent) then
begin
Bit := $80;
MaskDest := MaskRow;
MaskByte := 0;
for Col := 0 to Width-1 do
begin
// Set a bit in the mask if the pixel is transparent
if (Src^ = char(TransparentIndex)) then
MaskByte := MaskByte OR Bit;
Bit := Bit SHR 1;
if (Bit = $00) then
begin
// Store a mask byte for each 8 pixels
Bit := $80;
WasTransparent := WasTransparent or (MaskByte <> 0);
MaskDest^ := char(MaskByte);
inc(MaskDest);
MaskByte := 0;
end;
Inc(Src);
end;
// Save the last mask byte in case the width isn't divisable by 8
if (MaskByte <> 0) then
begin
WasTransparent := True;
MaskDest^ := char(MaskByte);
end;
Inc(MaskRow, MaskRowWidth);
end else
Inc(Src, Width);
end;
// Transparent paint needs a mask bitmap
if (IsTransparent) and (WasTransparent) then
FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
finally
if (MaskBits <> nil) then
FreeMem(MaskBits);
end;
finally
// Free DIB buffer used for scanline operations
DIBResult.Free;
end;
except
Result.Free;
raise;
end;
end;
{$ifdef DEBUG_RENDERPERFORMANCE}
var
ImageCount : DWORD = 0;
RenderTime : DWORD = 0;
{$endif}
function TGIFSubImage.GetBitmap: TBitmap;
var
n : integer;
{$ifdef DEBUG_RENDERPERFORMANCE}
RenderStartTime : DWORD;
{$endif}
begin
{$ifdef DEBUG_RENDERPERFORMANCE}
if (GetAsyncKeyState(VK_CONTROL) <> 0) then
begin
ShowMessage(format('Render %d images in %d mS, Rate %d mS/image (%d images/S)',
[ImageCount, RenderTime,
RenderTime DIV (ImageCount+1),
MulDiv(ImageCount, 1000, RenderTime+1)]));
end;
{$endif}
Result := FBitmap;
if (Result <> nil) or (Empty) then
Exit;
{$ifdef DEBUG_RENDERPERFORMANCE}
inc(ImageCount);
RenderStartTime := timeGetTime;
{$endif}
try
Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressRendering);
try
if (Image.DoDither) then
// Create dithered bitmap
FBitmap := DoGetDitherBitmap
else
// Create "regular" bitmap
FBitmap := DoGetBitmap;
Result := FBitmap;
finally
if ExceptObject = nil then
n := 100
else
n := 0;
Image.Progress(Self, psEnding, n, Image.PaletteModified, Rect(0,0,0,0),
sProgressRendering);
// Make sure new palette gets realized, in case OnProgress event didn't.
if Image.PaletteModified then
Image.Changed(Self);
end;
except
on EAbort do ; // OnProgress can raise EAbort to cancel image load
end;
{$ifdef DEBUG_RENDERPERFORMANCE}
inc(RenderTime, timeGetTime-RenderStartTime);
{$endif}
end;
procedure TGIFSubImage.SetBitmap(Value: TBitmap);
begin
FreeBitmap;
if (Value <> nil) then
Assign(Value);
end;
function TGIFSubImage.GetActiveColorMap: TGIFColorMap;
begin
if (ColorMap.Count > 0) or (Image.GlobalColorMap.Count = 0) then
Result := ColorMap
else
Result := Image.GlobalColorMap;
end;
function TGIFSubImage.GetInterlaced: boolean;
begin
Result := (FImageDescriptor.PackedFields AND idInterlaced) <> 0;
end;
procedure TGIFSubImage.SetInterlaced(Value: boolean);
begin
if (Value) then
FImageDescriptor.PackedFields := FImageDescriptor.PackedFields OR idInterlaced
else
FImageDescriptor.PackedFields := FImageDescriptor.PackedFields AND NOT(idInterlaced);
end;
function TGIFSubImage.GetVersion: TGIFVersion;
var
v : TGIFVersion;
i : integer;
begin
if (ColorMap.Optimized) then
Result := gv89a
else
Result := inherited GetVersion;
i := 0;
while (Result < high(TGIFVersion)) and (i < FExtensions.Count) do
begin
v := FExtensions[i].Version;
if (v > Result) then
Result := v;
end;
end;
function TGIFSubImage.GetColorResolution: integer;
begin
Result := ColorMap.BitsPerPixel-1;
end;
function TGIFSubImage.GetBitsPerPixel: integer;
begin
Result := ColorMap.BitsPerPixel;
end;
function TGIFSubImage.GetBoundsRect: TRect;
begin
Result := Rect(FImageDescriptor.Left,
FImageDescriptor.Top,
FImageDescriptor.Left+FImageDescriptor.Width,
FImageDescriptor.Top+FImageDescriptor.Height);
end;
procedure TGIFSubImage.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
var
TooLarge : boolean;
Zap : boolean;
begin
Zap := (FImageDescriptor.Width <> Width) or (FImageDescriptor.Height <> AHeight);
FImageDescriptor.Left := ALeft;
FImageDescriptor.Top := ATop;
FImageDescriptor.Width := AWidth;
FImageDescriptor.Height := AHeight;
// Delete existing image and bitmaps if size has changed
if (Zap) then
begin
FreeBitmap;
FreeMask;
FreeImage;
// ...and allocate a new image
NewImage;
end;
TooLarge := False;
// Set width & height if added image is larger than existing images
{$IFDEF STRICT_MOZILLA}
// From Mozilla source:
// Work around broken GIF files where the logical screen
// size has weird width or height. [...]
if (Image.Width < AWidth) or (Image.Height < AHeight) then
begin
TooLarge := True;
Image.Width := AWidth;
Image.Height := AHeight;
Left := 0;
Top := 0;
end;
{$ELSE}
if (Image.Width < ALeft+AWidth) then
begin
if (Image.Width > 0) then
begin
TooLarge := True;
Warning(gsWarning, sBadWidth)
end;
Image.Width := ALeft+AWidth;
end;
if (Image.Height < ATop+AHeight) then
begin
if (Image.Height > 0) then
begin
TooLarge := True;
Warning(gsWarning, sBadHeight)
end;
Image.Height := ATop+AHeight;
end;
{$ENDIF}
if (TooLarge) then
Warning(gsWarning, sScreenSizeExceeded);
end;
procedure TGIFSubImage.SetBoundsRect(const Value: TRect);
begin
DoSetBounds(Value.Left, Value.Top, Value.Right-Value.Left+1, Value.Bottom-Value.Top+1);
end;
function TGIFSubImage.GetClientRect: TRect;
begin
Result := Rect(0, 0, FImageDescriptor.Width, FImageDescriptor.Height);
end;
function TGIFSubImage.GetPixel(x, y: integer): BYTE;
begin
if (x < 0) or (x > Width-1) then
Error(sBadPixelCoordinates);
Result := BYTE(PChar(longInt(Scanline[y]) + x)^);
end;
function TGIFSubImage.GetScanline(y: integer): pointer;
begin
if (y < 0) or (y > Height-1) then
Error(sBadPixelCoordinates);
NeedImage;
Result := pointer(longInt(FData) + y * Width);
end;
procedure TGIFSubImage.Prepare;
var
Pack : BYTE;
begin
Pack := FImageDescriptor.PackedFields;
if (ColorMap.Count > 0) then
begin
Pack := idLocalColorTable;
if (ColorMap.Optimized) then
Pack := Pack OR idSort;
Pack := (Pack AND NOT(idColorTableSize)) OR (ColorResolution AND idColorTableSize);
end else
Pack := Pack AND NOT(idLocalColorTable OR idSort OR idColorTableSize);
FImageDescriptor.PackedFields := Pack;
end;
procedure TGIFSubImage.SaveToStream(Stream: TStream);
begin
FExtensions.SaveToStream(Stream);
if (Empty) then
exit;
Prepare;
Stream.Write(FImageDescriptor, sizeof(TImageDescriptor));
ColorMap.SaveToStream(Stream);
Compress(Stream);
end;
procedure TGIFSubImage.LoadFromStream(Stream: TStream);
var
ColorCount : integer;
b : BYTE;
begin
Clear;
FExtensions.LoadFromStream(Stream, self);
// Check for extension without image
if (Stream.Read(b, 1) <> 1) then
exit;
Stream.Seek(-1, soFromCurrent);
if (b = bsTrailer) or (b = 0) then
exit;
ReadCheck(Stream, FImageDescriptor, sizeof(TImageDescriptor));
// From Mozilla source:
// Work around more broken GIF files that have zero image
// width or height
if (FImageDescriptor.Height = 0) or (FImageDescriptor.Width = 0) then
begin
FImageDescriptor.Height := Image.Height;
FImageDescriptor.Width := Image.Width;
Warning(gsWarning, sScreenSizeExceeded);
end;
if (FImageDescriptor.PackedFields AND idLocalColorTable = idLocalColorTable) then
begin
ColorCount := 2 SHL (FImageDescriptor.PackedFields AND idColorTableSize);
if (ColorCount < 2) or (ColorCount > 256) then
Error(sImageBadColorSize);
ColorMap.LoadFromStream(Stream, ColorCount);
end;
Decompress(Stream);
// On-load rendering
if (GIFImageRenderOnLoad) then
// Touch bitmap to force frame to be rendered
Bitmap;
end;
procedure TGIFSubImage.AssignTo(Dest: TPersistent);
begin
if (Dest is TBitmap) then
Dest.Assign(Bitmap)
else
inherited AssignTo(Dest);
end;
procedure TGIFSubImage.Assign(Source: TPersistent);
var
MemoryStream : TMemoryStream;
i : integer;
PixelFormat : TPixelFormat;
DIBSource : TDIB;
ABitmap : TBitmap;
procedure Import8Bit(Dest: PChar);
var
y : integer;
begin
// Copy colormap
{$ifdef VER10_PLUS}
if (FBitmap.HandleType = bmDIB) then
FColorMap.ImportDIBColors(FBitmap.Canvas.Handle)
else
{$ENDIF}
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
Move(DIBSource.Scanline[y]^, Dest^, Width);
inc(Dest, Width);
end;
end;
procedure Import4Bit(Dest: PChar);
var
x, y : integer;
Scanline : PChar;
begin
// Copy colormap
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
ScanLine := DIBSource.Scanline[y];
for x := 0 to Width-1 do
begin
if (x AND $01 = 0) then
Dest^ := chr(ord(ScanLine^) SHR 4)
else
begin
Dest^ := chr(ord(ScanLine^) AND $0F);
inc(ScanLine);
end;
inc(Dest);
end;
end;
end;
procedure Import1Bit(Dest: PChar);
var
x, y : integer;
Scanline : PChar;
Bit : integer;
Byte : integer;
begin
// Copy colormap
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
ScanLine := DIBSource.Scanline[y];
x := Width;
Bit := 0;
Byte := 0; // To avoid compiler warning
while (x > 0) do
begin
if (Bit = 0) then
begin
Bit := 8;
Byte := ord(ScanLine^);
inc(Scanline);
end;
Dest^ := chr((Byte AND $80) SHR 7);
Byte := Byte SHL 1;
inc(Dest);
dec(Bit);
dec(x);
end;
end;
end;
procedure Import24Bit(Dest: PChar);
type
TCacheEntry = record
Color : TColor;
Index : integer;
end;
const
// Size of palette cache. Must be 2^n.
// The cache holds the palette index of the last "CacheSize" colors
// processed. Hopefully the cache can speed things up a bit... Initial
// testing shows that this is indeed the case at least for non-dithered
// bitmaps.
// All the same, a small hash table would probably be much better.
CacheSize = 8;
var
i : integer;
Cache : array[0..CacheSize-1] of TCacheEntry;
LastEntry : integer;
Scanline : PRGBTriple;
Pixel : TColor;
RGBTriple : TRGBTriple absolute Pixel;
x, y : integer;
ColorMap : PColorMap;
t : byte;
label
NextPixel;
begin
for i := 0 to CacheSize-1 do
Cache[i].Index := -1;
LastEntry := 0;
// Copy all pixels and build colormap
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
ScanLine := DIBSource.Scanline[y];
for x := 0 to Width-1 do
begin
Pixel := 0;
RGBTriple := Scanline^;
// Scan cache for color from most recently processed color to last
// recently processed. This is done because TColorMap.AddUnique is very slow.
i := LastEntry;
repeat
if (Cache[i].Index = -1) then
break;
if (Cache[i].Color = Pixel) then
begin
Dest^ := chr(Cache[i].Index);
LastEntry := i;
goto NextPixel;
end;
if (i = 0) then
i := CacheSize-1
else
dec(i);
until (i = LastEntry);
// Color not found in cache, do it the slow way instead
Dest^ := chr(FColorMap.AddUnique(Pixel));
// Add color and index to cache
LastEntry := (LastEntry + 1) AND (CacheSize-1);
Cache[LastEntry].Color := Pixel;
Cache[LastEntry].Index := ord(Dest^);
NextPixel:
Inc(Dest);
Inc(Scanline);
end;
end;
// Convert colors in colormap from BGR to RGB
ColorMap := FColorMap.Data;
i := FColorMap.Count;
while (i > 0) do
begin
t := ColorMap^[0].Red;
ColorMap^[0].Red := ColorMap^[0].Blue;
ColorMap^[0].Blue := t;
inc(integer(ColorMap), sizeof(TGIFColor));
dec(i);
end;
end;
procedure ImportViaDraw(ABitmap: TBitmap; Graphic: TGraphic);
begin
ABitmap.Height := Graphic.Height;
ABitmap.Width := Graphic.Width;
// Note: Disable the call to SafeSetPixelFormat below to import
// in max number of colors with the risk of having to use
// TCanvas.Pixels to do it (very slow).
// Make things a little easier for TGIFSubImage.Assign by converting
// pfDevice to a more import friendly format
{$ifdef SLOW_BUT_SAFE}
SafeSetPixelFormat(ABitmap, pf8bit);
{$else}
{$ifndef VER9x}
SetPixelFormat(ABitmap, pf24bit);
{$endif}
{$endif}
ABitmap.Canvas.Draw(0, 0, Graphic);
end;
procedure AddMask(Mask: TBitmap);
var
DIBReader : TDIBReader;
TransparentIndex : integer;
i ,
j : integer;
GIFPixel ,
MaskPixel : PChar;
WasTransparent : boolean;
GCE : TGIFGraphicControlExtension;
begin
// Optimize colormap to make room for transparent color
ColorMap.Optimize;
// Can't make transparent if no color or colormap full
if (ColorMap.Count = 0) or (ColorMap.Count = 256) then
exit;
// Add the transparent color to the color map
TransparentIndex := ColorMap.Add(TColor(0));
WasTransparent := False;
DIBReader := TDIBReader.Create(Mask, pf8bit);
try
for i := 0 to Height-1 do
begin
MaskPixel := DIBReader.Scanline[i];
GIFPixel := Scanline[i];
for j := 0 to Width-1 do
begin
// Change all unmasked pixels to transparent
if (MaskPixel^ <> #0) then
begin
GIFPixel^ := chr(TransparentIndex);
WasTransparent := True;
end;
inc(MaskPixel);
inc(GIFPixel);
end;
end;
finally
DIBReader.Free;
end;
// Add a Graphic Control Extension if any part of the mask was transparent
if (WasTransparent) then
begin
GCE := TGIFGraphicControlExtension.Create(self);
GCE.Transparent := True;
GCE.TransparentColorIndex := TransparentIndex;
Extensions.Add(GCE);
end else
// Otherwise removed the transparency color since it wasn't used
ColorMap.Delete(TransparentIndex);
end;
procedure AddMaskOnly(hMask: hBitmap);
var
Mask : TBitmap;
begin
if (hMask = 0) then
exit;
// Encapsulate the mask
Mask := TBitmap.Create;
try
Mask.Handle := hMask;
AddMask(Mask);
finally
Mask.ReleaseHandle;
Mask.Free;
end;
end;
procedure AddIconMask(Icon: TIcon);
var
IconInfo : TIconInfo;
begin
if (not GetIconInfo(Icon.Handle, IconInfo)) then
exit;
// Extract the icon mask
AddMaskOnly(IconInfo.hbmMask);
end;
procedure AddMetafileMask(Metafile: TMetaFile);
var
Mask1 ,
Mask2 : TBitmap;
procedure DrawMetafile(ABitmap: TBitmap; Background: TColor);
begin
ABitmap.Width := Metafile.Width;
ABitmap.Height := Metafile.Height;
{$ifndef VER9x}
SetPixelFormat(ABitmap, pf24bit);
{$endif}
ABitmap.Canvas.Brush.Color := Background;
ABitmap.Canvas.Brush.Style := bsSolid;
ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
ABitmap.Canvas.Draw(0,0, Metafile);
end;
begin
// Create the metafile mask
Mask1 := TBitmap.Create;
try
Mask2 := TBitmap.Create;
try
DrawMetafile(Mask1, clWhite);
DrawMetafile(Mask2, clBlack);
Mask1.Canvas.CopyMode := cmSrcInvert;
Mask1.Canvas.Draw(0,0, Mask2);
AddMask(Mask1);
finally
Mask2.Free;
end;
finally
Mask1.Free;
end;
end;
begin
if (Source = self) then
exit;
if (Source = nil) then
begin
Clear;
end else
//
// TGIFSubImage import
//
if (Source is TGIFSubImage) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TGIFSubImage(Source).Empty) then
exit;
// Copy source data
FImageDescriptor := TGIFSubImage(Source).FImageDescriptor;
FTransparent := TGIFSubImage(Source).Transparent;
// Copy image data
NewImage;
if (FData <> nil) and (TGIFSubImage(Source).Data <> nil) then
Move(TGIFSubImage(Source).Data^, FData^, FDataSize);
// Copy palette
FColorMap.Assign(TGIFSubImage(Source).ColorMap);
// Copy extensions
if (TGIFSubImage(Source).Extensions.Count > 0) then
begin
MemoryStream := TMemoryStream.Create;
try
TGIFSubImage(Source).Extensions.SaveToStream(MemoryStream);
MemoryStream.Seek(0, soFromBeginning);
Extensions.LoadFromStream(MemoryStream, Self);
finally
MemoryStream.Free;
end;
end;
// Copy bitmap representation
// (Not really nescessary but improves performance if the bitmap is needed
// later on)
if (TGIFSubImage(Source).HasBitmap) then
begin
NewBitmap;
FBitmap.Assign(TGIFSubImage(Source).Bitmap);
end;
end else
//
// Bitmap import
//
if (Source is TBitmap) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TBitmap(Source).Empty) then
exit;
Width := TBitmap(Source).Width;
Height := TBitmap(Source).Height;
PixelFormat := GetPixelFormat(TBitmap(Source));
{$ifdef VER9x}
// Delphi 2 TBitmaps are always DDBs. This means that if a 24 bit
// bitmap is loaded in 8 bit device mode, TBitmap.PixelFormat will
// be pf8bit, but TBitmap.Palette will be 0!
if (TBitmap(Source).Palette = 0) then
PixelFormat := pfDevice;
{$endif}
if (PixelFormat > pf8bit) or (PixelFormat = pfDevice) then
begin
// Convert image to 8 bits/pixel or less
FBitmap := ReduceColors(TBitmap(Source), Image.ColorReduction,
Image.DitherMode, Image.ReductionBits, 0);
PixelFormat := GetPixelFormat(FBitmap);