RichEdit

开发平台：

Delphi

GifImage.pas：源码内容

end else
begin
// Create new bitmap and copy
NewBitmap;
FBitmap.Assign(TBitmap(Source));
end;
// Allocate new buffer
NewImage;
Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressConverting);
try
{$ifdef VER9x}
// This shouldn't happen, but better safe...
if (FBitmap.Palette = 0) then
PixelFormat := pf24bit;
{$endif}
if (not(PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit])) then
PixelFormat := pf24bit;
DIBSource := TDIBReader.Create(FBitmap, PixelFormat);
try
// Copy pixels
case (PixelFormat) of
pf8bit: Import8Bit(Fdata);
pf4bit: Import4Bit(Fdata);
pf1bit: Import1Bit(Fdata);
else
// Error(sUnsupportedBitmap);
Import24Bit(Fdata);
end;
finally
DIBSource.Free;
end;
{$ifdef VER10_PLUS}
// Add mask for transparent bitmaps
if (TBitmap(Source).Transparent) then
AddMaskOnly(TBitmap(Source).MaskHandle);
{$endif}
finally
if ExceptObject = nil then
i := 100
else
i := 0;
Image.Progress(Self, psEnding, i, Image.PaletteModified, Rect(0,0,0,0), sProgressConverting);
end;
end else
//
// TGraphic import
//
if (Source is TGraphic) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TGraphic(Source).Empty) then
exit;
ABitmap := TBitmap.Create;
try
// Import TIcon and TMetafile by drawing them onto a bitmap...
// ...and then importing the bitmap recursively
if (Source is TIcon) or (Source is TMetafile) then
begin
try
ImportViaDraw(ABitmap, TGraphic(Source))
except
// If import via TCanvas.Draw fails (which it shouldn't), we try the
// Assign mechanism instead
ABitmap.Assign(Source);
end;
end else
try
ABitmap.Assign(Source);
except
// If automatic conversion to bitmap fails, we try and draw the
// graphic on the bitmap instead
ImportViaDraw(ABitmap, TGraphic(Source));
end;
// Convert the bitmap to a GIF frame recursively
Assign(ABitmap);
finally
ABitmap.Free;
end;
// Import transparency mask
if (Source is TIcon) then
AddIconMask(TIcon(Source));
if (Source is TMetaFile) then
AddMetafileMask(TMetaFile(Source));
end else
//
// TPicture import
//
if (Source is TPicture) then
begin
// Recursively import TGraphic
Assign(TPicture(Source).Graphic);
end else
// Unsupported format - fall back to Source.AssignTo
inherited Assign(Source);
end;
// Copied from D3 graphics.pas
// Fixed by Brian Lowe of Acro Technology Inc. 30Jan98
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
MaskY: Integer): Boolean;
const
ROP_DstCopy = $00AA0029;
var
MemDC ,
OrMaskDC : HDC;
MemBmp ,
OrMaskBmp : HBITMAP;
Save ,
OrMaskSave : THandle;
crText, crBack : TColorRef;
SavePal : HPALETTE;
begin
Result := True;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
begin
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
MemBmp := SelectObject(MaskDC, MemBmp);
try
MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
finally
MemBmp := SelectObject(MaskDC, MemBmp);
DeleteObject(MemBmp);
end;
Exit;
end;
SavePal := 0;
MemDC := GDICheck(CreateCompatibleDC(DstDC));
try
{ Color bitmap for combining OR mask with source bitmap }
MemBmp := GDICheck(CreateCompatibleBitmap(DstDC, SrcW, SrcH));
try
Save := SelectObject(MemDC, MemBmp);
try
{ This bitmap needs the size of the source but DC of the dest }
OrMaskDC := GDICheck(CreateCompatibleDC(DstDC));
try
{ Need a monochrome bitmap for OR mask!! }
OrMaskBmp := GDICheck(CreateBitmap(SrcW, SrcH, 1, 1, nil));
try
OrMaskSave := SelectObject(OrMaskDC, OrMaskBmp);
try
// OrMask := 1
// Original: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, WHITENESS);
// Replacement, but not needed: PatBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, WHITENESS);
// OrMask := OrMask XOR Mask
// Not needed: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, SrcInvert);
// OrMask := NOT Mask
BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, NotSrcCopy);
// Retrieve source palette (with dummy select)
SavePal := SelectPalette(SrcDC, SystemPalette16, False);
// Restore source palette
SelectPalette(SrcDC, SavePal, False);
// Select source palette into memory buffer
if SavePal <> 0 then
SavePal := SelectPalette(MemDC, SavePal, True)
else
SavePal := SelectPalette(MemDC, SystemPalette16, True);
RealizePalette(MemDC);
// Mem := OrMask
BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, SrcCopy);
// Mem := Mem AND Src
{$IFNDEF GIF_TESTMASK} // Define GIF_TESTMASK if you want to know what it does...
BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcAnd);
{$ELSE}
StretchBlt(DstDC, DstX, DstY, DstW DIV 2, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
StretchBlt(DstDC, DstX+DstW DIV 2, DstY, DstW DIV 2, DstH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
exit;
{$ENDIF}
finally
if (OrMaskSave <> 0) then
SelectObject(OrMaskDC, OrMaskSave);
end;
finally
DeleteObject(OrMaskBmp);
end;
finally
DeleteDC(OrMaskDC);
end;
crText := SetTextColor(DstDC, $00000000);
crBack := SetBkColor(DstDC, $00FFFFFF);
{ All color rendering is done at 1X (no stretching),
then final 2 masks are stretched to dest DC }
// Neat trick!
// Dst := Dst AND Mask
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, SrcX, SrcY, SrcW, SrcH, SrcAnd);
// Dst := Dst OR Mem
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcPaint);
SetTextColor(DstDC, crText);
SetTextColor(DstDC, crBack);
finally
if (Save <> 0) then
SelectObject(MemDC, Save);
end;
finally
DeleteObject(MemBmp);
end;
finally
if (SavePal <> 0) then
SelectPalette(MemDC, SavePal, False);
DeleteDC(MemDC);
end;
end;
procedure TGIFSubImage.Draw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
begin
if (DoTile) then
StretchDraw(ACanvas, Rect, DoTransparent, DoTile)
else
StretchDraw(ACanvas, ScaleRect(Rect), DoTransparent, DoTile);
end;
type
// Dummy class used to gain access to protected method TCanvas.Changed
TChangableCanvas = class(TCanvas)
end;
procedure TGIFSubImage.StretchDraw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
var
MaskDC : HDC;
Save : THandle;
Tile : TRect;
{$ifdef DEBUG_DRAWPERFORMANCE}
ImageCount ,
TimeStart ,
TimeStop : DWORD;
{$endif}
begin
{$ifdef DEBUG_DRAWPERFORMANCE}
TimeStart := timeGetTime;
ImageCount := 0;
{$endif}
if (DoTransparent) and (Transparent) and (HasMask) then
begin
// Draw transparent using mask
Save := 0;
MaskDC := 0;
try
MaskDC := GDICheck(CreateCompatibleDC(0));
Save := SelectObject(MaskDC, FMask);
if (DoTile) then
begin
Tile.Left := Rect.Left+Left;
Tile.Right := Tile.Left + Width;
while (Tile.Left < Rect.Right) do
begin
Tile.Top := Rect.Top+Top;
Tile.Bottom := Tile.Top + Height;
while (Tile.Top < Rect.Bottom) do
begin
TransparentStretchBlt(ACanvas.Handle, Tile.Left, Tile.Top, Width, Height,
Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
Tile.Top := Tile.Top + Image.Height;
Tile.Bottom := Tile.Bottom + Image.Height;
{$ifdef DEBUG_DRAWPERFORMANCE}
inc(ImageCount);
{$endif}
end;
Tile.Left := Tile.Left + Image.Width;
Tile.Right := Tile.Right + Image.Width;
end;
end else
TransparentStretchBlt(ACanvas.Handle, Rect.Left, Rect.Top,
Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
// Since we are not using any of the TCanvas functions (only handle)
// we need to fire the TCanvas.Changed method "manually".
TChangableCanvas(ACanvas).Changed;
finally
if (Save <> 0) then
SelectObject(MaskDC, Save);
if (MaskDC <> 0) then
DeleteDC(MaskDC);
end;
end else
begin
if (DoTile) then
begin
Tile.Left := Rect.Left+Left;
Tile.Right := Tile.Left + Width;
while (Tile.Left < Rect.Right) do
begin
Tile.Top := Rect.Top+Top;
Tile.Bottom := Tile.Top + Height;
while (Tile.Top < Rect.Bottom) do
begin
ACanvas.StretchDraw(Tile, Bitmap);
Tile.Top := Tile.Top + Image.Height;
Tile.Bottom := Tile.Bottom + Image.Height;
{$ifdef DEBUG_DRAWPERFORMANCE}
inc(ImageCount);
{$endif}
end;
Tile.Left := Tile.Left + Image.Width;
Tile.Right := Tile.Right + Image.Width;
end;
end else
ACanvas.StretchDraw(Rect, Bitmap);
end;
{$ifdef DEBUG_DRAWPERFORMANCE}
if (GetAsyncKeyState(VK_CONTROL) <> 0) then
begin
TimeStop := timeGetTime;
ShowMessage(format('Draw %d images in %d mS, Rate %d images/mS (%d images/S)',
[ImageCount, TimeStop-TimeStart,
ImageCount DIV (TimeStop-TimeStart+1),
MulDiv(ImageCount, 1000, TimeStop-TimeStart+1)]));
end;
{$endif}
end;
// Given a destination rect (DestRect) calculates the
// area covered by this sub image
function TGIFSubImage.ScaleRect(DestRect: TRect): TRect;
var
HeightMul ,
HeightDiv : integer;
WidthMul ,
WidthDiv : integer;
begin
HeightDiv := Image.Height;
HeightMul := DestRect.Bottom-DestRect.Top;
WidthDiv := Image.Width;
WidthMul := DestRect.Right-DestRect.Left;
Result.Left := DestRect.Left + muldiv(Left, WidthMul, WidthDiv);
Result.Top := DestRect.Top + muldiv(Top, HeightMul, HeightDiv);
Result.Right := DestRect.Left + muldiv(Left+Width, WidthMul, WidthDiv);
Result.Bottom := DestRect.Top + muldiv(Top+Height, HeightMul, HeightDiv);
end;
procedure TGIFSubImage.Crop;
var
TransparentColorIndex : byte;
CropLeft ,
CropTop ,
CropRight ,
CropBottom : integer;
WasTransparent : boolean;
i : integer;
NewSize : integer;
NewData : PChar;
NewWidth ,
NewHeight : integer;
pSource ,
pDest : PChar;
begin
if (Empty) or (not Transparent) then
exit;
TransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
CropLeft := 0;
CropRight := Width - 1;
CropTop := 0;
CropBottom := Height - 1;
// Find left edge
WasTransparent := True;
while (CropLeft <= CropRight) and (WasTransparent) do
begin
for i := CropTop to CropBottom do
if (Pixels[CropLeft, i] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
inc(CropLeft);
end;
// Find right edge
WasTransparent := True;
while (CropLeft <= CropRight) and (WasTransparent) do
begin
for i := CropTop to CropBottom do
if (pixels[CropRight, i] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
dec(CropRight);
end;
if (CropLeft <= CropRight) then
begin
// Find top edge
WasTransparent := True;
while (CropTop <= CropBottom) and (WasTransparent) do
begin
for i := CropLeft to CropRight do
if (pixels[i, CropTop] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
inc(CropTop);
end;
// Find bottom edge
WasTransparent := True;
while (CropTop <= CropBottom) and (WasTransparent) do
begin
for i := CropLeft to CropRight do
if (pixels[i, CropBottom] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
dec(CropBottom);
end;
end;
if (CropLeft > CropRight) or (CropTop > CropBottom) then
begin
// Cropped to nothing - frame is invisible
Clear;
end else
begin
// Crop frame - move data
NewWidth := CropRight - CropLeft + 1;
Newheight := CropBottom - CropTop + 1;
NewSize := NewWidth * NewHeight;
GetMem(NewData, NewSize);
pSource := PChar(integer(FData) + CropTop * Width + CropLeft);
pDest := NewData;
for i := 0 to NewHeight-1 do
begin
Move(pSource^, pDest^, NewWidth);
inc(pSource, Width);
inc(pDest, NewWidth);
end;
FreeImage;
FData := NewData;
FDataSize := NewSize;
inc(FImageDescriptor.Left, CropLeft);
inc(FImageDescriptor.Top, CropTop);
FImageDescriptor.Width := NewWidth;
FImageDescriptor.Height := NewHeight;
FreeBitmap;
FreeMask
end;
end;
procedure TGIFSubImage.Merge(Previous: TGIFSubImage);
var
SourceIndex ,
DestIndex : byte;
SourceTransparent : boolean;
NeedTransparentColorIndex: boolean;
PreviousRect ,
ThisRect ,
MergeRect : TRect;
PreviousY ,
X ,
Y : integer;
pSource ,
pDest : PChar;
pSourceMap ,
pDestMap : PColorMap;
GCE : TGIFGraphicControlExtension;
function CanMakeTransparent: boolean;
begin
// Is there a local color map...
if (ColorMap.Count > 0) then
// ...and is there room in it?
Result := (ColorMap.Count < 256)
// Is there a global color map...
else if (Image.GlobalColorMap.Count > 0) then
// ...and is there room in it?
Result := (Image.GlobalColorMap.Count < 256)
else
Result := False;
end;
function GetTransparentColorIndex: byte;
var
i : integer;
begin
if (ColorMap.Count > 0) then
begin
// Get the transparent color from the local color map
Result := ColorMap.Add(TColor(0));
end else
begin
// Are any other frames using the global color map for transparency
for i := 0 to Image.Images.Count-1 do
if (Image.Images[i] <> self) and (Image.Images[i].Transparent) and
(Image.Images[i].ColorMap.Count = 0) then
begin
// Use the same transparency color as the other frame
Result := Image.Images[i].GraphicControlExtension.TransparentColorIndex;
exit;
end;
// Get the transparent color from the global color map
Result := Image.GlobalColorMap.Add(TColor(0));
end;
end;
begin
// Determine if it is possible to merge this frame
if (Empty) or (Previous = nil) or (Previous.Empty) or
((Previous.GraphicControlExtension <> nil) and
(Previous.GraphicControlExtension.Disposal in [dmBackground, dmPrevious])) then
exit;
PreviousRect := Previous.BoundsRect;
ThisRect := BoundsRect;
// Cannot merge unless the frames intersect
if (not IntersectRect(MergeRect, PreviousRect, ThisRect)) then
exit;
// If the frame isn't already transparent, determine
// if it is possible to make it so
if (Transparent) then
begin
DestIndex := GraphicControlExtension.TransparentColorIndex;
NeedTransparentColorIndex := False;
end else
begin
if (not CanMakeTransparent) then
exit;
DestIndex := 0; // To avoid compiler warning
NeedTransparentColorIndex := True;
end;
SourceTransparent := Previous.Transparent;
if (SourceTransparent) then
SourceIndex := Previous.GraphicControlExtension.TransparentColorIndex
else
SourceIndex := 0; // To avoid compiler warning
PreviousY := MergeRect.Top - Previous.Top;
pSourceMap := Previous.ActiveColorMap.Data;
pDestMap := ActiveColorMap.Data;
for Y := MergeRect.Top - Top to MergeRect.Bottom - Top-1 do
begin
pSource := PChar(integer(Previous.Scanline[PreviousY]) + MergeRect.Left - Previous.Left);
pDest := PChar(integer(Scanline[Y]) + MergeRect.Left - Left);
for X := MergeRect.Left to MergeRect.Right-1 do
begin
// Ignore pixels if either this frame's or the previous frame's pixel is transparent
if (
not(
((not NeedTransparentColorIndex) and (pDest^ = char(DestIndex))) or
((SourceTransparent) and (pSource^ = char(SourceIndex)))
)
) and (
// Replace same colored pixels with transparency
((pDestMap = pSourceMap) and (pDest^ = pSource^)) or
(CompareMem(@(pDestMap^[ord(pDest^)]), @(pSourceMap^[ord(pSource^)]), sizeof(TGIFColor)))
) then
begin
if (NeedTransparentColorIndex) then
begin
NeedTransparentColorIndex := False;
DestIndex := GetTransparentColorIndex;
end;
pDest^ := char(DestIndex);
end;
inc(pDest);
inc(pSource);
end;
inc(PreviousY);
end;
(*
** Create a GCE if the frame wasn't already transparent and any
** pixels were made transparent
*)
if (not Transparent) and (not NeedTransparentColorIndex) then
begin
if (GraphicControlExtension = nil) then
begin
GCE := TGIFGraphicControlExtension.Create(self);
Extensions.Add(GCE);
end else
GCE := GraphicControlExtension;
GCE.Transparent := True;
GCE.TransparentColorIndex := DestIndex;
end;
FreeBitmap;
FreeMask
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTrailer
//
////////////////////////////////////////////////////////////////////////////////
procedure TGIFTrailer.SaveToStream(Stream: TStream);
begin
WriteByte(Stream, bsTrailer);
end;
procedure TGIFTrailer.LoadFromStream(Stream: TStream);
var
b : BYTE;
begin
if (Stream.Read(b, 1) <> 1) then
exit;
if (b <> bsTrailer) then
Warning(gsWarning, sBadTrailer);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
TExtensionLeadIn = packed record
Introducer: byte; { always $21 }
ExtensionLabel: byte;
end;
PExtRec = ^TExtRec;
TExtRec = record
ExtClass: TGIFExtensionClass;
ExtLabel: BYTE;
end;
TExtensionList = class(TList)
public
constructor Create;
destructor Destroy; override;
procedure Add(eLabel: BYTE; eClass: TGIFExtensionClass);
function FindExt(eLabel: BYTE): TGIFExtensionClass;
procedure Remove(eClass: TGIFExtensionClass);
end;
constructor TExtensionList.Create;
begin
inherited Create;
Add(bsPlainTextExtension, TGIFTextExtension);
Add(bsGraphicControlExtension, TGIFGraphicControlExtension);
Add(bsCommentExtension, TGIFCommentExtension);
Add(bsApplicationExtension, TGIFApplicationExtension);
end;
destructor TExtensionList.Destroy;
var
I: Integer;
begin
for I := 0 to Count-1 do
Dispose(PExtRec(Items[I]));
inherited Destroy;
end;
procedure TExtensionList.Add(eLabel: BYTE; eClass: TGIFExtensionClass);
var
NewRec: PExtRec;
begin
New(NewRec);
with NewRec^ do
begin
ExtLabel := eLabel;
ExtClass := eClass;
end;
inherited Add(NewRec);
end;
function TExtensionList.FindExt(eLabel: BYTE): TGIFExtensionClass;
var
I: Integer;
begin
for I := Count-1 downto 0 do
with PExtRec(Items[I])^ do
if ExtLabel = eLabel then
begin
Result := ExtClass;
Exit;
end;
Result := nil;
end;
procedure TExtensionList.Remove(eClass: TGIFExtensionClass);
var
I: Integer;
P: PExtRec;
begin
for I := Count-1 downto 0 do
begin
P := PExtRec(Items[I]);
if P^.ExtClass.InheritsFrom(eClass) then
begin
Dispose(P);
Delete(I);
end;
end;
end;
var
ExtensionList: TExtensionList = nil;
function GetExtensionList: TExtensionList;
begin
if (ExtensionList = nil) then
ExtensionList := TExtensionList.Create;
Result := ExtensionList;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension
//
////////////////////////////////////////////////////////////////////////////////
function TGIFExtension.GetVersion: TGIFVersion;
begin
Result := gv89a;
end;
class procedure TGIFExtension.RegisterExtension(eLabel: BYTE; eClass: TGIFExtensionClass);
begin
GetExtensionList.Add(eLabel, eClass);
end;
class function TGIFExtension.FindExtension(Stream: TStream): TGIFExtensionClass;
var
eLabel : BYTE;
SubClass : TGIFExtensionClass;
Pos : LongInt;
begin
Pos := Stream.Position;
if (Stream.Read(eLabel, 1) <> 1) then
begin
Result := nil;
exit;
end;
Result := GetExtensionList.FindExt(eLabel);
while (Result <> nil) do
begin
SubClass := Result.FindSubExtension(Stream);
if (SubClass = Result) then
break;
Result := SubClass;
end;
Stream.Position := Pos;
end;
class function TGIFExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
begin
Result := self;
end;
constructor TGIFExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage.Image);
FSubImage := ASubImage;
end;
destructor TGIFExtension.Destroy;
begin
if (FSubImage <> nil) then
FSubImage.Extensions.Remove(self);
inherited Destroy;
end;
procedure TGIFExtension.SaveToStream(Stream: TStream);
var
ExtensionLeadIn : TExtensionLeadIn;
begin
ExtensionLeadIn.Introducer := bsExtensionIntroducer;
ExtensionLeadIn.ExtensionLabel := ExtensionType;
Stream.Write(ExtensionLeadIn, sizeof(ExtensionLeadIn));
end;
function TGIFExtension.DoReadFromStream(Stream: TStream): TGIFExtensionType;
var
ExtensionLeadIn : TExtensionLeadIn;
begin
ReadCheck(Stream, ExtensionLeadIn, sizeof(ExtensionLeadIn));
if (ExtensionLeadIn.Introducer <> bsExtensionIntroducer) then
Error(sBadExtensionLabel);
Result := ExtensionLeadIn.ExtensionLabel;
end;
procedure TGIFExtension.LoadFromStream(Stream: TStream);
begin
// Seek past lead-in
// Stream.Seek(sizeof(TExtensionLeadIn), soFromCurrent);
if (DoReadFromStream(Stream) <> ExtensionType) then
Error(sBadExtensionInstance);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFGraphicControlExtension
//
////////////////////////////////////////////////////////////////////////////////
const
{ Extension flag bit masks }
efInputFlag = $02; { 00000010 }
efDisposal = $1C; { 00011100 }
efTransparent = $01; { 00000001 }
efReserved = $E0; { 11100000 }
constructor TGIFGraphicControlExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FGCExtension.BlockSize := 4;
FGCExtension.PackedFields := $00;
FGCExtension.DelayTime := 0;
FGCExtension.TransparentColorIndex := 0;
FGCExtension.Terminator := 0;
if (ASubImage.FGCE = nil) then
ASubImage.FGCE := self;
end;
destructor TGIFGraphicControlExtension.Destroy;
begin
// Clear transparent flag in sub image
if (Transparent) then
SubImage.FTransparent := False;
if (SubImage.FGCE = self) then
SubImage.FGCE := nil;
inherited Destroy;
end;
function TGIFGraphicControlExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsGraphicControlExtension;
end;
function TGIFGraphicControlExtension.GetTransparent: boolean;
begin
Result := (FGCExtension.PackedFields AND efTransparent) <> 0;
end;
procedure TGIFGraphicControlExtension.SetTransparent(Value: boolean);
begin
// Set transparent flag in sub image
SubImage.FTransparent := Value;
if (Value) then
FGCExtension.PackedFields := FGCExtension.PackedFields OR efTransparent
else
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efTransparent);
end;
function TGIFGraphicControlExtension.GetTransparentColor: TColor;
begin
Result := SubImage.ActiveColorMap[TransparentColorIndex];
end;
procedure TGIFGraphicControlExtension.SetTransparentColor(Color: TColor);
begin
FGCExtension.TransparentColorIndex := Subimage.ActiveColorMap.AddUnique(Color);
end;
function TGIFGraphicControlExtension.GetTransparentColorIndex: BYTE;
begin
Result := FGCExtension.TransparentColorIndex;
end;
procedure TGIFGraphicControlExtension.SetTransparentColorIndex(Value: BYTE);
begin
if ((Value >= SubImage.ActiveColorMap.Count) and (SubImage.ActiveColorMap.Count > 0)) then
begin
Warning(gsWarning, sBadColorIndex);
Value := 0;
end;
FGCExtension.TransparentColorIndex := Value;
end;
function TGIFGraphicControlExtension.GetDelay: WORD;
begin
Result := FGCExtension.DelayTime;
end;
procedure TGIFGraphicControlExtension.SetDelay(Value: WORD);
begin
FGCExtension.DelayTime := Value;
end;
function TGIFGraphicControlExtension.GetUserInput: boolean;
begin
Result := (FGCExtension.PackedFields AND efInputFlag) <> 0;
end;
procedure TGIFGraphicControlExtension.SetUserInput(Value: boolean);
begin
if (Value) then
FGCExtension.PackedFields := FGCExtension.PackedFields OR efInputFlag
else
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efInputFlag);
end;
function TGIFGraphicControlExtension.GetDisposal: TDisposalMethod;
begin
Result := TDisposalMethod((FGCExtension.PackedFields AND efDisposal) SHR 2);
end;
procedure TGIFGraphicControlExtension.SetDisposal(Value: TDisposalMethod);
begin
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efDisposal)
OR ((ord(Value) SHL 2) AND efDisposal);
end;
procedure TGIFGraphicControlExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
Stream.Write(FGCExtension, sizeof(FGCExtension));
end;
procedure TGIFGraphicControlExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
if (Stream.Read(FGCExtension, sizeof(FGCExtension)) <> sizeof(FGCExtension)) then
begin
Warning(gsWarning, sOutOfData);
exit;
end;
// Set transparent flag in sub image
if (Transparent) then
SubImage.FTransparent := True;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTextExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFTextExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FText := TStringList.Create;
FPlainTextExtension.BlockSize := 12;
FPlainTextExtension.Left := 0;
FPlainTextExtension.Top := 0;
FPlainTextExtension.Width := 0;
FPlainTextExtension.Height := 0;
FPlainTextExtension.CellWidth := 0;
FPlainTextExtension.CellHeight := 0;
FPlainTextExtension.TextFGColorIndex := 0;
FPlainTextExtension.TextBGColorIndex := 0;
end;
destructor TGIFTextExtension.Destroy;
begin
FText.Free;
inherited Destroy;
end;
function TGIFTextExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsPlainTextExtension;
end;
function TGIFTextExtension.GetForegroundColor: TColor;
begin
Result := SubImage.ColorMap[ForegroundColorIndex];
end;
procedure TGIFTextExtension.SetForegroundColor(Color: TColor);
begin
ForegroundColorIndex := SubImage.ActiveColorMap.AddUnique(Color);
end;
function TGIFTextExtension.GetBackgroundColor: TColor;
begin
Result := SubImage.ActiveColorMap[BackgroundColorIndex];
end;
procedure TGIFTextExtension.SetBackgroundColor(Color: TColor);
begin
BackgroundColorIndex := SubImage.ColorMap.AddUnique(Color);
end;
function TGIFTextExtension.GetBounds(Index: integer): WORD;
begin
case (Index) of
1: Result := FPlainTextExtension.Left;
2: Result := FPlainTextExtension.Top;
3: Result := FPlainTextExtension.Width;
4: Result := FPlainTextExtension.Height;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetBounds(Index: integer; Value: WORD);
begin
case (Index) of
1: FPlainTextExtension.Left := Value;
2: FPlainTextExtension.Top := Value;
3: FPlainTextExtension.Width := Value;
4: FPlainTextExtension.Height := Value;
end;
end;
function TGIFTextExtension.GetCharWidthHeight(Index: integer): BYTE;
begin
case (Index) of
1: Result := FPlainTextExtension.CellWidth;
2: Result := FPlainTextExtension.CellHeight;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetCharWidthHeight(Index: integer; Value: BYTE);
begin
case (Index) of
1: FPlainTextExtension.CellWidth := Value;
2: FPlainTextExtension.CellHeight := Value;
end;
end;
function TGIFTextExtension.GetColorIndex(Index: integer): BYTE;
begin
case (Index) of
1: Result := FPlainTextExtension.TextFGColorIndex;
2: Result := FPlainTextExtension.TextBGColorIndex;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetColorIndex(Index: integer; Value: BYTE);
begin
case (Index) of
1: FPlainTextExtension.TextFGColorIndex := Value;
2: FPlainTextExtension.TextBGColorIndex := Value;
end;
end;
procedure TGIFTextExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
Stream.Write(FPlainTextExtension, sizeof(FPlainTextExtension));
WriteStrings(Stream, FText);
end;
procedure TGIFTextExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
ReadCheck(Stream, FPlainTextExtension, sizeof(FPlainTextExtension));
ReadStrings(Stream, FText);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFCommentExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFCommentExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FText := TStringList.Create;
end;
destructor TGIFCommentExtension.Destroy;
begin
FText.Free;
inherited Destroy;
end;
function TGIFCommentExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsCommentExtension;
end;
procedure TGIFCommentExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
WriteStrings(Stream, FText);
end;
procedure TGIFCommentExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
ReadStrings(Stream, FText);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
PAppExtRec = ^TAppExtRec;
TAppExtRec = record
AppClass: TGIFAppExtensionClass;
Ident: TGIFApplicationRec;
end;
TAppExtensionList = class(TList)
public
constructor Create;
destructor Destroy; override;
procedure Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
function FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
procedure Remove(eClass: TGIFAppExtensionClass);
end;
constructor TAppExtensionList.Create;
const
NSLoopIdent: array[0..1] of TGIFApplicationRec =
((Identifier: 'NETSCAPE'; Authentication: '2.0'),
(Identifier: 'ANIMEXTS'; Authentication: '1.0'));
begin
inherited Create;
Add(NSLoopIdent[0], TGIFAppExtNSLoop);
Add(NSLoopIdent[1], TGIFAppExtNSLoop);
end;
destructor TAppExtensionList.Destroy;
var
I: Integer;
begin
for I := 0 to Count-1 do
Dispose(PAppExtRec(Items[I]));
inherited Destroy;
end;
procedure TAppExtensionList.Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
var
NewRec: PAppExtRec;
begin
New(NewRec);
NewRec^.Ident := eIdent;
NewRec^.AppClass := eClass;
inherited Add(NewRec);
end;
function TAppExtensionList.FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
var
I: Integer;
begin
for I := Count-1 downto 0 do
with PAppExtRec(Items[I])^ do
if CompareMem(@Ident, @eIdent, sizeof(TGIFApplicationRec)) then
begin
Result := AppClass;
Exit;
end;
Result := nil;
end;
procedure TAppExtensionList.Remove(eClass: TGIFAppExtensionClass);
var
I: Integer;
P: PAppExtRec;
begin
for I := Count-1 downto 0 do
begin
P := PAppExtRec(Items[I]);
if P^.AppClass.InheritsFrom(eClass) then
begin
Dispose(P);
Delete(I);
end;
end;
end;
var
AppExtensionList: TAppExtensionList = nil;
function GetAppExtensionList: TAppExtensionList;
begin
if (AppExtensionList = nil) then
AppExtensionList := TAppExtensionList.Create;
Result := AppExtensionList;
end;
class procedure TGIFApplicationExtension.RegisterExtension(eIdent: TGIFApplicationRec;
eClass: TGIFAppExtensionClass);
begin
GetAppExtensionList.Add(eIdent, eClass);
end;
class function TGIFApplicationExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
var
eIdent : TGIFApplicationRec;
OldPos : longInt;
Size : BYTE;
begin
OldPos := Stream.Position;
Result := nil;
if (Stream.Read(Size, 1) <> 1) then
exit;
// Some old Adobe export filters mistakenly uses a value of 10
if (Size = 10) then
begin
{ TODO -oanme -cImprovement : replace with seek or read and check contents = 'Adobe' }
if (Stream.Read(eIdent, 10) <> 10) then
exit;
Result := TGIFUnknownAppExtension;
exit;
end else
if (Size <> sizeof(TGIFApplicationRec)) or
(Stream.Read(eIdent, sizeof(eIdent)) <> sizeof(eIdent)) then
begin
Stream.Position := OldPos;
Result := inherited FindSubExtension(Stream);
end else
begin
Result := GetAppExtensionList.FindExt(eIdent);
if (Result = nil) then
Result := TGIFUnknownAppExtension;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFApplicationExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FillChar(FIdent, sizeof(FIdent), 0);
end;
destructor TGIFApplicationExtension.Destroy;
begin
inherited Destroy;
end;
function TGIFApplicationExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsApplicationExtension;
end;
function TGIFApplicationExtension.GetAuthentication: string;
begin
Result := FIdent.Authentication;
end;
procedure TGIFApplicationExtension.SetAuthentication(const Value: string);
begin
if (Length(Value) < sizeof(TGIFAuthenticationCode)) then
FillChar(FIdent.Authentication, sizeof(TGIFAuthenticationCode), 32);
StrLCopy(@(FIdent.Authentication[0]), PChar(Value), sizeof(TGIFAuthenticationCode));
end;
function TGIFApplicationExtension.GetIdentifier: string;
begin
Result := FIdent.Identifier;
end;
procedure TGIFApplicationExtension.SetIdentifier(const Value: string);
begin
if (Length(Value) < sizeof(TGIFIdentifierCode)) then
FillChar(FIdent.Identifier, sizeof(TGIFIdentifierCode), 32);
StrLCopy(@(FIdent.Identifier[0]), PChar(Value), sizeof(TGIFIdentifierCode));
end;
procedure TGIFApplicationExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
WriteByte(Stream, sizeof(FIdent)); // Block size
Stream.Write(FIdent, sizeof(FIdent));
SaveData(Stream);
end;
procedure TGIFApplicationExtension.LoadFromStream(Stream: TStream);
var
i : integer;
begin
inherited LoadFromStream(Stream);
i := ReadByte(Stream);
// Some old Adobe export filters mistakenly uses a value of 10
if (i = 10) then
FillChar(FIdent, sizeOf(FIdent), 0)
else
if (i < 11) then
Error(sBadBlockSize);
ReadCheck(Stream, FIdent, sizeof(FIdent));
Dec(i, sizeof(FIdent));
// Ignore extra data
Stream.Seek(i, soFromCurrent);
// ***FIXME***
// If self class is TGIFApplicationExtension, this will cause an "abstract
// error".
// TGIFApplicationExtension.LoadData should read and ignore rest of block.
LoadData(Stream);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFUnknownAppExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFBlock.Create(ASize: integer);
begin
inherited Create;
FSize := ASize;
GetMem(FData, FSize);
FillChar(FData^, FSize, 0);
end;
destructor TGIFBlock.Destroy;
begin
FreeMem(FData);
inherited Destroy;
end;
procedure TGIFBlock.SaveToStream(Stream: TStream);
begin
Stream.Write(FSize, 1);
Stream.Write(FData^, FSize);
end;
procedure TGIFBlock.LoadFromStream(Stream: TStream);
begin
ReadCheck(Stream, FData^, FSize);
end;
constructor TGIFUnknownAppExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FBlocks := TList.Create;
end;
destructor TGIFUnknownAppExtension.Destroy;
var
i : integer;
begin
for i := 0 to FBlocks.Count-1 do
TGIFBlock(FBlocks[i]).Free;
FBlocks.Free;
inherited Destroy;
end;
procedure TGIFUnknownAppExtension.SaveData(Stream: TStream);
var
i : integer;
begin
for i := 0 to FBlocks.Count-1 do
TGIFBlock(FBlocks[i]).SaveToStream(Stream);
// Terminating zero
WriteByte(Stream, 0);
end;
procedure TGIFUnknownAppExtension.LoadData(Stream: TStream);
var
b : BYTE;
Block : TGIFBlock;
i : integer;
begin
// Zap old blocks
for i := 0 to FBlocks.Count-1 do
TGIFBlock(FBlocks[i]).Free;
FBlocks.Clear;
// Read blocks
if (Stream.Read(b, 1) <> 1) then
exit;
while (b <> 0) do
begin
Block := TGIFBlock.Create(b);
try
Block.LoadFromStream(Stream);
except
Block.Free;
raise;
end;
FBlocks.Add(Block);
if (Stream.Read(b, 1) <> 1) then
exit;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFAppExtNSLoop
//
////////////////////////////////////////////////////////////////////////////////
const
// Netscape sub block types
nbLoopExtension = 1;
nbBufferExtension = 2;
constructor TGIFAppExtNSLoop.Create(ASubImage: TGIFSubImage);
const
NSLoopIdent: TGIFApplicationRec = (Identifier: 'NETSCAPE'; Authentication: '2.0');
begin
inherited Create(ASubImage);
FIdent := NSLoopIdent;
end;
procedure TGIFAppExtNSLoop.SaveData(Stream: TStream);
begin
// Write loop count
WriteByte(Stream, 1 + sizeof(FLoops)); // Size of block
WriteByte(Stream, nbLoopExtension); // Identify sub block as looping extension data
Stream.Write(FLoops, sizeof(FLoops)); // Loop count
// Write buffer size if specified
if (FBufferSize > 0) then
begin
WriteByte(Stream, 1 + sizeof(FBufferSize)); // Size of block
WriteByte(Stream, nbBufferExtension); // Identify sub block as buffer size data
Stream.Write(FBufferSize, sizeof(FBufferSize)); // Buffer size
end;
WriteByte(Stream, 0); // Terminating zero
end;
procedure TGIFAppExtNSLoop.LoadData(Stream: TStream);
var
BlockSize : integer;
BlockType : integer;
begin
// Read size of first block or terminating zero
BlockSize := ReadByte(Stream);
while (BlockSize <> 0) do
begin
BlockType := ReadByte(Stream);
dec(BlockSize);
case (BlockType AND $07) of
nbLoopExtension:
begin
if (BlockSize < sizeof(FLoops)) then
Error(sInvalidData);
// Read loop count
ReadCheck(Stream, FLoops, sizeof(FLoops));
dec(BlockSize, sizeof(FLoops));
end;
nbBufferExtension:
begin
if (BlockSize < sizeof(FBufferSize)) then
Error(sInvalidData);
// Read buffer size
ReadCheck(Stream, FBufferSize, sizeof(FBufferSize));
dec(BlockSize, sizeof(FBufferSize));
end;
end;
// Skip/ignore unread data
if (BlockSize > 0) then
Stream.Seek(BlockSize, soFromCurrent);
// Read size of next block or terminating zero
BlockSize := ReadByte(Stream);
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImageList
//
////////////////////////////////////////////////////////////////////////////////
function TGIFImageList.GetImage(Index: Integer): TGIFSubImage;
begin
Result := TGIFSubImage(Items[Index]);
end;
procedure TGIFImageList.SetImage(Index: Integer; SubImage: TGIFSubImage);
begin
Items[Index] := SubImage;
end;
procedure TGIFImageList.LoadFromStream(Stream: TStream; Parent: TObject);
var
b : BYTE;
SubImage : TGIFSubImage;
begin
// Peek ahead to determine block type
repeat
if (Stream.Read(b, 1) <> 1) then
exit;
until (b <> 0); // Ignore 0 padding (non-compliant)
while (b <> bsTrailer) do
begin
Stream.Seek(-1, soFromCurrent);
if (b in [bsExtensionIntroducer, bsImageDescriptor]) then
begin
SubImage := TGIFSubImage.Create(Parent as TGIFImage);
try
SubImage.LoadFromStream(Stream);
Add(SubImage);
Image.Progress(Self, psRunning, MulDiv(Stream.Position, 100, Stream.Size),
GIFImageRenderOnLoad, Rect(0,0,0,0), sProgressLoading);
except
SubImage.Free;
raise;
end;
end else
begin
Warning(gsWarning, sBadBlock);
break;
end;
repeat
if (Stream.Read(b, 1) <> 1) then
exit;
until (b <> 0); // Ignore 0 padding (non-compliant)
end;
Stream.Seek(-1, soFromCurrent);
end;
procedure TGIFImageList.SaveToStream(Stream: TStream);
var
i : integer;
begin
for i := 0 to Count-1 do
begin
TGIFItem(Items[i]).SaveToStream(Stream);
Image.Progress(Self, psRunning, MulDiv((i+1), 100, Count), False, Rect(0,0,0,0), sProgressSaving);
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFPainter
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFPainter.CreateRef(Painter: PGIFPainter; AImage: TGIFImage;
ACanvas: TCanvas; ARect: TRect; Options: TGIFDrawOptions);
begin
Create(AImage, ACanvas, ARect, Options);
PainterRef := Painter;
if (PainterRef <> nil) then
PainterRef^ := self;
end;
constructor TGIFPainter.Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
Options: TGIFDrawOptions);
var
i : integer;
BackgroundColor : TColor;
Disposals : set of TDisposalMethod;
begin
inherited Create(True);
FreeOnTerminate := True;
Onterminate := DoOnTerminate;
FImage := AImage;
FCanvas := ACanvas;
FRect := ARect;
FActiveImage := -1;
FDrawOptions := Options;
FStarted := False;
BackupBuffer := nil;
FrameBuffer := nil;
Background := nil;
FEventHandle := 0;
// This should be a parameter, but I think I've got enough of them already...
FAnimationSpeed := FImage.AnimationSpeed;
// An event handle is used for animation delays
if (FDrawOptions >= [goAnimate, goAsync]) and (FImage.Images.Count > 1) and
(FAnimationSpeed >= 0) then
FEventHandle := CreateEvent(nil, False, False, nil);
// Preprocessing of extensions to determine if we need frame buffers
Disposals := [];
if (FImage.DrawBackgroundColor = clNone) then
begin
if (FImage.GlobalColorMap.Count > 0) then
BackgroundColor := FImage.BackgroundColor
else
BackgroundColor := ColorToRGB(clWindow);
end else
BackgroundColor := ColorToRGB(FImage.DrawBackgroundColor);
// Need background buffer to clear on loop
if (goClearOnLoop in FDrawOptions) then
Include(Disposals, dmBackground);
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].GraphicControlExtension <> nil) then
with (FImage.Images[i].GraphicControlExtension) do
Include(Disposals, Disposal);
// Need background buffer to draw transparent on background
if (dmBackground in Disposals) and (goTransparent in FDrawOptions) then
begin
Background := TBitmap.Create;
Background.Height := FRect.Bottom-FRect.Top;
Background.Width := FRect.Right-FRect.Left;
// Copy background immediately
Background.Canvas.CopyMode := cmSrcCopy;
Background.Canvas.CopyRect(Background.Canvas.ClipRect, FCanvas, FRect);
end;
// Need frame- and backup buffer to restore to previous and background
if ((Disposals * [dmPrevious, dmBackground]) <> []) then
begin
BackupBuffer := TBitmap.Create;
BackupBuffer.Height := FRect.Bottom-FRect.Top;
BackupBuffer.Width := FRect.Right-FRect.Left;
BackupBuffer.Canvas.CopyMode := cmSrcCopy;
BackupBuffer.Canvas.Brush.Color := BackgroundColor;
BackupBuffer.Canvas.Brush.Style := bsSolid;
{$IFDEF DEBUG}
BackupBuffer.Canvas.Brush.Color := clBlack;
BackupBuffer.Canvas.Brush.Style := bsDiagCross;
{$ENDIF}
// Step 1: Copy destination to backup buffer
// Always executed before first frame and only once.
BackupBuffer.Canvas.CopyRect(BackupBuffer.Canvas.ClipRect, FCanvas, FRect);
FrameBuffer := TBitmap.Create;
FrameBuffer.Height := FRect.Bottom-FRect.Top;
FrameBuffer.Width := FRect.Right-FRect.Left;
FrameBuffer.Canvas.CopyMode := cmSrcCopy;
FrameBuffer.Canvas.Brush.Color := BackgroundColor;
FrameBuffer.Canvas.Brush.Style := bsSolid;
{$IFDEF DEBUG}
FrameBuffer.Canvas.Brush.Color := clBlack;
FrameBuffer.Canvas.Brush.Style := bsDiagCross;
{$ENDIF}
end;
end;
destructor TGIFPainter.Destroy;
begin
// OnTerminate isn't called if we are running in main thread, so we must call
// it manually
if not(goAsync in DrawOptions) then
DoOnTerminate(self);
// Reraise any exptions that were eaten in the Execute method
if (ExceptObject <> nil) then
raise ExceptObject at ExceptAddress;
inherited Destroy;
end;
procedure TGIFPainter.SetAnimationSpeed(Value: integer);
begin
if (Value < 0) then
Value := 0
else if (Value > 1000) then
Value := 1000;
if (Value <> FAnimationSpeed) then
begin
FAnimationSpeed := Value;
// Signal WaitForSingleObject delay to abort
if (FEventHandle <> 0) then
SetEvent(FEventHandle)
else
DoRestart := True;
end;
end;
procedure TGIFPainter.SetActiveImage(const Value: integer);
begin
if (Value >= 0) and (Value < FImage.Images.Count) then
FActiveImage := Value;
end;
// Conditional Synchronize
procedure TGIFPainter.DoSynchronize(Method: TThreadMethod);
begin
if (Terminated) then
exit;
if (goAsync in FDrawOptions) then
// Execute Synchronized if requested...
Synchronize(Method)
else
// ...Otherwise just execute in current thread (probably main thread)
Method;
end;
// Delete frame buffers - Executed in main thread
procedure TGIFPainter.DoOnTerminate(Sender: TObject);
begin
// It shouldn't really be nescessary to protect PainterRef in this manner
// since we are running in the main thread at this point, but I'm a little
// paranoid about the way PainterRef is being used...
with Image.Painters.LockList do
try
// Zap pointer to self and remove from painter list
if (PainterRef <> nil) and (PainterRef^ = self) then
PainterRef^ := nil;
finally
Image.Painters.UnLockList;
end;
Image.Painters.Remove(self);
FImage := nil;
// Free buffers
if (BackupBuffer <> nil) then
BackupBuffer.Free;
if (FrameBuffer <> nil) then
FrameBuffer.Free;
if (Background <> nil) then
Background.Free;
// Delete event handle
if (FEventHandle <> 0) then
CloseHandle(FEventHandle);
end;
// Event "dispatcher" - Executed in main thread
procedure TGIFPainter.DoEvent;
begin
if (Assigned(FEvent)) then
FEvent(self);
end;
// Non-buffered paint - Executed in main thread
procedure TGIFPainter.DoPaint;
begin
FImage.Images[ActiveImage].Draw(FCanvas, FRect, (goTransparent in FDrawOptions),
(goTile in FDrawOptions));
FStarted := True;
end;
// Buffered paint - Executed in main thread
procedure TGIFPainter.DoPaintFrame;
var
DrawDestination : TCanvas;
DrawRect : TRect;
DoStep2 ,
DoStep3 ,
DoStep5 ,
DoStep6 : boolean;
SavePal ,
SourcePal : HPALETTE;
procedure ClearBackup;
var
r ,
Tile : TRect;
FrameTop ,
FrameHeight : integer;
ImageWidth ,
ImageHeight : integer;
begin
if (goTransparent in FDrawOptions) then
begin
// If the frame is transparent, we must remove it by copying the
// background buffer over it
if (goTile in FDrawOptions) then
begin
FrameTop := FImage.Images[ActiveImage].Top;
FrameHeight := FImage.Images[ActiveImage].Height;
ImageWidth := FImage.Width;
ImageHeight := FImage.Height;
Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
while (Tile.Left < FRect.Right) do
begin
Tile.Top := FRect.Top + FrameTop;
Tile.Bottom := Tile.Top + FrameHeight;
while (Tile.Top < FRect.Bottom) do
begin
BackupBuffer.Canvas.CopyRect(Tile, Background.Canvas, Tile);
Tile.Top := Tile.Top + ImageHeight;
Tile.Bottom := Tile.Bottom + ImageHeight;
end;
Tile.Left := Tile.Left + ImageWidth;
Tile.Right := Tile.Right + ImageWidth;
end;
end else
begin
r := FImage.Images[ActiveImage].ScaleRect(BackupBuffer.Canvas.ClipRect);
BackupBuffer.Canvas.CopyRect(r, Background.Canvas, r)
end;
end else
begin
// If the frame isn't transparent, we just clear the area covered by
// it to the background color.
// Tile the background unless the frame covers all of the image
if (goTile in FDrawOptions) and
((FImage.Width <> FImage.Images[ActiveImage].Width) and
(FImage.height <> FImage.Images[ActiveImage].Height)) then
begin
FrameTop := FImage.Images[ActiveImage].Top;
FrameHeight := FImage.Images[ActiveImage].Height;
ImageWidth := FImage.Width;
ImageHeight := FImage.Height;
// ***FIXME*** I don't think this does any difference
BackupBuffer.Canvas.Brush.Color := FImage.DrawBackgroundColor;
Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
while (Tile.Left < FRect.Right) do
begin
Tile.Top := FRect.Top + FrameTop;
Tile.Bottom := Tile.Top + FrameHeight;
while (Tile.Top < FRect.Bottom) do
begin
BackupBuffer.Canvas.FillRect(Tile);
Tile.Top := Tile.Top + ImageHeight;
Tile.Bottom := Tile.Bottom + ImageHeight;
end;
Tile.Left := Tile.Left + ImageWidth;
Tile.Right := Tile.Right + ImageWidth;
end;
end else
BackupBuffer.Canvas.FillRect(FImage.Images[ActiveImage].ScaleRect(FRect));
end;
end;
begin
if (goValidateCanvas in FDrawOptions) then
if (GetObjectType(ValidateDC) <> OBJ_DC) then
begin
Terminate;
exit;
end;
DrawDestination := nil;
DoStep2 := (goClearOnLoop in FDrawOptions) and (FActiveImage = 0);
DoStep3 := False;
DoStep5 := False;
DoStep6 := False;
{
Disposal mode algorithm:
Step 1: Copy destination to backup buffer
Always executed before first frame and only once.
Done in constructor.
Step 2: Clear previous frame (implementation is same as step 6)
Done implicitly by implementation.
Only done explicitly on first frame if goClearOnLoop option is set.
Step 3: Copy backup buffer to frame buffer
Step 4: Draw frame
Step 5: Copy buffer to destination
Step 6: Clear frame from backup buffer
+------------+------------------+---------------------+------------------------+
|New Old | dmNone | dmBackground | dmPrevious |
+------------+------------------+---------------------+------------------------+
|dmNone | | | |
| |4. Paint on backup|4. Paint on backup |4. Paint on backup |
| |5. Restore |5. Restore |5. Restore |
+------------+------------------+---------------------+------------------------+
|dmBackground| | | |
| |4. Paint on backup|4. Paint on backup |4. Paint on backup |
| |5. Restore |5. Restore |5. Restore |
| |6. Clear backup |6. Clear backup |6. Clear backup |
+------------+------------------+---------------------+------------------------+
|dmPrevious | | | |
| | |3. Copy backup to buf|3. Copy backup to buf |
| |4. Paint on dest |4. Paint on buf |4. Paint on buf |
| | |5. Copy buf to dest |5. Copy buf to dest |
+------------+------------------+---------------------+------------------------+
}
case (Disposal) of
dmNone, dmNoDisposal:
begin
DrawDestination := BackupBuffer.Canvas;
DrawRect := BackupBuffer.Canvas.ClipRect;
DoStep5 := True;
end;
dmBackground:
begin
DrawDestination := BackupBuffer.Canvas;
DrawRect := BackupBuffer.Canvas.ClipRect;
DoStep5 := True;
DoStep6 := True;
end;
dmPrevious:
case (OldDisposal) of
dmNone, dmNoDisposal:
begin
DrawDestination := FCanvas;
DrawRect := FRect;
end;
dmBackground, dmPrevious:
begin
DrawDestination := FrameBuffer.Canvas;
DrawRect := FrameBuffer.Canvas.ClipRect;
DoStep3 := True;
DoStep5 := True;
end;
end;
end;
// Find source palette
SourcePal := FImage.Images[ActiveImage].Palette;
if (SourcePal = 0) then
SourcePal := SystemPalette16; // This should never happen
SavePal := SelectPalette(DrawDestination.Handle, SourcePal, False);
RealizePalette(DrawDestination.Handle);
// Step 2: Clear previous frame
if (DoStep2) then
ClearBackup;
// Step 3: Copy backup buffer to frame buffer
if (DoStep3) then
FrameBuffer.Canvas.CopyRect(FrameBuffer.Canvas.ClipRect,
BackupBuffer.Canvas, BackupBuffer.Canvas.ClipRect);
// Step 4: Draw frame
if (DrawDestination <> nil) then
FImage.Images[ActiveImage].Draw(DrawDestination, DrawRect,
(goTransparent in FDrawOptions), (goTile in FDrawOptions));
// Step 5: Copy buffer to destination
if (DoStep5) then
begin
FCanvas.CopyMode := cmSrcCopy;
FCanvas.CopyRect(FRect, DrawDestination, DrawRect);
end;
if (SavePal <> 0) then
SelectPalette(DrawDestination.Handle, SavePal, False);
// Step 6: Clear frame from backup buffer
if (DoStep6) then
ClearBackup;
FStarted := True;
end;
// Prefetch bitmap
// Used to force the GIF image to be rendered as a bitmap
{$ifdef SERIALIZE_RENDER}
procedure TGIFPainter.PrefetchBitmap;
begin
// Touch current bitmap to force bitmap to be rendered
if not((FImage.Images[ActiveImage].Empty) or (FImage.Images[ActiveImage].HasBitmap)) then
FImage.Images[ActiveImage].Bitmap;
end;
{$endif}
// Main thread execution loop - This is where it all happens...
procedure TGIFPainter.Execute;
var
i : integer;
LoopCount ,
LoopPoint : integer;
Looping : boolean;
Ext : TGIFExtension;
Msg : TMsg;
Delay ,
OldDelay ,
DelayUsed : longInt;
DelayStart ,
NewDelayStart : DWORD;
procedure FireEvent(Event: TNotifyEvent);
begin
if not(Assigned(Event)) then
exit;
FEvent := Event;
try
DoSynchronize(DoEvent);
finally
FEvent := nil;
end;
end;
begin
{
Disposal:
dmNone: Same as dmNodisposal
dmNoDisposal: Do not dispose
dmBackground: Clear with background color *)
dmPrevious: Previous image
*) Note: Background color should either be a BROWSER SPECIFIED Background
color (DrawBackgroundColor) or the background image if any frames are
transparent.
}
try
try
if (goValidateCanvas in FDrawOptions) then
ValidateDC := FCanvas.Handle;
DoRestart := True;
// Loop to restart paint
while (DoRestart) and not(Terminated) do
begin
FActiveImage := 0;
// Fire OnStartPaint event
// Note: ActiveImage may be altered by the event handler
FireEvent(FOnStartPaint);
FStarted := False;
DoRestart := False;
LoopCount := 1;
LoopPoint := FActiveImage;
Looping := False;
if (goAsync in DrawOptions) then
Delay := 0
else
Delay := 1; // Dummy to process messages
OldDisposal := dmNoDisposal;
// Fetch delay start time
DelayStart := timeGetTime;
OldDelay := 0;
// Loop to loop - duh!
while ((LoopCount <> 0) or (goLoopContinously in DrawOptions)) and
not(Terminated or DoRestart) do
begin
FActiveImage := LoopPoint;
// Fire OnLoopPaint event
// Note: ActiveImage may be altered by the event handler
if (FStarted) then
FireEvent(FOnLoop);
// Loop to animate
while (ActiveImage < FImage.Images.Count) and not(Terminated or DoRestart) do
begin
// Ignore empty images
if (FImage.Images[ActiveImage].Empty) then
break;
// Delay from previous image
if (Delay > 0) then
begin
// Prefetch frame bitmap
{$ifdef SERIALIZE_RENDER}
DoSynchronize(PrefetchBitmap);
{$else}
FImage.Images[ActiveImage].Bitmap;
{$endif}
// Calculate inter frame delay
NewDelayStart := timeGetTime;
if (FAnimationSpeed > 0) then
begin
// Calculate number of mS used in prefetch and display
try
DelayUsed := integer(NewDelayStart-DelayStart)-OldDelay;
// Prevent feedback oscillations caused by over/undercompensation.
DelayUsed := DelayUsed DIV 2;
// Convert delay value to mS and...
// ...Adjust for time already spent converting GIF to bitmap and...
// ...Adjust for Animation Speed factor.
Delay := MulDiv(Delay * GIFDelayExp - DelayUsed, 100, FAnimationSpeed);
OldDelay := Delay;
except
Delay := GIFMaximumDelay * GIFDelayExp;
OldDelay := 0;
end;
end else
begin
if (goAsync in DrawOptions) then
Delay := longInt(INFINITE)
else
Delay := GIFMaximumDelay * GIFDelayExp;
end;
// Fetch delay start time
DelayStart := NewDelayStart;
// Sleep in one chunk if we are running in a thread
if (goAsync in DrawOptions) then
begin
// Use of WaitForSingleObject allows TGIFPainter.Stop to wake us up
if (Delay > 0) or (FAnimationSpeed = 0) then
begin
if (WaitForSingleObject(FEventHandle, DWORD(Delay)) <> WAIT_TIMEOUT) then
begin
// Don't use interframe delay feedback adjustment if delay
// were prematurely aborted (e.g. because the animation
// speed were changed)
OldDelay := 0;
DelayStart := longInt(timeGetTime);
end;
end;
end else
begin
if (Delay <= 0) then
Delay := 1;
// Fetch start time
NewDelayStart := timeGetTime;
// If we are not running in a thread we Sleep in small chunks
// and give the user a chance to abort
while (Delay > 0) and not(Terminated or DoRestart) do
begin
if (Delay < 100) then
Sleep(Delay)
else
Sleep(100);
// Calculate number of mS delayed in this chunk
DelayUsed := integer(timeGetTime - NewDelayStart);
dec(Delay, DelayUsed);
// Reset start time for chunk
NewDelaySTart := timeGetTime;
// Application.ProcessMessages wannabe
while (not(Terminated or DoRestart)) and
(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) do
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
// Put WM_QUIT back in queue and get out of here fast
PostQuitMessage(Msg.WParam);
Terminate;
end;
end;
end;
end;
end else
Sleep(0); // Yield
if (Terminated) then
break;
// Fire OnPaint event
// Note: ActiveImage may be altered by the event handler
FireEvent(FOnPaint);
if (Terminated) then
break;
// Pre-draw processing of extensions
Disposal := dmNoDisposal;
for i := 0 to FImage.Images[ActiveImage].Extensions.Count-1 do
begin
Ext := FImage.Images[ActiveImage].Extensions[i];
if (Ext is TGIFAppExtNSLoop) then
begin
// Recursive loops not supported (or defined)
if (Looping) then
continue;
Looping := True;
LoopCount := TGIFAppExtNSLoop(Ext).Loops;
if ((LoopCount = 0) or (goLoopContinously in DrawOptions)) and
(goAsync in DrawOptions) then
LoopCount := -1; // Infinite if running in separate thread
{$IFNDEF STRICT_MOZILLA}
// Loop from this image and on
// Note: This is not standard behavior
LoopPoint := ActiveImage;
{$ENDIF}
end else
if (Ext is TGIFGraphicControlExtension) then
Disposal := TGIFGraphicControlExtension(Ext).Disposal;
end;
// Paint the image
if (BackupBuffer <> nil) then
DoSynchronize(DoPaintFrame)
else
DoSynchronize(DoPaint);
OldDisposal := Disposal;
if (Terminated) then
break;
Delay := GIFDefaultDelay; // Default delay
// Post-draw processing of extensions
if (FImage.Images[ActiveImage].GraphicControlExtension <> nil) then
if (FImage.Images[ActiveImage].GraphicControlExtension.Delay > 0) then
begin
Delay := FImage.Images[ActiveImage].GraphicControlExtension.Delay;
// Enforce minimum animation delay in compliance with Mozilla
if (Delay < GIFMinimumDelay) then
Delay := GIFMinimumDelay;
// Do not delay more than 10 seconds if running in main thread
if (Delay > GIFMaximumDelay) and not(goAsync in DrawOptions) then
Delay := GIFMaximumDelay; // Max 10 seconds
end;
// Fire OnAfterPaint event
// Note: ActiveImage may be altered by the event handler
i := FActiveImage;
FireEvent(FOnAfterPaint);
if (Terminated) then
break;
// Don't increment frame counter if event handler modified
// current frame
if (FActiveImage = i) then
Inc(FActiveImage);
// Nothing more to do unless we are animating
if not(goAnimate in DrawOptions) then
break;
end;
if (LoopCount > 0) then
Dec(LoopCount);
if ([goAnimate, goLoop] * DrawOptions <> [goAnimate, goLoop]) then
break;
end;
end;
FActiveImage := -1;
// Fire OnEndPaint event
FireEvent(FOnEndPaint);
finally
// If we are running in the main thread we will have to zap our self
if not(goAsync in DrawOptions) then
Free;
end;
except
on E: Exception do
begin
// Eat exception and terminate thread...
// If we allow the exception to abort the thread at this point, the
// application will hang since the thread destructor will never be called
// and the application will wait forever for the thread to die!
Terminate;
// Clone exception
ExceptObject := E.Create(E.Message);
ExceptAddress := ExceptAddr;
end;
end;
end;
procedure TGIFPainter.Start;
begin
if (goAsync in FDrawOptions) then
Resume;
end;
procedure TGIFPainter.Stop;
begin
Terminate;
if (goAsync in FDrawOptions) then
begin
// Signal WaitForSingleObject delay to abort
if (FEventHandle <> 0) then
SetEvent(FEventHandle);
Priority := tpNormal;
if (Suspended) then
Resume; // Must be running before we can terminate
end;
end;
procedure TGIFPainter.Restart;
begin
DoRestart := True;
if (Suspended) and (goAsync in FDrawOptions) then
Resume; // Must be running before we can terminate
end;
////////////////////////////////////////////////////////////////////////////////
//
// TColorMapOptimizer
//
////////////////////////////////////////////////////////////////////////////////
// Used by TGIFImage to optimize local color maps to a single global color map.
// The following algorithm is used:
// 1) Build a histogram for each image
// 2) Merge histograms
// 3) Sum equal colors and adjust max # of colors
// 4) Map entries > max to entries <= 256
// 5) Build new color map
// 6) Map images to new color map
////////////////////////////////////////////////////////////////////////////////
type
POptimizeEntry = ^TOptimizeEntry;
TColorRec = record
case byte of
0: (Value: integer);
1: (Color: TGIFColor);
2: (SameAs: POptimizeEntry); // Used if TOptimizeEntry.Count = 0
end;
TOptimizeEntry = record
Count : integer; // Usage count
OldIndex : integer; // Color OldIndex
NewIndex : integer; // NewIndex color OldIndex
Color : TColorRec; // Color value
end;
TOptimizeEntries = array[0..255] of TOptimizeEntry;
POptimizeEntries = ^TOptimizeEntries;
THistogram = class(TObject)
private
PHistogram : POptimizeEntries;
FCount : integer;
FColorMap : TGIFColorMap;
FList : TList;
FImages : TList;
public
constructor Create(AColorMap: TGIFColorMap);
destructor Destroy; override;
function ProcessSubImage(Image: TGIFSubImage): boolean;
function Prune: integer;
procedure MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
property Count: integer read FCount;
property ColorMap: TGIFColorMap read FColorMap;
property List: TList read FList;
end;
TColorMapOptimizer = class(TObject)
private
FImage : TGIFImage;
FHistogramList : TList;
FHistogram : TList;
FColorMap : TColorMap;
FFinalCount : integer;
FUseTransparency : boolean;
FNewTransparentColorIndex: byte;
protected
procedure ProcessImage;
procedure MergeColors;
procedure MapColors;
procedure ReplaceColorMaps;
public
constructor Create(AImage: TGIFImage);
destructor Destroy; override;
procedure Optimize;
end;
function CompareColor(Item1, Item2: Pointer): integer;
begin
Result := POptimizeEntry(Item2)^.Color.Value - POptimizeEntry(Item1)^.Color.Value;
end;
function CompareCount(Item1, Item2: Pointer): integer;
begin
Result := POptimizeEntry(Item2)^.Count - POptimizeEntry(Item1)^.Count;
end;
constructor THistogram.Create(AColorMap: TGIFColorMap);
var
i : integer;
begin
inherited Create;
FCount := AColorMap.Count;
FColorMap := AColorMap;
FImages := TList.Create;
// Allocate memory for histogram
GetMem(PHistogram, FCount * sizeof(TOptimizeEntry));
FList := TList.Create;
FList.Capacity := FCount;
// Move data to histogram and initialize
for i := 0 to FCount-1 do
with PHistogram^[i] do
begin
FList.Add(@PHistogram^[i]);
OldIndex := i;
Count := 0;
Color.Value := 0;
Color.Color := AColorMap.Data^[i];
NewIndex := 256; // Used to signal unmapped
end;
end;
destructor THistogram.Destroy;
begin
FImages.Free;
FList.Free;
FreeMem(PHistogram);
inherited Destroy;
end;
//: Build a color histogram
function THistogram.ProcessSubImage(Image: TGIFSubImage): boolean;
var
Size : integer;
Pixel : PChar;
IsTransparent ,
WasTransparent : boolean;
OldTransparentColorIndex: byte;
begin
Result := False;
if (Image.Empty) then
exit;
FImages.Add(Image);
Pixel := Image.data;
Size := Image.Width * Image.Height;
IsTransparent := Image.Transparent;
if (IsTransparent) then
OldTransparentColorIndex := Image.GraphicControlExtension.TransparentColorIndex
else
OldTransparentColorIndex := 0; // To avoid compiler warning
WasTransparent := False;
(*
** Sum up usage count for each color
*)
while (Size > 0) do
begin
// Ignore transparent pixels
if (not IsTransparent) or (ord(Pixel^) <> OldTransparentColorIndex) then
begin
// Check for invalid color index
if (ord(Pixel^) >= FCount) then
begin
Pixel^ := #0; // ***FIXME*** Isn't this an error condition?
Image.Warning(gsWarning, sInvalidColor);
end;
with PHistogram^[ord(Pixel^)] do
begin
// Stop if any color reaches the max count
if (Count = high(integer)) then
break;
inc(Count);
end;
end else
WasTransparent := WasTransparent or IsTransparent;
inc(Pixel);
dec(Size);
end;
(*
** Clear frames transparency flag if the frame claimed to
** be transparent, but wasn't
*)
if (IsTransparent and not WasTransparent) then
begin
Image.GraphicControlExtension.TransparentColorIndex := 0;
Image.GraphicControlExtension.Transparent := False;
end;
Result := WasTransparent;
end;
//: Removed unused color entries from the histogram
function THistogram.Prune: integer;
var
i, j : integer;
begin
(*
** Sort by usage count
*)
FList.Sort(CompareCount);
(*
** Determine number of used colors
*)
for i := 0 to FCount-1 do
// Find first unused color entry
if (POptimizeEntry(FList[i])^.Count = 0) then
begin
// Zap unused colors
for j := i to FCount-1 do
POptimizeEntry(FList[j])^.Count := -1; // Use -1 to signal unused entry
// Remove unused entries
FCount := i;
FList.Count := FCount;
break;
end;
Result := FCount;
end;
//: Convert images from old color map to new color map
procedure THistogram.MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
var
i : integer;
Size : integer;
Pixel : PChar;
ReverseMap : array[byte] of byte;
IsTransparent : boolean;
OldTransparentColorIndex: byte;
begin
(*
** Build NewIndex map
*)
for i := 0 to List.Count-1 do
ReverseMap[POptimizeEntry(List[i])^.OldIndex] := POptimizeEntry(List[i])^.NewIndex;
(*
** Reorder all images using this color map
*)
for i := 0 to FImages.Count-1 do
with TGIFSubImage(FImages[i]) do
begin
Pixel := Data;
Size := Width * Height;
// Determine frame transparency
IsTransparent := (Transparent) and (UseTransparency);
if (IsTransparent) then
begin
OldTransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
// Map transparent color
GraphicControlExtension.TransparentColorIndex := NewTransparentColorIndex;
end else
OldTransparentColorIndex := 0; // To avoid compiler warning
// Map all pixels to new color map
while (Size > 0) do
begin
// Map transparent pixels to the new transparent color index and...
if (IsTransparent) and (ord(Pixel^) = OldTransparentColorIndex) then
Pixel^ := char(NewTransparentColorIndex)
else
// ... all other pixels to their new color index
Pixel^ := char(ReverseMap[ord(Pixel^)]);
dec(size);
inc(Pixel);
end;
end;
end;
constructor TColorMapOptimizer.Create(AImage: TGIFImage);
begin
inherited Create;
FImage := AImage;
FHistogramList := TList.Create;
FHistogram := TList.Create;
end;
destructor TColorMapOptimizer.Destroy;
var
i : integer;
begin
FHistogram.Free;
for i := FHistogramList.Count-1 downto 0 do
THistogram(FHistogramList[i]).Free;
FHistogramList.Free;
inherited Destroy;
end;
procedure TColorMapOptimizer.ProcessImage;
var
Hist : THistogram;
i : integer;
ProcessedImage : boolean;
begin
FUseTransparency := False;
(*
** First process images using global color map
*)
if (FImage.GlobalColorMap.Count > 0) then
begin
Hist := THistogram.Create(FImage.GlobalColorMap);
ProcessedImage := False;
// Process all images that are using the global color map
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap.Count = 0) and (not FImage.Images[i].Empty) then
begin
ProcessedImage := True;
// Note: Do not change order of statements. Shortcircuit evaluation not desired!
FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
end;
// Keep the histogram if any images used the global color map...
if (ProcessedImage) then
FHistogramList.Add(Hist)
else // ... otherwise delete it
Hist.Free;
end;
(*
** Next process images that have a local color map
*)
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap.Count > 0) and (not FImage.Images[i].Empty) then
begin
Hist := THistogram.Create(FImage.Images[i].ColorMap);
FHistogramList.Add(Hist);
// Note: Do not change order of statements. Shortcircuit evaluation not desired!
FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
end;
end;
procedure TColorMapOptimizer.MergeColors;
var
Entry, SameEntry : POptimizeEntry;
i : integer;
begin
(*
** Sort by color value
*)
FHistogram.Sort(CompareColor);
(*
** Merge same colors
*)
SameEntry := POptimizeEntry(FHistogram[0]);
for i := 1 to FHistogram.Count-1 do
begin
Entry := POptimizeEntry(FHistogram[i]);
ASSERT(Entry^.Count > 0, 'Unused entry exported from THistogram');
if (Entry^.Color.Value = SameEntry^.Color.Value) then
begin
// Transfer usage count to first entry
inc(SameEntry^.Count, Entry^.Count);
Entry^.Count := 0; // Use 0 to signal merged entry
Entry^.Color.SameAs := SameEntry; // Point to master
end else
SameEntry := Entry;
end;
end;
procedure TColorMapOptimizer.MapColors;
var
i, j : integer;
Delta, BestDelta : integer;
BestIndex : integer;
MaxColors : integer;
begin
(*
** Sort by usage count
*)
FHistogram.Sort(CompareCount);
(*
** Handle transparency
*)
if (FUseTransparency) then
MaxColors := 255
else
MaxColors := 256;
(*
** Determine number of colors used (max 256)
*)
FFinalCount := FHistogram.Count;
for i := 0 to FFinalCount-1 do
if (i >= MaxColors) or (POptimizeEntry(FHistogram[i])^.Count = 0) then
begin
FFinalCount := i;
break;
end;
(*
** Build color map and reverse map for final entries
*)
for i := 0 to FFinalCount-1 do
begin
POptimizeEntry(FHistogram[i])^.NewIndex := i;
FColorMap[i] := POptimizeEntry(FHistogram[i])^.Color.Color;
end;
(*
** Map colors > 256 to colors <= 256 and build NewIndex color map
*)
for i := FFinalCount to FHistogram.Count-1 do
with POptimizeEntry(FHistogram[i])^ do
begin
// Entries with a usage count of -1 is unused
ASSERT(Count <> -1, 'Internal error: Unused entry exported');
// Entries with a usage count of 0 has been merged with another entry
if (Count = 0) then
begin
// Use mapping of master entry
ASSERT(Color.SameAs.NewIndex < 256, 'Internal error: Mapping to unmapped color');
NewIndex := Color.SameAs.NewIndex;
end else
begin
// Search for entry with nearest color value
BestIndex := 0;
BestDelta := 255*3;
for j := 0 to FFinalCount-1 do
begin
Delta := ABS((POptimizeEntry(FHistogram[j])^.Color.Color.Red - Color.Color.Red) +
(POptimizeEntry(FHistogram[j])^.Color.Color.Green - Color.Color.Green) +
(POptimizeEntry(FHistogram[j])^.Color.Color.Blue - Color.Color.Blue));
if (Delta < BestDelta) then
begin
BestDelta := Delta;
BestIndex := j;
end;
end;
NewIndex := POptimizeEntry(FHistogram[BestIndex])^.NewIndex;;
end;
end;
(*
** Add transparency color to new color map
*)
if (FUseTransparency) then
begin
FNewTransparentColorIndex := FFinalCount;
FColorMap[FFinalCount].Red := 0;
FColorMap[FFinalCount].Green := 0;
FColorMap[FFinalCount].Blue := 0;
inc(FFinalCount);
end;
end;
procedure TColorMapOptimizer.ReplaceColorMaps;
var
i : integer;
begin
// Zap all local color maps
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap <> nil) then
FImage.Images[i].ColorMap.Clear;
// Store optimized global color map
FImage.GlobalColorMap.ImportColorMap(FColorMap, FFinalCount);
FImage.GlobalColorMap.Optimized := True;
end;
procedure TColorMapOptimizer.Optimize;
var
Total : integer;
i, j : integer;
begin
// Stop all painters during optimize...
FImage.PaintStop;
// ...and prevent any new from starting while we are doing our thing
FImage.Painters.LockList;
try
(*
** Process all sub images
*)
ProcessImage;
// Prune histograms and calculate total number of colors
Total := 0;
for i := 0 to FHistogramList.Count-1 do
inc(Total, THistogram(FHistogramList[i]).Prune);
// Allocate global histogram
FHistogram.Clear;
FHistogram.Capacity := Total;
// Move data pointers from local histograms to global histogram
for i := 0 to FHistogramList.Count-1 do
with THistogram(FHistogramList[i]) do
for j := 0 to Count-1 do
begin
ASSERT(POptimizeEntry(List[j])^.Count > 0, 'Unused entry exported from THistogram');
FHistogram.Add(List[j]);
end;
(*
** Merge same colors
*)
MergeColors;
(*
** Build color map and NewIndex map for final entries
*)
MapColors;
(*
** Replace local colormaps with global color map
*)
ReplaceColorMaps;
(*
** Process images for each color map
*)
for i := 0 to FHistogramList.Count-1 do
THistogram(FHistogramList[i]).MapImages(FUseTransparency, FNewTransparentColorIndex);
(*
** Delete the frame's old bitmaps and palettes
*)
for i := 0 to FImage.Images.Count-1 do
begin
FImage.Images[i].HasBitmap := False;
FImage.Images[i].Palette := 0;
end;
finally
FImage.Painters.UnlockList;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFImage.Create;
begin
inherited Create;
FImages := TGIFImageList.Create(self);
FHeader := TGIFHeader.Create(self);
FPainters := TThreadList.Create;
FGlobalPalette := 0;
// Load defaults
FDrawOptions := GIFImageDefaultDrawOptions;
ColorReduction := GIFImageDefaultColorReduction;
FReductionBits := GIFImageDefaultColorReductionBits;
FDitherMode := GIFImageDefaultDitherMode;
FCompression := GIFImageDefaultCompression;
FThreadPriority := GIFImageDefaultThreadPriority;
FAnimationSpeed := GIFImageDefaultAnimationSpeed;
FDrawBackgroundColor := clNone;
IsDrawing := False;
IsInsideGetPalette := False;
NewImage;
end;
destructor TGIFImage.Destroy;
var
i : integer;
begin
PaintStop;
with FPainters.LockList do
try
for i := Count-1 downto 0 do
TGIFPainter(Items[i]).FImage := nil;
finally
FPainters.UnLockList;
end;
Clear;
FPainters.Free;
FImages.Free;
FHeader.Free;
inherited Destroy;
end;
procedure TGIFImage.Clear;
begin
PaintStop;
FreeBitmap;
FImages.Clear;
FHeader.ColorMap.Clear;
FHeader.Height := 0;
FHeader.Width := 0;
FHeader.Prepare;
Palette := 0;
end;
procedure TGIFImage.NewImage;
begin
Clear;
end;
function TGIFImage.GetVersion: TGIFVersion;
var
v : TGIFVersion;
i : integer;
begin
Result := gvUnknown;
for i := 0 to FImages.Count-1 do
begin
v := FImages[i].Version;
if (v > Result) then
Result := v;
if (v >= high(TGIFVersion)) then
break;
end;
end;
function TGIFImage.GetColorResolution: integer;
var
i : integer;
begin
Result := FHeader.ColorResolution;
for i := 0 to FImages.Count-1 do
if (FImages[i].ColorResolution > Result) then
Result := FImages[i].ColorResolution;
end;
function TGIFImage.GetBitsPerPixel: integer;
var
i : integer;
begin
Result := FHeader.BitsPerPixel;
for i := 0 to FImages.Count-1 do
if (FImages[i].BitsPerPixel > Result) then
Result := FImages[i].BitsPerPixel;
end;
function TGIFImage.GetBackgroundColorIndex: BYTE;
begin
Result := FHeader.BackgroundColorIndex;
end;
procedure TGIFImage.SetBackgroundColorIndex(const Value: BYTE);
begin
FHeader.BackgroundColorIndex := Value;
end;
function TGIFImage.GetBackgroundColor: TColor;
begin
Result := FHeader.BackgroundColor;
end;
procedure TGIFImage.SetBackgroundColor(const Value: TColor);
begin
FHeader.BackgroundColor := Value;
end;
function TGIFImage.GetAspectRatio: BYTE;
begin
Result := FHeader.AspectRatio;
end;
procedure TGIFImage.SetAspectRatio(const Value: BYTE);
begin
FHeader.AspectRatio := Value;
end;
procedure TGIFImage.SetDrawOptions(Value: TGIFDrawOptions);
begin
if (FDrawOptions = Value) then
exit;
if (DrawPainter <> nil) then
DrawPainter.Stop;
FDrawOptions := Value;
// Zap all bitmaps
Pack;
Changed(self);
end;
function TGIFImage.GetAnimate: Boolean;
begin
Result:= goAnimate in DrawOptions;
end;
procedure TGIFImage.SetAnimate(const Value: Boolean);
begin
if Value then
DrawOptions:= DrawOptions + [goAnimate]
else
DrawOptions:= DrawOptions - [goAnimate];
end;
procedure TGIFImage.SetAnimationSpeed(Value: integer);
begin
if (Value < 0) then
Value := 0
else if (Value > 1000) then
Value := 1000;
if (Value <> FAnimationSpeed) then
begin
FAnimationSpeed := Value;
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
if (FDrawPainter <> nil) then
FDrawPainter.AnimationSpeed := FAnimationSpeed;
finally
// Release the lock on FPainters to let paint thread kill itself
FPainters.UnLockList;
end;
end;
end;
procedure TGIFImage.SetReductionBits(Value: integer);
begin
if (Value < 3) or (Value > 8) then
Error(sInvalidBitSize);
FReductionBits := Value;
end;
procedure TGIFImage.OptimizeColorMap;
var
ColorMapOptimizer : TColorMapOptimizer;
begin
ColorMapOptimizer := TColorMapOptimizer.Create(self);
try
ColorMapOptimizer.Optimize;
finally
ColorMapOptimizer.Free;
end;
end;
procedure TGIFImage.Optimize(Options: TGIFOptimizeOptions;
ColorReduction: TColorReduction; DitherMode: TDitherMode;
ReductionBits: integer);
var
i ,
j : integer;
Delay : integer;
GCE : TGIFGraphicControlExtension;
ThisRect ,
NextRect ,
MergeRect : TRect;
Prog ,
MaxProg : integer;
function Scan(Buf: PChar; Value: Byte; Count: integer): boolean; assembler;
asm
PUSH EDI
MOV EDI, Buf
MOV ECX, Count
MOV AL, Value
REPNE SCASB
MOV EAX, False
JNE @@1
MOV EAX, True
@@1:POP EDI
end;
begin
if (Empty) then
exit;
// Stop all painters during optimize...
PaintStop;
// ...and prevent any new from starting while we are doing our thing
FPainters.LockList;
try
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressOptimizing);
try
Prog := 0;
MaxProg := Images.Count*6;
// Sort color map by usage and remove unused entries
if (ooColorMap in Options) then
begin
// Optimize global color map
if (GlobalColorMap.Count > 0) then
GlobalColorMap.Optimize;
// Optimize local color maps
for i := 0 to Images.Count-1 do
begin
inc(Prog);
if (Images[i].ColorMap.Count > 0) then
begin
Images[i].ColorMap.Optimize;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end;
// Remove passive elements, pass 1
if (ooCleanup in Options) then
begin
// Check for transparency flag without any transparent pixels
for i := 0 to Images.Count-1 do
begin
inc(Prog);
if (Images[i].Transparent) then
begin
if not(Scan(Images[i].Data,
Images[i].GraphicControlExtension.TransparentColorIndex,
Images[i].DataSize)) then
begin
Images[i].GraphicControlExtension.Transparent := False;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end;
// Change redundant disposal modes
for i := 0 to Images.Count-2 do
begin
inc(Prog);
if (Images[i].GraphicControlExtension <> nil) and
(Images[i].GraphicControlExtension.Disposal in [dmPrevious, dmBackground]) and
(not Images[i+1].Transparent) then
begin
ThisRect := Images[i].BoundsRect;
NextRect := Images[i+1].BoundsRect;
if (not IntersectRect(MergeRect, ThisRect, NextRect)) then
continue;
// If the next frame completely covers the current frame,
// change the disposal mode to dmNone
if (EqualRect(MergeRect, NextRect)) then
Images[i].GraphicControlExtension.Disposal := dmNone;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end else
inc(Prog, 2*Images.Count);
// Merge layers of equal pixels (remove redundant pixels)
if (ooMerge in Options) then
begin
// Merge from last to first to avoid intefering with merge
for i := Images.Count-1 downto 1 do
begin
inc(Prog);
j := i-1;
// If the "previous" frames uses dmPrevious disposal mode, we must
// instead merge with the frame before the previous
while (j > 0) and
((Images[j].GraphicControlExtension <> nil) and
(Images[j].GraphicControlExtension.Disposal = dmPrevious)) do
dec(j);
// Merge
Images[i].Merge(Images[j]);
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end else
inc(Prog, Images.Count);
// Crop transparent areas
if (ooCrop in Options) then
begin
for i := Images.Count-1 downto 0 do
begin
inc(Prog);
if (not Images[i].Empty) and (Images[i].Transparent) then
begin
// Remember frames delay in case frame is deleted
Delay := Images[i].GraphicControlExtension.Delay;
// Crop
Images[i].Crop;
// If the frame was completely transparent we remove it
if (Images[i].Empty) then
begin
// Transfer delay to previous frame in case frame was deleted
if (i > 0) and (Images[i-1].Transparent) then
Images[i-1].GraphicControlExtension.Delay :=
Images[i-1].GraphicControlExtension.Delay + Delay;
Images.Delete(i);
end;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end else
inc(Prog, Images.Count);
// Remove passive elements, pass 2
inc(Prog, Images.Count);
if (ooCleanup in Options) then
begin
for i := Images.Count-1 downto 0 do
begin
// Remove comments and application extensions
for j := Images[i].Extensions.Count-1 downto 0 do
if (Images[i].Extensions[j] is TGIFCommentExtension) or
(Images[i].Extensions[j] is TGIFTextExtension) or
(Images[i].Extensions[j] is TGIFUnknownAppExtension) or
((Images[i].Extensions[j] is TGIFAppExtNSLoop) and
((i > 0) or (Images.Count = 1))) then
Images[i].Extensions.Delete(j);
if (Images[i].GraphicControlExtension <> nil) then
begin
GCE := Images[i].GraphicControlExtension;
// Zap GCE if all of the following are true:
// * No delay or only one image
// * Not transparent
// * No prompt
// * No disposal or only one image
if ((GCE.Delay = 0) or (Images.Count = 1)) and
(not GCE.Transparent) and
(not GCE.UserInput) and
((GCE.Disposal in [dmNone, dmNoDisposal]) or (Images.Count = 1)) then
begin
GCE.Free;
end;
end;
// Zap frame if it has become empty
if (Images[i].Empty) and (Images[i].Extensions.Count = 0) then
Images[i].Free;
end;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end else
// Reduce color depth
if (ooReduceColors in Options) then
begin
if (ColorReduction = rmPalette) then
Error(sInvalidReduction);
{ TODO -oanme -cFeature : Implement ooReduceColors option. }
// Not implemented!
end;
finally
if ExceptObject = nil then
i := 100
else
i := 0;
Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressOptimizing);
end;
finally
FPainters.UnlockList;
end;
end;
procedure TGIFImage.Pack;
var
i : integer;
begin
// Zap bitmaps and palettes
FreeBitmap;
Palette := 0;
for i := 0 to FImages.Count-1 do
begin
FImages[i].Bitmap := nil;
FImages[i].Palette := 0;
end;
// Only pack if no global colormap and a single image
if (FHeader.ColorMap.Count > 0) or (FImages.Count <> 1) then
exit;
// Copy local colormap to global
FHeader.ColorMap.Assign(FImages[0].ColorMap);
// Zap local colormap
FImages[0].ColorMap.Clear;
end;
procedure TGIFImage.SaveToStream(Stream: TStream);
var
n : Integer;
begin
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressSaving);
try
// Write header
FHeader.SaveToStream(Stream);
// Write images
FImages.SaveToStream(Stream);
// Write trailer
with TGIFTrailer.Create(self) do
try
SaveToStream(Stream);
finally
Free;
end;
finally
if ExceptObject = nil then
n := 100
else
n := 0;
Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressSaving);
end;
end;
procedure TGIFImage.LoadFromStream(Stream: TStream);
var
n : Integer;
Position : integer;
begin
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressLoading);
try
// Zap old image
Clear;
Position := Stream.Position;
try
// Read header
FHeader.LoadFromStream(Stream);
// Read images
FImages.LoadFromStream(Stream, self);
// Read trailer
with TGIFTrailer.Create(self) do
try
LoadFromStream(Stream);
finally
Free;
end;
except
// Restore stream position in case of error.
// Not required, but "a nice thing to do"
Stream.Position := Position;
raise;
end;
finally
if ExceptObject = nil then
n := 100
else
n := 0;
Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressLoading);
end;
end;
procedure TGIFImage.LoadFromResourceName(Instance: THandle; const ResName: String);
var
Stream: TCustomMemoryStream;
begin
Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
function TGIFImage.GetBitmap: TBitmap;
begin
if not(Empty) then
begin
Result := FBitmap;
if (Result <> nil) then
exit;
FBitmap := TBitmap.Create;
Result := FBitmap;
FBitmap.OnChange := Changed;
// Use first image as default
if (Images.Count > 0) then
begin
if (Images[0].Width = Width) and (Images[0].Height = Height) then
begin
// Use first image as it has same dimensions
FBitmap.Assign(Images[0].Bitmap);
end else
begin
// Draw first image on bitmap
FBitmap.Palette := CopyPalette(Palette);
FBitmap.Height := Height;
FBitmap.Width := Width;
Images[0].Draw(FBitmap.Canvas, FBitmap.Canvas.ClipRect, False, False);
end;
end;
end else
Result := nil
end;
// Create a new (empty) bitmap
function TGIFImage.NewBitmap: TBitmap;
begin
Result := FBitmap;
if (Result <> nil) then
exit;
FBitmap := TBitmap.Create;
Result := FBitmap;
FBitmap.OnChange := Changed;
// Draw first image on bitmap
FBitmap.Palette := CopyPalette(Palette);
FBitmap.Height := Height;
FBitmap.Width := Width;
end;
procedure TGIFImage.FreeBitmap;
begin
if (DrawPainter <> nil) then
DrawPainter.Stop;
if (FBitmap <> nil) then
begin
FBitmap.Free;
FBitmap := nil;
end;
end;
function TGIFImage.Add(Source: TPersistent): integer;
var
Image : TGIFSubImage;
begin
Image := nil; // To avoid compiler warning - not needed.
if (Source is TGraphic) then
begin
Image := TGIFSubImage.Create(self);
try
Image.Assign(Source);
// ***FIXME*** Documentation should explain the inconsistency here:
// TGIFimage does not take ownership of Source after TGIFImage.Add() and
// therefore does not delete Source.
except
Image.Free;
raise;
end;
end else
if (Source is TGIFSubImage) then
Image := TGIFSubImage(Source)
else
Error(sUnsupportedClass);
Result := FImages.Add(Image);
FreeBitmap;
Changed(self);
end;
function TGIFImage.GetEmpty: Boolean;
begin
Result := (FImages.Count = 0);
end;
function TGIFImage.GetHeight: Integer;
begin
Result := FHeader.Height;
end;
function TGIFImage.GetWidth: Integer;
begin
Result := FHeader.Width;
end;
function TGIFImage.GetIsTransparent: Boolean;
var
i : integer;
begin
Result := False;
for i := 0 to Images.Count-1 do
if (Images[i].GraphicControlExtension <> nil) and
(Images[i].GraphicControlExtension.Transparent) then
begin
Result := True;
exit;
end;
end;
function TGIFImage.Equals(Graphic: TGraphic): Boolean;
begin
Result := (Graphic = self);
end;
function TGIFImage.GetPalette: HPALETTE;
begin
// Check for recursion
// (TGIFImage.GetPalette->TGIFSubImage.GetPalette->TGIFImage.GetPalette etc...)
if (IsInsideGetPalette) then
Error(sNoColorTable);
IsInsideGetPalette := True;
try
Result := 0;
if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
// Use bitmaps own palette if possible
Result := FBitmap.Palette
else if (FGlobalPalette <> 0) then
// Or a previously exported global palette
Result := FGlobalPalette
else if (DoDither) then
begin
// or create a new dither palette
FGlobalPalette := WebPalette;
Result := FGlobalPalette;
end else
if (FHeader.ColorMap.Count > 0) then
begin
// or create a new if first time
FGlobalPalette := FHeader.ColorMap.ExportPalette;
Result := FGlobalPalette;
end else
if (FImages.Count > 0) then
// This can cause a recursion if no global palette exist and image[0]
// hasn't got one either. Checked by the IsInsideGetPalette semaphor.
Result := FImages[0].Palette;
finally
IsInsideGetPalette := False;
end;
end;
procedure TGIFImage.SetPalette(Value: HPalette);
var
NeedNewBitmap : boolean;
begin
if (Value <> FGlobalPalette) then
begin
// Zap old palette
if (FGlobalPalette <> 0) then
DeleteObject(FGlobalPalette);
// Zap bitmap unless new palette is same as bitmaps own
NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);
// Use new palette
FGlobalPalette := Value;
if (NeedNewBitmap) then
begin
// Need to create new bitmap and repaint
FreeBitmap;
PaletteModified := True;
Changed(Self);
end;
end;
end;
// Obsolete
// procedure TGIFImage.Changed(Sender: TObject);
// begin
// inherited Changed(Sender);
// end;
procedure TGIFImage.SetHeight(Value: Integer);
var
i : integer;
begin
for i := 0 to Images.Count-1 do
if (Images[i].Top + Images[i].Height > Value) then
Error(sBadHeight);
if (Value <> Header.Height) then
begin
Header.Height := Value;
FreeBitmap;
Changed(self);
end;
end;
procedure TGIFImage.SetWidth(Value: Integer);
var
i : integer;
begin
for i := 0 to Images.Count-1 do
if (Images[i].Left + Images[i].Width > Value) then
Error(sBadWidth);
if (Value <> Header.Width) then
begin
Header.Width := Value;
FreeBitmap;
Changed(self);
end;
end;
procedure TGIFImage.WriteData(Stream: TStream);
begin
if (GIFImageOptimizeOnStream) then
Optimize([ooCrop, ooMerge, ooCleanup, ooColorMap, ooReduceColors], rmNone, dmNearest, 8);
inherited WriteData(Stream);
end;
procedure TGIFImage.AssignTo(Dest: TPersistent);
begin
if (Dest is TBitmap) then
Dest.Assign(Bitmap)
else
inherited AssignTo(Dest);
end;
{ TODO 1 -oanme -cImprovement : Better handling of TGIFImage.Assign(Empty TBitmap). }
procedure TGIFImage.Assign(Source: TPersistent);
var
i : integer;
Image : TGIFSubImage;
begin
if (Source = self) then
exit;
if (Source = nil) then
begin
Clear;
end else
//
// TGIFImage import
//
if (Source is TGIFImage) then
begin
Clear;
// Temporarily copy event handlers to be able to generate progress events
// during the copy and handle copy errors
OnProgress := TGIFImage(Source).OnProgress;
try
FOnWarning := TGIFImage(Source).OnWarning;
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressCopying);
try
FHeader.Assign(TGIFImage(Source).Header);
FThreadPriority := TGIFImage(Source).ThreadPriority;
FDrawBackgroundColor := TGIFImage(Source).DrawBackgroundColor;
FDrawOptions := TGIFImage(Source).DrawOptions;
FColorReduction := TGIFImage(Source).ColorReduction;
FDitherMode := TGIFImage(Source).DitherMode;
FOnWarning:= TGIFImage(Source).FOnWarning;
FOnStartPaint:= TGIFImage(Source).FOnStartPaint;
FOnPaint:= TGIFImage(Source).FOnPaint;
FOnEndPaint:= TGIFImage(Source).FOnEndPaint;
FOnAfterPaint:= TGIFImage(Source).FOnAfterPaint;
FOnLoop:= TGIFImage(Source).FOnLoop;
for i := 0 to TGIFImage(Source).Images.Count-1 do
begin
Image := TGIFSubImage.Create(self);
Image.Assign(TGIFImage(Source).Images[i]);
Add(Image);
Progress(Self, psRunning, MulDiv((i+1), 100, TGIFImage(Source).Images.Count),
False, Rect(0,0,0,0), sProgressCopying);
end;
finally
if ExceptObject = nil then
i := 100
else
i := 0;
Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressCopying);
end;
finally
// Reset event handlers
FOnWarning := nil;
OnProgress := nil;
end;
end else
//
// Import via TGIFSubImage.Assign
//
begin
Clear;
Image := TGIFSubImage.Create(self);
try
Image.Assign(Source);
Add(Image);
except
on E: EConvertError do
begin
Image.Free;
// Unsupported format - fall back to Source.AssignTo
inherited Assign(Source);
end;
else
// Unknown conversion error
Image.Free;
raise;
end;
end;
end;
procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
Size : Longint;
Buffer : Pointer;
Stream : TMemoryStream;
Bmp : TBitmap;
{$ENDIF}
begin
{$IFDEF REGISTER_TGIFIMAGE}
if (AData = 0) then
AData := GetClipboardData(AFormat);
if (AData <> 0) and (AFormat = CF_GIF) then
begin
// Get size and pointer to data
Size := GlobalSize(AData);
Buffer := GlobalLock(AData);
try
Stream := TMemoryStream.Create;
try
// Copy data to a stream
Stream.SetSize(Size);
Move(Buffer^, Stream.Memory^, Size);
// Load GIF from stream
LoadFromStream(Stream);
finally
Stream.Free;
end;
finally
GlobalUnlock(AData);
end;
end else
if (AData <> 0) and (AFormat = CF_BITMAP) then
begin
// No GIF on clipboard - try loading a bitmap instead
Bmp := TBitmap.Create;
try
Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
Assign(Bmp);
finally
Bmp.Free;
end;
end else
Error(sUnknownClipboardFormat);
{$ELSE}
Error(sGIFToClipboard);
{$ENDIF}
end;
procedure TGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
Stream : TMemoryStream;
Data : THandle;
Buffer : Pointer;
{$ENDIF}
begin
{$IFDEF REGISTER_TGIFIMAGE}
if (Empty) then
exit;
// First store a bitmap version on the clipboard...
Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
// ...then store a GIF
Stream := TMemoryStream.Create;
try
// Save the GIF to a memory stream
SaveToStream(Stream);
Stream.Position := 0;
// Allocate some memory for the GIF data
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
try
if (Data <> 0) then
begin
Buffer := GlobalLock(Data);
try
// Copy GIF data from stream memory to clipboard memory
Move(Stream.Memory^, Buffer^, Stream.Size);
finally
GlobalUnlock(Data);
end;
// Transfer data to clipboard
if (SetClipboardData(CF_GIF, Data) = 0) then
Error(sFailedPaste);
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
{$ELSE}
Error(sGIFToClipboard);
{$ENDIF}
end;
function TGIFImage.GetColorMap: TGIFColorMap;
begin
Result := FHeader.ColorMap;
end;
function TGIFImage.GetDoDither: boolean;
begin
Result := (goDither in DrawOptions) and
(((goAutoDither in DrawOptions) and DoAutoDither) or
not(goAutoDither in DrawOptions));
end;
{$IFDEF VER9x}
procedure TGIFImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if Assigned(FOnProgress) then
FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
{$ENDIF}
procedure TGIFImage.StopDraw;
var
Msg : TMsg;
ThreadWindow : HWND;
begin
repeat
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
if (FDrawPainter = nil) then
break;
// Tell thread to terminate
FDrawPainter.Stop;
// No need to wait for "thread" to terminate if running in main thread
if not(goAsync in FDrawPainter.DrawOptions) then
break;
finally
// Release the lock on FPainters to let paint thread kill itself
FPainters.UnLockList;
end;
{$IFDEF VER14_PLUS}
if (GetCurrentThreadID = MainThreadID) then
while CheckSynchronize do {loop};
{$ELSE}
// Process Messages to make Synchronize work
// (Instead of Application.ProcessMessages)
ThreadWindow := FindWindow('TThreadWindow', nil);
while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
PostQuitMessage(Msg.WParam);
exit;
end;
end;
{$ENDIF}
Sleep(0); // Yield
until (False);
FreeBitmap;
end;
procedure TGIFImage.Draw(ACanvas: TCanvas; const Rect: TRect);
var
Canvas : TCanvas;
DestRect : TRect;
Msg : TMsg;
ThreadWindow : HWND;
procedure DrawTile(Rect: TRect; Bitmap: TBitmap);
var
Tile : TRect;
begin
if (goTile in FDrawOptions) then
begin
// Note: This design does not handle transparency correctly!
Tile.Left := Rect.Left;
Tile.Right := Tile.Left + Width;
while (Tile.Left < Rect.Right) do
begin
Tile.Top := Rect.Top;
Tile.Bottom := Tile.Top + Height;
while (Tile.Top < Rect.Bottom) do
begin
ACanvas.StretchDraw(Tile, Bitmap);
Tile.Top := Tile.Top + Height;
Tile.Bottom := Tile.Top + Height;
end;
Tile.Left := Tile.Left + Width;
Tile.Right := Tile.Left + Width;
end;
end else
ACanvas.StretchDraw(Rect, Bitmap);
end;
begin
// Prevent recursion(s(s(s)))
if (IsDrawing) or (FImages.Count = 0) then
exit;
IsDrawing := True;
try
// Copy bitmap to canvas if we are already drawing
// (or have drawn but are finished)
if (FImages.Count = 1) or // Only one image
(not (goAnimate in FDrawOptions)) then // Don't animate
begin
FImages[0].Draw(ACanvas, Rect, (goTransparent in FDrawOptions),
(goTile in FDrawOptions));
exit;
end else
if (FBitmap <> nil) and not(goDirectDraw in FDrawOptions) then
begin
DrawTile(Rect, Bitmap);
exit;
end;
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
// If we are already painting on the canvas in goDirectDraw mode
// and at the same location, just exit and let the painter do
// its thing when it's ready
if (FDrawPainter <> nil) and (FDrawPainter.Canvas = ACanvas) and
EqualRect(FDrawPainter.Rect, Rect) then
exit;
// Kill the current paint thread
StopDraw;
if not(goDirectDraw in FDrawOptions) then
begin
// Create a bitmap to draw on
NewBitmap;
Canvas := FBitmap.Canvas;
DestRect := Canvas.ClipRect;
// Initialize bitmap canvas with background image
Canvas.CopyRect(DestRect, ACanvas, Rect);
end else
begin
Canvas := ACanvas;
DestRect := Rect;
end;
// Create new paint thread
InternalPaint(@FDrawPainter, Canvas, DestRect, FDrawOptions);
if (FDrawPainter <> nil) then
begin
// Launch thread
FDrawPainter.Start;
if not(goDirectDraw in FDrawOptions) then
begin
{$IFDEF VER14_PLUS}
while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
(not FDrawPainter.Started) do
begin
if not CheckSynchronize then
Sleep(0); // Yield
end;
{$ELSE}
ThreadWindow := FindWindow('TThreadWindow', nil);
// Wait for thread to render first frame
while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
(not FDrawPainter.Started) do
// Process Messages to make Synchronize work
// (Instead of Application.ProcessMessages)
if PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) then
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
PostQuitMessage(Msg.WParam);
exit;
end;
end else
Sleep(0); // Yield
{$ENDIF}
// Draw frame to destination
DrawTile(Rect, Bitmap);
end;
end;
finally
FPainters.UnLockList;
end;
finally
IsDrawing := False;
end;
end;
// Internal pain(t) routine used by Draw()
function TGIFImage.InternalPaint(Painter: PGifPainter; ACanvas: TCanvas;
const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
begin
if (Empty) or (Rect.Left >= Rect.Right) or (Rect.Top >= Rect.Bottom) then
begin
Result := nil;
if (Painter <> nil) then
Painter^ := Result;
exit;
end;
// Draw in main thread if only one image
if (Images.Count = 1) then
Options := Options - [goAsync, goAnimate];
Result := TGIFPainter.CreateRef(Painter, self, ACanvas, Rect, Options);
FPainters.Add(Result);
Result.OnStartPaint := FOnStartPaint;
Result.OnPaint := FOnPaint;
Result.OnAfterPaint := FOnAfterPaint;
Result.OnLoop := FOnLoop;
Result.OnEndPaint := FOnEndPaint;
if not(goAsync in Options) then
begin
// Run in main thread
Result.Execute;
// Note: Painter threads executing in the main thread are freed upon exit
// from the Execute method, so no need to do it here.
Result := nil;
if (Painter <> nil) then
Painter^ := Result;
end else
Result.Priority := FThreadPriority;
end;
function TGIFImage.Paint(ACanvas: TCanvas; const Rect: TRect;
Options: TGIFDrawOptions): TGIFPainter;
begin
Result := InternalPaint(nil, ACanvas, Rect, Options);
if (Result <> nil) then
// Run in separate thread
Result.Start;
end;
procedure TGIFImage.PaintStart;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Start;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintStop;
var
Ghosts : integer;
i : integer;
Msg : TMsg;
ThreadWindow : HWND;
procedure KillThreads;
var
i : integer;
begin
with FPainters.LockList do
try
for i := Count-1 downto 0 do
if (goAsync in TGIFPainter(Items[i]).DrawOptions) then
begin
TerminateThread(TGIFPainter(Items[i]).Handle, 0);
Delete(i);
end;
finally
FPainters.UnLockList;
end;
end;
begin
try
// Loop until all have died
repeat
with FPainters.LockList do
try
if (Count = 0) then
exit;
// Signal painters to terminate
// Painters will attempt to remove them self from the
// painter list when they die
Ghosts := Count;
for i := Ghosts-1 downto 0 do
begin
if not(goAsync in TGIFPainter(Items[i]).DrawOptions) then
dec(Ghosts);
TGIFPainter(Items[i]).Stop;
end;
finally
FPainters.UnLockList;
end;
// If all painters were synchronous, there's no purpose waiting for them
// to terminate, because they are running in the main thread.
if (Ghosts = 0) then
exit;
{$IFDEF VER14_PLUS}
if (GetCurrentThreadID = MainThreadID) then
while CheckSynchronize do {loop};
{$ELSE}
// Process Messages to make TThread.Synchronize work
// (Instead of Application.ProcessMessages)
ThreadWindow := FindWindow('TThreadWindow', nil);
if (ThreadWindow = 0) then
begin
KillThreads;
exit;
end;
while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
KillThreads;
exit;
end;
end;
{$ENDIF}
Sleep(0);
until (False);
finally
FreeBitmap;
end;
end;
procedure TGIFImage.PaintPause;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Suspend;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintResume;
var
i : integer;
begin
// Implementation is currently same as PaintStart, but don't call PaintStart
// in case its implementation changes
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Start;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintRestart;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Restart;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.Warning(Sender: TObject; Severity: TGIFSeverity; Message: string);
begin
if (Assigned(FOnWarning)) then
FOnWarning(Sender, Severity, Message);
end;
{$IFDEF VER12_PLUS}
type
TDummyThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TDummyThread.Execute;
begin
end;
{$ENDIF}
var
DesktopDC: HDC;
{$IFDEF VER12_PLUS}
DummyThread: TThread;
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Initialization
//
////////////////////////////////////////////////////////////////////////////////
initialization
{$IFDEF REGISTER_TGIFIMAGE}
TPicture.RegisterFileFormat('GIF', sGIFImageFile, TGIFImage);
CF_GIF := RegisterClipboardFormat(PChar(sGIFImageFile));
TPicture.RegisterClipboardFormat(CF_GIF, TGIFImage);
{$ENDIF}
DesktopDC := GetDC(0);
try
PaletteDevice := (GetDeviceCaps(DesktopDC, BITSPIXEL) * GetDeviceCaps(DesktopDC, PLANES) <= 8);
DoAutoDither := PaletteDevice;
finally
ReleaseDC(0, DesktopDC);
end;
{$IFDEF VER9x}
// Note: This doesn't return the same palette as the Delphi 3 system palette
// since the true system palette contains 20 entries and the Delphi 3 system
// palette only contains 16.
// For our purpose this doesn't matter since we do not care about the actual
// colors (or their number) in the palette.
// Stock objects doesn't have to be deleted.
SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
{$ENDIF}
{$IFDEF VER12_PLUS}
// Make sure that at least one thread always exist.
// This is done to circumvent a race condition bug in Delphi 4.x and later:
// When threads are deleted and created in rapid succesion, a situation might
// arise where the thread window is deleted *after* the threads it controls
// has been created. See the Delphi Bug Lists for more information.
DummyThread := TDummyThread.Create(True);
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Finalization
//
////////////////////////////////////////////////////////////////////////////////
finalization
ExtensionList.Free;
AppExtensionList.Free;
{$IFNDEF VER9x}
{$IFDEF REGISTER_TGIFIMAGE}
TPicture.UnregisterGraphicClass(TGIFImage);
{$ENDIF}
{$IFDEF VER100}
if (pf8BitBitmap <> nil) then
pf8BitBitmap.Free;
{$ENDIF}
{$ENDIF}
{$IFDEF VER12_PLUS}
if (DummyThread <> nil) then
DummyThread.Free;
{$ENDIF}
end.