You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1291 lines
40 KiB
1291 lines
40 KiB
{
|
|
Vampyre Imaging Library
|
|
by Marek Mauder
|
|
http://imaginglib.sourceforge.net
|
|
|
|
The contents of this file are used with permission, subject to the Mozilla
|
|
Public License Version 1.1 (the "License"); you may not use this file except
|
|
in compliance with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU Lesser General Public License (the "LGPL License"), in which case the
|
|
provisions of the LGPL License are applicable instead of those above.
|
|
If you wish to allow use of your version of this file only under the terms
|
|
of the LGPL License and not to allow others to use your version of this file
|
|
under the MPL, indicate your decision by deleting the provisions above and
|
|
replace them with the notice and other provisions required by the LGPL
|
|
License. If you do not delete the provisions above, a recipient may use
|
|
your version of this file under either the MPL or the LGPL License.
|
|
|
|
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
|
|
}
|
|
|
|
{ This unit contains image format loader/saver for GIF images.}
|
|
unit ImagingGif;
|
|
|
|
{$I ImagingOptions.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
|
|
|
|
type
|
|
{ GIF (Graphics Interchange Format) loader/saver class. GIF was
|
|
(and is still used) popular format for storing images supporting
|
|
multiple images per file and single color transparency.
|
|
Pixel format is 8 bit indexed where each image frame can have
|
|
its own color palette. GIF uses lossless LZW compression
|
|
(patent expired few years ago).
|
|
Imaging can load and save all GIFs with all frames and supports
|
|
transparency. Imaging can load just raw ifIndex8 frames or
|
|
also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
|
|
TGIFFileFormat = class(TImageFileFormat)
|
|
private
|
|
FLoadAnimated: LongBool;
|
|
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
|
|
procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
|
|
Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
|
|
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
|
|
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
|
|
protected
|
|
procedure Define; override;
|
|
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
|
|
OnlyFirstLevel: Boolean): Boolean; override;
|
|
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
|
|
Index: LongInt): Boolean; override;
|
|
procedure ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo); override;
|
|
public
|
|
function TestFormat(Handle: TImagingHandle): Boolean; override;
|
|
published
|
|
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
|
|
end;
|
|
|
|
implementation
|
|
|
|
const
|
|
SGIFFormatName = 'Graphics Interchange Format';
|
|
SGIFMasks = '*.gif';
|
|
GIFSupportedFormats: TImageFormats = [ifIndex8];
|
|
GIFDefaultLoadAnimated = True;
|
|
|
|
type
|
|
TGIFVersion = (gv87, gv89);
|
|
TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
|
|
dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
|
|
|
|
const
|
|
GIFSignature: TChar3 = 'GIF';
|
|
GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
|
|
GIFDefaultDelay = 65;
|
|
|
|
// Masks for accessing fields in PackedFields of TGIFHeader
|
|
GIFGlobalColorTable = $80;
|
|
GIFColorResolution = $70;
|
|
GIFColorTableSorted = $08;
|
|
GIFColorTableSize = $07;
|
|
|
|
// Masks for accessing fields in PackedFields of TImageDescriptor
|
|
GIFLocalColorTable = $80;
|
|
GIFInterlaced = $40;
|
|
GIFLocalTableSorted = $20;
|
|
|
|
// Block identifiers
|
|
GIFPlainText: Byte = $01;
|
|
GIFGraphicControlExtension: Byte = $F9;
|
|
GIFCommentExtension: Byte = $FE;
|
|
GIFApplicationExtension: Byte = $FF;
|
|
GIFImageDescriptor: Byte = Ord(',');
|
|
GIFExtensionIntroducer: Byte = Ord('!');
|
|
GIFTrailer: Byte = Ord(';');
|
|
GIFBlockTerminator: Byte = $00;
|
|
|
|
// Masks for accessing fields in PackedFields of TGraphicControlExtension
|
|
GIFTransparent = $01;
|
|
GIFUserInput = $02;
|
|
GIFDisposalMethod = $1C;
|
|
|
|
const
|
|
// Netscape sub block types
|
|
GIFAppLoopExtension = 1;
|
|
GIFAppBufferExtension = 2;
|
|
|
|
type
|
|
TGIFHeader = packed record
|
|
// File header part
|
|
Signature: TChar3; // Header Signature (always "GIF")
|
|
Version: TChar3; // GIF format version("87a" or "89a")
|
|
// Logical Screen Descriptor part
|
|
ScreenWidth: Word; // Width of Display Screen in Pixels
|
|
ScreenHeight: Word; // Height of Display Screen in Pixels
|
|
PackedFields: Byte; // Screen and color map information
|
|
BackgroundColorIndex: Byte; // Background color index (in global color table)
|
|
AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
|
|
end;
|
|
|
|
TImageDescriptor = packed record
|
|
//Separator: Byte; // leave that out since we always read one bye ahead
|
|
Left: Word; // X position of image with respect to logical screen
|
|
Top: Word; // Y position
|
|
Width: Word;
|
|
Height: Word;
|
|
PackedFields: Byte;
|
|
end;
|
|
|
|
const
|
|
// GIF extension labels
|
|
GIFExtTypeGraphic = $F9;
|
|
GIFExtTypePlainText = $01;
|
|
GIFExtTypeApplication = $FF;
|
|
GIFExtTypeComment = $FE;
|
|
|
|
type
|
|
TGraphicControlExtension = packed record
|
|
BlockSize: Byte;
|
|
PackedFields: Byte;
|
|
DelayTime: Word;
|
|
TransparentColorIndex: Byte;
|
|
Terminator: Byte;
|
|
end;
|
|
|
|
type
|
|
TGIFIdentifierCode = array[0..7] of AnsiChar;
|
|
TGIFAuthenticationCode = array[0..2] of AnsiChar;
|
|
TGIFApplicationRec = packed record
|
|
Identifier: TGIFIdentifierCode;
|
|
Authentication: TGIFAuthenticationCode;
|
|
end;
|
|
|
|
const
|
|
CodeTableSize = 4096;
|
|
HashTableSize = 17777;
|
|
|
|
type
|
|
TReadContext = record
|
|
Inx: Integer;
|
|
Size: Integer;
|
|
Buf: array [0..255 + 4] of Byte;
|
|
CodeSize: Integer;
|
|
ReadMask: Integer;
|
|
end;
|
|
PReadContext = ^TReadContext;
|
|
|
|
TWriteContext = record
|
|
Inx: Integer;
|
|
CodeSize: Integer;
|
|
Buf: array [0..255 + 4] of Byte;
|
|
end;
|
|
PWriteContext = ^TWriteContext;
|
|
|
|
TOutputContext = record
|
|
W: Integer;
|
|
H: Integer;
|
|
X: Integer;
|
|
Y: Integer;
|
|
BitsPerPixel: Integer;
|
|
Pass: Integer;
|
|
Interlace: Boolean;
|
|
LineIdent: Integer;
|
|
Data: Pointer;
|
|
CurrLineData: Pointer;
|
|
end;
|
|
|
|
TImageDict = record
|
|
Tail: Word;
|
|
Index: Word;
|
|
Col: Byte;
|
|
end;
|
|
PImageDict = ^TImageDict;
|
|
|
|
PIntCodeTable = ^TIntCodeTable;
|
|
TIntCodeTable = array [0..CodeTableSize - 1] of Word;
|
|
|
|
TDictTable = array [0..CodeTableSize - 1] of TImageDict;
|
|
PDictTable = ^TDictTable;
|
|
|
|
resourcestring
|
|
SGIFDecodingError = 'Error when decoding GIF LZW data';
|
|
|
|
{
|
|
TGIFFileFormat implementation
|
|
}
|
|
|
|
procedure TGIFFileFormat.Define;
|
|
begin
|
|
inherited;
|
|
FName := SGIFFormatName;
|
|
FFeatures := [ffLoad, ffSave, ffMultiImage];
|
|
FSupportedFormats := GIFSupportedFormats;
|
|
FLoadAnimated := GIFDefaultLoadAnimated;
|
|
|
|
AddMasks(SGIFMasks);
|
|
RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
|
|
end;
|
|
|
|
function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
|
|
begin
|
|
Result := Y;
|
|
case Pass of
|
|
0, 1:
|
|
Inc(Result, 8);
|
|
2:
|
|
Inc(Result, 4);
|
|
3:
|
|
Inc(Result, 2);
|
|
end;
|
|
if Result >= Height then
|
|
begin
|
|
if Pass = 0 then
|
|
begin
|
|
Pass := 1;
|
|
Result := 4;
|
|
if Result < Height then
|
|
Exit;
|
|
end;
|
|
if Pass = 1 then
|
|
begin
|
|
Pass := 2;
|
|
Result := 2;
|
|
if Result < Height then
|
|
Exit;
|
|
end;
|
|
if Pass = 2 then
|
|
begin
|
|
Pass := 3;
|
|
Result := 1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
|
|
procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
|
|
Interlaced: Boolean; Data: Pointer);
|
|
var
|
|
MinCodeSize: Byte;
|
|
MaxCode, BitMask, InitCodeSize: Integer;
|
|
ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
|
|
I, OutCount, Code: Integer;
|
|
CurCode, OldCode, InCode, FinalChar: Word;
|
|
Prefix, Suffix, OutCode: PIntCodeTable;
|
|
ReadCtxt: TReadContext;
|
|
OutCtxt: TOutputContext;
|
|
TableFull: Boolean;
|
|
|
|
function ReadCode(var Context: TReadContext): Integer;
|
|
var
|
|
RawCode: Integer;
|
|
ByteIndex: Integer;
|
|
Bytes: Byte;
|
|
BytesToLose: Integer;
|
|
begin
|
|
while (Context.Inx + Context.CodeSize > Context.Size) and
|
|
(Stream.Position < Stream.Size) do
|
|
begin
|
|
// Not enough bits in buffer - refill it - Not very efficient, but infrequently called
|
|
BytesToLose := Context.Inx shr 3;
|
|
// Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
|
|
Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
|
|
Context.Inx := Context.Inx and 7;
|
|
Context.Size := Context.Size - (BytesToLose shl 3);
|
|
Stream.Read(Bytes, 1);
|
|
if Bytes > 0 then
|
|
Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
|
|
Context.Size := Context.Size + (Bytes shl 3);
|
|
end;
|
|
ByteIndex := Context.Inx shr 3;
|
|
RawCode := Context.Buf[Word(ByteIndex)] +
|
|
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
|
|
if Context.CodeSize > 8 then
|
|
RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16);
|
|
RawCode := RawCode shr (Context.Inx and 7);
|
|
Context.Inx := Context.Inx + Byte(Context.CodeSize);
|
|
Result := RawCode and Context.ReadMask;
|
|
end;
|
|
|
|
procedure Output(Value: Byte; var Context: TOutputContext);
|
|
var
|
|
P: PByte;
|
|
begin
|
|
if Context.Y >= Context.H then
|
|
Exit;
|
|
|
|
// Only ifIndex8 supported
|
|
P := @PByteArray(Context.CurrLineData)[Context.X];
|
|
P^ := Value;
|
|
|
|
{case Context.BitsPerPixel of
|
|
1:
|
|
begin
|
|
P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
|
|
if (Context.X and $07) <> 0 then
|
|
P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
|
|
else
|
|
P^ := Byte(Value shl 7);
|
|
end;
|
|
4:
|
|
begin
|
|
P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
|
|
if (Context.X and 1) <> 0 then
|
|
P^ := P^ or Value
|
|
else
|
|
P^ := Byte(Value shl 4);
|
|
end;
|
|
8:
|
|
begin
|
|
P := @PByteArray(Context.CurrLineData)[Context.X];
|
|
P^ := Value;
|
|
end;
|
|
end;}
|
|
Inc(Context.X);
|
|
|
|
if Context.X < Context.W then
|
|
Exit;
|
|
Context.X := 0;
|
|
if Context.Interlace then
|
|
Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
|
|
else
|
|
Inc(Context.Y);
|
|
|
|
Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
|
|
end;
|
|
|
|
begin
|
|
OutCount := 0;
|
|
OldCode := 0;
|
|
FinalChar := 0;
|
|
TableFull := False;
|
|
GetMem(Prefix, SizeOf(TIntCodeTable));
|
|
GetMem(Suffix, SizeOf(TIntCodeTable));
|
|
GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
|
|
try
|
|
Stream.Read(MinCodeSize, 1);
|
|
if (MinCodeSize < 2) or (MinCodeSize > 9) then
|
|
RaiseImaging(SGIFDecodingError, []);
|
|
// Initial read context
|
|
ReadCtxt.Inx := 0;
|
|
ReadCtxt.Size := 0;
|
|
ReadCtxt.CodeSize := MinCodeSize + 1;
|
|
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
|
|
// Initialise pixel-output context
|
|
OutCtxt.X := 0;
|
|
OutCtxt.Y := 0;
|
|
OutCtxt.Pass := 0;
|
|
OutCtxt.W := Width;
|
|
OutCtxt.H := Height;
|
|
OutCtxt.BitsPerPixel := MinCodeSize;
|
|
OutCtxt.Interlace := Interlaced;
|
|
OutCtxt.LineIdent := Width;
|
|
OutCtxt.Data := Data;
|
|
OutCtxt.CurrLineData := Data;
|
|
BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
|
|
// 2 ^ MinCodeSize accounts for all colours in file
|
|
ClearCode := 1 shl MinCodeSize;
|
|
EndingCode := ClearCode + 1;
|
|
FreeCode := ClearCode + 2;
|
|
FirstFreeCode := FreeCode;
|
|
// 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
|
|
InitCodeSize := ReadCtxt.CodeSize;
|
|
MaxCode := 1 shl ReadCtxt.CodeSize;
|
|
Code := ReadCode(ReadCtxt);
|
|
while (Code <> EndingCode) and (Code <> $FFFF) and
|
|
(OutCtxt.Y < OutCtxt.H) do
|
|
begin
|
|
if Code = ClearCode then
|
|
begin
|
|
ReadCtxt.CodeSize := InitCodeSize;
|
|
MaxCode := 1 shl ReadCtxt.CodeSize;
|
|
ReadCtxt.ReadMask := MaxCode - 1;
|
|
FreeCode := FirstFreeCode;
|
|
Code := ReadCode(ReadCtxt);
|
|
CurCode := Code;
|
|
OldCode := Code;
|
|
if Code = $FFFF then
|
|
Break;
|
|
FinalChar := (CurCode and BitMask);
|
|
Output(Byte(FinalChar), OutCtxt);
|
|
TableFull := False;
|
|
end
|
|
else
|
|
begin
|
|
CurCode := Code;
|
|
InCode := Code;
|
|
if CurCode >= FreeCode then
|
|
begin
|
|
CurCode := OldCode;
|
|
OutCode^[OutCount] := FinalChar;
|
|
Inc(OutCount);
|
|
end;
|
|
while CurCode > BitMask do
|
|
begin
|
|
if OutCount > CodeTableSize then
|
|
RaiseImaging(SGIFDecodingError, []);
|
|
OutCode^[OutCount] := Suffix^[CurCode];
|
|
Inc(OutCount);
|
|
CurCode := Prefix^[CurCode];
|
|
end;
|
|
|
|
FinalChar := CurCode and BitMask;
|
|
OutCode^[OutCount] := FinalChar;
|
|
Inc(OutCount);
|
|
for I := OutCount - 1 downto 0 do
|
|
Output(Byte(OutCode^[I]), OutCtxt);
|
|
OutCount := 0;
|
|
// Update dictionary
|
|
if not TableFull then
|
|
begin
|
|
Prefix^[FreeCode] := OldCode;
|
|
Suffix^[FreeCode] := FinalChar;
|
|
// Advance to next free slot
|
|
Inc(FreeCode);
|
|
if FreeCode >= MaxCode then
|
|
begin
|
|
if ReadCtxt.CodeSize < 12 then
|
|
begin
|
|
Inc(ReadCtxt.CodeSize);
|
|
MaxCode := MaxCode shl 1;
|
|
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
|
|
end
|
|
else
|
|
TableFull := True;
|
|
end;
|
|
end;
|
|
OldCode := InCode;
|
|
end;
|
|
Code := ReadCode(ReadCtxt);
|
|
end;
|
|
if Code = $FFFF then
|
|
RaiseImaging(SGIFDecodingError, []);
|
|
finally
|
|
FreeMem(Prefix);
|
|
FreeMem(OutCode);
|
|
FreeMem(Suffix);
|
|
end;
|
|
end;
|
|
|
|
{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
|
|
procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
|
|
Interlaced: Boolean; Data: Pointer);
|
|
var
|
|
LineIdent: Integer;
|
|
MinCodeSize, Col: Byte;
|
|
InitCodeSize, X, Y: Integer;
|
|
Pass: Integer;
|
|
MaxCode: Integer; { 1 shl CodeSize }
|
|
ClearCode, EndingCode, LastCode, Tail: Integer;
|
|
I, HashValue: Integer;
|
|
LenString: Word;
|
|
Dict: PDictTable;
|
|
HashTable: TList;
|
|
PData: PByte;
|
|
WriteCtxt: TWriteContext;
|
|
|
|
function InitHash(P: Integer): Integer;
|
|
begin
|
|
Result := (P + 3) * 301;
|
|
end;
|
|
|
|
procedure WriteCode(Code: Integer; var Context: TWriteContext);
|
|
var
|
|
BufIndex: Integer;
|
|
Bytes: Byte;
|
|
begin
|
|
BufIndex := Context.Inx shr 3;
|
|
Code := Code shl (Context.Inx and 7);
|
|
Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
|
|
Context.Buf[BufIndex + 1] := Byte(Code shr 8);
|
|
Context.Buf[BufIndex + 2] := Byte(Code shr 16);
|
|
Context.Inx := Context.Inx + Context.CodeSize;
|
|
if Context.Inx >= 255 * 8 then
|
|
begin
|
|
// Flush out full buffer
|
|
Bytes := 255;
|
|
IO.Write(Handle, @Bytes, 1);
|
|
IO.Write(Handle, @Context.Buf, Bytes);
|
|
Move(Context.Buf[255], Context.Buf[0], 2);
|
|
FillChar(Context.Buf[2], 255, 0);
|
|
Context.Inx := Context.Inx - (255 * 8);
|
|
end;
|
|
end;
|
|
|
|
procedure FlushCode(var Context: TWriteContext);
|
|
var
|
|
Bytes: Byte;
|
|
begin
|
|
Bytes := (Context.Inx + 7) shr 3;
|
|
if Bytes > 0 then
|
|
begin
|
|
IO.Write(Handle, @Bytes, 1);
|
|
IO.Write(Handle, @Context.Buf, Bytes);
|
|
end;
|
|
// Data block terminator - a block of zero Size
|
|
Bytes := 0;
|
|
IO.Write(Handle, @Bytes, 1);
|
|
end;
|
|
|
|
begin
|
|
LineIdent := Width;
|
|
Tail := 0;
|
|
HashValue := 0;
|
|
Col := 0;
|
|
HashTable := TList.Create;
|
|
GetMem(Dict, SizeOf(TDictTable));
|
|
try
|
|
for I := 0 to HashTableSize - 1 do
|
|
HashTable.Add(nil);
|
|
|
|
// Initialise encoder variables
|
|
InitCodeSize := BitCount + 1;
|
|
if InitCodeSize = 2 then
|
|
Inc(InitCodeSize);
|
|
MinCodeSize := InitCodeSize - 1;
|
|
IO.Write(Handle, @MinCodeSize, 1);
|
|
ClearCode := 1 shl MinCodeSize;
|
|
EndingCode := ClearCode + 1;
|
|
LastCode := EndingCode;
|
|
MaxCode := 1 shl InitCodeSize;
|
|
LenString := 0;
|
|
// Setup write context
|
|
WriteCtxt.Inx := 0;
|
|
WriteCtxt.CodeSize := InitCodeSize;
|
|
FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
|
|
WriteCode(ClearCode, WriteCtxt);
|
|
Y := 0;
|
|
Pass := 0;
|
|
|
|
while Y < Height do
|
|
begin
|
|
PData := @PByteArray(Data)[Y * LineIdent];
|
|
for X := 0 to Width - 1 do
|
|
begin
|
|
// Only ifIndex8 support
|
|
case BitCount of
|
|
8:
|
|
begin
|
|
Col := PData^;
|
|
PData := @PByteArray(PData)[1];
|
|
end;
|
|
{4:
|
|
begin
|
|
if X and 1 <> 0 then
|
|
begin
|
|
Col := PData^ and $0F;
|
|
PData := @PByteArray(PData)[1];
|
|
end
|
|
else
|
|
Col := PData^ shr 4;
|
|
end;
|
|
1:
|
|
begin
|
|
if X and 7 = 7 then
|
|
begin
|
|
Col := PData^ and 1;
|
|
PData := @PByteArray(PData)[1];
|
|
end
|
|
else
|
|
Col := (PData^ shr (7 - (X and $07))) and $01;
|
|
end;}
|
|
end;
|
|
Inc(LenString);
|
|
if LenString = 1 then
|
|
begin
|
|
Tail := Col;
|
|
HashValue := InitHash(Col);
|
|
end
|
|
else
|
|
begin
|
|
HashValue := HashValue * (Col + LenString + 4);
|
|
I := HashValue mod HashTableSize;
|
|
HashValue := HashValue mod HashTableSize;
|
|
while (HashTable[I] <> nil) and
|
|
((PImageDict(HashTable[I])^.Tail <> Tail) or
|
|
(PImageDict(HashTable[I])^.Col <> Col)) do
|
|
begin
|
|
Inc(I);
|
|
if I >= HashTableSize then
|
|
I := 0;
|
|
end;
|
|
if HashTable[I] <> nil then // Found in the strings table
|
|
Tail := PImageDict(HashTable[I])^.Index
|
|
else
|
|
begin
|
|
// Not found
|
|
WriteCode(Tail, WriteCtxt);
|
|
Inc(LastCode);
|
|
HashTable[I] := @Dict^[LastCode];
|
|
PImageDict(HashTable[I])^.Index := LastCode;
|
|
PImageDict(HashTable[I])^.Tail := Tail;
|
|
PImageDict(HashTable[I])^.Col := Col;
|
|
Tail := Col;
|
|
HashValue := InitHash(Col);
|
|
LenString := 1;
|
|
if LastCode >= MaxCode then
|
|
begin
|
|
// Next Code will be written longer
|
|
MaxCode := MaxCode shl 1;
|
|
Inc(WriteCtxt.CodeSize);
|
|
end
|
|
else
|
|
if LastCode >= CodeTableSize - 2 then
|
|
begin
|
|
// Reset tables
|
|
WriteCode(Tail, WriteCtxt);
|
|
WriteCode(ClearCode, WriteCtxt);
|
|
LenString := 0;
|
|
LastCode := EndingCode;
|
|
WriteCtxt.CodeSize := InitCodeSize;
|
|
MaxCode := 1 shl InitCodeSize;
|
|
for I := 0 to HashTableSize - 1 do
|
|
HashTable[I] := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if Interlaced then
|
|
Y := InterlaceStep(Y, Height, Pass)
|
|
else
|
|
Inc(Y);
|
|
end;
|
|
WriteCode(Tail, WriteCtxt);
|
|
WriteCode(EndingCode, WriteCtxt);
|
|
FlushCode(WriteCtxt);
|
|
finally
|
|
HashTable.Free;
|
|
FreeMem(Dict);
|
|
end;
|
|
end;
|
|
|
|
function TGIFFileFormat.LoadData(Handle: TImagingHandle;
|
|
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
|
|
type
|
|
TFrameInfo = record
|
|
Left, Top: Integer;
|
|
Width, Height: Integer;
|
|
Disposal: TDisposalMethod;
|
|
HasTransparency: Boolean;
|
|
HasLocalPal: Boolean;
|
|
TransIndex: Integer;
|
|
BackIndex: Integer;
|
|
end;
|
|
var
|
|
Header: TGIFHeader;
|
|
HasGlobalPal: Boolean;
|
|
GlobalPalLength: Integer;
|
|
GlobalPal: TPalette32Size256;
|
|
ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
|
|
BlockID: Byte;
|
|
HasGraphicExt: Boolean;
|
|
GraphicExt: TGraphicControlExtension;
|
|
FrameInfos: array of TFrameInfo;
|
|
AppRead: Boolean;
|
|
CachedFrame: TImageData;
|
|
AnimFrames: TDynImageDataArray;
|
|
|
|
function ReadBlockID: Byte;
|
|
begin
|
|
Result := GIFTrailer;
|
|
if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
|
|
Result := GIFTrailer;
|
|
end;
|
|
|
|
procedure ReadExtensions;
|
|
var
|
|
BlockSize, BlockType, ExtType: Byte;
|
|
AppRec: TGIFApplicationRec;
|
|
LoopCount: SmallInt;
|
|
|
|
procedure SkipBytes;
|
|
begin
|
|
with GetIO do
|
|
repeat
|
|
// Read block sizes and skip them
|
|
Read(Handle, @BlockSize, SizeOf(BlockSize));
|
|
Seek(Handle, BlockSize, smFromCurrent);
|
|
until BlockSize = 0;
|
|
end;
|
|
|
|
begin
|
|
HasGraphicExt := False;
|
|
AppRead := False;
|
|
|
|
// Read extensions until image descriptor is found. Only graphic extension
|
|
// is stored now (for transparency), others are skipped.
|
|
while BlockID = GIFExtensionIntroducer do
|
|
with GetIO do
|
|
begin
|
|
Read(Handle, @ExtType, SizeOf(ExtType));
|
|
|
|
while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
|
|
begin
|
|
if ExtType = GIFGraphicControlExtension then
|
|
begin
|
|
HasGraphicExt := True;
|
|
Read(Handle, @GraphicExt, SizeOf(GraphicExt));
|
|
end
|
|
else if (ExtType = GIFApplicationExtension) and not AppRead then
|
|
begin
|
|
Read(Handle, @BlockSize, SizeOf(BlockSize));
|
|
if BlockSize >= SizeOf(AppRec) then
|
|
begin
|
|
Read(Handle, @AppRec, SizeOf(AppRec));
|
|
if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or
|
|
((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then
|
|
begin
|
|
Read(Handle, @BlockSize, SizeOf(BlockSize));
|
|
while BlockSize <> 0 do
|
|
begin
|
|
BlockType := ReadBlockID;
|
|
Dec(BlockSize);
|
|
|
|
case BlockType of
|
|
GIFAppLoopExtension:
|
|
if (BlockSize >= SizeOf(LoopCount)) then
|
|
begin
|
|
// Read loop count
|
|
Read(Handle, @LoopCount, SizeOf(LoopCount));
|
|
Dec(BlockSize, SizeOf(LoopCount));
|
|
if LoopCount > 0 then
|
|
Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
|
|
FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
|
|
end;
|
|
GIFAppBufferExtension:
|
|
begin
|
|
Dec(BlockSize, SizeOf(Word));
|
|
Seek(Handle, SizeOf(Word), smFromCurrent);
|
|
end;
|
|
end;
|
|
end;
|
|
SkipBytes;
|
|
AppRead := True;
|
|
end
|
|
else
|
|
begin
|
|
// Revert all bytes reading
|
|
Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
|
|
SkipBytes;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
|
|
SkipBytes;
|
|
end;
|
|
end
|
|
else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
|
|
repeat
|
|
// Read block sizes and skip them
|
|
Read(Handle, @BlockSize, SizeOf(BlockSize));
|
|
Seek(Handle, BlockSize, smFromCurrent);
|
|
until BlockSize = 0;
|
|
|
|
// Read ID of following block
|
|
BlockID := ReadBlockID;
|
|
ExtType := BlockID;
|
|
end
|
|
end;
|
|
end;
|
|
|
|
procedure CopyLZWData(Dest: TStream);
|
|
var
|
|
CodeSize, BlockSize: Byte;
|
|
InputSize: Integer;
|
|
Buff: array[Byte] of Byte;
|
|
begin
|
|
InputSize := ImagingIO.GetInputSize(GetIO, Handle);
|
|
// Copy codesize to stream
|
|
GetIO.Read(Handle, @CodeSize, 1);
|
|
Dest.Write(CodeSize, 1);
|
|
repeat
|
|
// Read and write data blocks, last is block term value of 0
|
|
GetIO.Read(Handle, @BlockSize, 1);
|
|
Dest.Write(BlockSize, 1);
|
|
if BlockSize > 0 then
|
|
begin
|
|
GetIO.Read(Handle, @Buff[0], BlockSize);
|
|
Dest.Write(Buff[0], BlockSize);
|
|
end;
|
|
until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize);
|
|
end;
|
|
|
|
procedure ReadFrame;
|
|
var
|
|
ImageDesc: TImageDescriptor;
|
|
Interlaced: Boolean;
|
|
I, Idx, LocalPalLength: Integer;
|
|
LocalPal: TPalette32Size256;
|
|
LZWStream: TMemoryStream;
|
|
|
|
procedure RemoveBadFrame;
|
|
begin
|
|
FreeImage(Images[Idx]);
|
|
SetLength(Images, Length(Images) - 1);
|
|
end;
|
|
|
|
begin
|
|
Idx := Length(Images);
|
|
SetLength(Images, Idx + 1);
|
|
SetLength(FrameInfos, Idx + 1);
|
|
FillChar(LocalPal, SizeOf(LocalPal), 0);
|
|
|
|
with GetIO do
|
|
begin
|
|
// Read and parse image descriptor
|
|
Read(Handle, @ImageDesc, SizeOf(ImageDesc));
|
|
FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
|
|
Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
|
|
LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
|
|
LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
|
|
|
|
// From Mozilla source
|
|
if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
|
|
ImageDesc.Width := Header.ScreenWidth;
|
|
if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then
|
|
ImageDesc.Height := Header.ScreenHeight;
|
|
|
|
FrameInfos[Idx].Left := ImageDesc.Left;
|
|
FrameInfos[Idx].Top := ImageDesc.Top;
|
|
FrameInfos[Idx].Width := ImageDesc.Width;
|
|
FrameInfos[Idx].Height := ImageDesc.Height;
|
|
FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
|
|
|
|
// Create new image for this frame which would be later pasted onto logical screen
|
|
NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
|
|
|
|
// Load local palette if there is any
|
|
if FrameInfos[Idx].HasLocalPal then
|
|
for I := 0 to LocalPalLength - 1 do
|
|
begin
|
|
LocalPal[I].A := 255;
|
|
Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
|
|
Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
|
|
Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
|
|
end;
|
|
|
|
// Use local pal if present or global pal if present or create
|
|
// default pal if neither of them is present
|
|
if FrameInfos[Idx].HasLocalPal then
|
|
Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
|
|
else if HasGlobalPal then
|
|
Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
|
|
else
|
|
FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
|
|
|
|
if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
|
|
begin
|
|
// Resize the screen if needed to fit the frame
|
|
ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
|
|
ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
|
|
end
|
|
else
|
|
begin
|
|
// Remove frame outside logical screen
|
|
RemoveBadFrame;
|
|
Exit;
|
|
end;
|
|
|
|
// If Grahic Control Extension is present make use of it
|
|
if HasGraphicExt then
|
|
begin
|
|
FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
|
|
FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
|
|
if FrameInfos[Idx].HasTransparency then
|
|
begin
|
|
FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
|
|
Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
|
|
end;
|
|
FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
|
|
end
|
|
else
|
|
FrameInfos[Idx].HasTransparency := False;
|
|
|
|
LZWStream := TMemoryStream.Create;
|
|
try
|
|
try
|
|
// Copy LZW data to temp stream, needed for correct decompression
|
|
CopyLZWData(LZWStream);
|
|
LZWStream.Position := 0;
|
|
// Data decompression finally
|
|
LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
|
|
except
|
|
RemoveBadFrame;
|
|
Exit;
|
|
end;
|
|
finally
|
|
LZWStream.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
|
|
var
|
|
X, Y: Integer;
|
|
Src: PByte;
|
|
Dst: PColor32;
|
|
begin
|
|
Src := Frame.Bits;
|
|
|
|
// Copy all pixels from frame to log screen but ignore the transparent ones
|
|
for Y := 0 to Frame.Height - 1 do
|
|
begin
|
|
Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
|
|
for X := 0 to Frame.Width - 1 do
|
|
begin
|
|
if (Frame.Palette[Src^].A <> 0) then
|
|
Dst^ := Frame.Palette[Src^].Color;
|
|
Inc(Src);
|
|
Inc(Dst);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
|
|
var
|
|
I, First, Last: Integer;
|
|
UseCache: Boolean;
|
|
BGColor: TColor32;
|
|
begin
|
|
// We may need to use raw frame 0 to n to correctly animate n-th frame
|
|
Last := Index;
|
|
First := Max(0, Last);
|
|
// See if we can use last animate frame as a basis for this one
|
|
// (so we don't have to use previous raw frames).
|
|
UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
|
|
(FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
|
|
|
|
// Reuse or release cache
|
|
if UseCache then
|
|
CloneImage(CachedFrame, AnimFrame)
|
|
else
|
|
FreeImage(CachedFrame);
|
|
|
|
// Default color for clearing of the screen
|
|
BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
|
|
|
|
// Now prepare logical screen for drawing of raw frame at Index.
|
|
// We may need to use all previous raw frames to get the screen
|
|
// to proper state (according to their disposal methods).
|
|
|
|
if not UseCache then
|
|
begin
|
|
if FrameInfos[Index].HasTransparency then
|
|
BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
|
|
// Clear whole screen
|
|
FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
|
|
|
|
// Try to maximize First so we don't have to use all 0 to n raw frames
|
|
while First > 0 do
|
|
begin
|
|
if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
|
|
begin
|
|
if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
|
|
Break;
|
|
end;
|
|
Dec(First);
|
|
end;
|
|
|
|
for I := First to Last - 1 do
|
|
begin
|
|
case FrameInfos[I].Disposal of
|
|
dmNoRemoval, dmLeave:
|
|
begin
|
|
// Copy previous raw frame onto screen
|
|
CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
|
|
end;
|
|
dmRestoreBackground:
|
|
if (I > First) then
|
|
begin
|
|
// Restore background color
|
|
FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
|
|
FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
|
|
end;
|
|
dmRestorePrevious: ; // Do nothing - previous state is already on screen
|
|
end;
|
|
end;
|
|
end
|
|
else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
|
|
begin
|
|
// We have our cached result but also need to restore
|
|
// background in a place of cached frame
|
|
if FrameInfos[CachedIndex].HasTransparency then
|
|
BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
|
|
FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
|
|
FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
|
|
end;
|
|
|
|
// Copy current raw frame to prepared screen
|
|
CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
|
|
|
|
// Cache animated result
|
|
CloneImage(AnimFrame, CachedFrame);
|
|
CachedIndex := Index;
|
|
end;
|
|
|
|
begin
|
|
AppRead := False;
|
|
|
|
SetLength(Images, 0);
|
|
FillChar(GlobalPal, SizeOf(GlobalPal), 0);
|
|
|
|
with GetIO do
|
|
begin
|
|
// Read GIF header
|
|
Read(Handle, @Header, SizeOf(Header));
|
|
ScreenWidth := Header.ScreenWidth;
|
|
ScreenHeight := Header.ScreenHeight;
|
|
HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
|
|
GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
|
|
GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1)
|
|
|
|
// Read global palette from file if present
|
|
if HasGlobalPal then
|
|
begin
|
|
for I := 0 to GlobalPalLength - 1 do
|
|
begin
|
|
GlobalPal[I].A := 255;
|
|
Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
|
|
Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
|
|
Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
|
|
end;
|
|
end;
|
|
|
|
// Read ID of the first block
|
|
BlockID := ReadBlockID;
|
|
|
|
// Now read all data blocks in the file until file trailer is reached
|
|
while BlockID <> GIFTrailer do
|
|
begin
|
|
// Read blocks until we find the one of known type
|
|
while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
|
|
BlockID := ReadBlockID;
|
|
// Read supported and skip unsupported extensions
|
|
ReadExtensions;
|
|
// If image frame is found read it
|
|
if BlockID = GIFImageDescriptor then
|
|
ReadFrame;
|
|
// Read next block's ID
|
|
BlockID := ReadBlockID;
|
|
// If block ID is unknown set it to end-of-GIF marker
|
|
if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
|
|
BlockID := GIFTrailer;
|
|
end;
|
|
|
|
if FLoadAnimated then
|
|
begin
|
|
// Aniated frames will be stored in AnimFrames
|
|
SetLength(AnimFrames, Length(Images));
|
|
InitImage(CachedFrame);
|
|
CachedIndex := -1;
|
|
|
|
for I := 0 to High(Images) do
|
|
begin
|
|
// Create new logical screen
|
|
NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
|
|
// Animate frames to current log screen
|
|
AnimateFrame(I, AnimFrames[I]);
|
|
end;
|
|
|
|
// Now release raw 8bit frames and put animated 32bit ones
|
|
// to output array
|
|
FreeImage(CachedFrame);
|
|
for I := 0 to High(AnimFrames) do
|
|
begin
|
|
FreeImage(Images[I]);
|
|
Images[I] := AnimFrames[I];
|
|
end;
|
|
end;
|
|
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function TGIFFileFormat.SaveData(Handle: TImagingHandle;
|
|
const Images: TDynImageDataArray; Index: Integer): Boolean;
|
|
var
|
|
Header: TGIFHeader;
|
|
ImageDesc: TImageDescriptor;
|
|
ImageToSave: TImageData;
|
|
MustBeFreed: Boolean;
|
|
I, J: Integer;
|
|
GraphicExt: TGraphicControlExtension;
|
|
|
|
procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
MaxWidth := Images[FFirstIdx].Width;
|
|
MaxHeight := Images[FFirstIdx].Height;
|
|
|
|
for I := FFirstIdx + 1 to FLastIdx do
|
|
begin
|
|
MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
|
|
MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
|
|
end;
|
|
end;
|
|
|
|
procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension);
|
|
begin
|
|
if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then
|
|
Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10
|
|
else
|
|
Ext.DelayTime := GIFDefaultDelay;
|
|
end;
|
|
|
|
procedure SaveGlobalMetadata;
|
|
var
|
|
AppExt: TGIFApplicationRec;
|
|
BlockSize, LoopExtId: Byte;
|
|
Repeats: Word;
|
|
begin
|
|
if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
|
|
with GetIO do
|
|
begin
|
|
FillChar(AppExt, SizeOf(AppExt), 0);
|
|
AppExt.Identifier := 'NETSCAPE';
|
|
AppExt.Authentication := '2.0';
|
|
Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
|
|
if Repeats > 0 then
|
|
Dec(Repeats);
|
|
LoopExtId := GIFAppLoopExtension;
|
|
|
|
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
|
|
Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension));
|
|
BlockSize := 11;
|
|
Write(Handle, @BlockSize, SizeOf(BlockSize));
|
|
Write(Handle, @AppExt, SizeOf(AppExt));
|
|
BlockSize := 3;
|
|
Write(Handle, @BlockSize, SizeOf(BlockSize));
|
|
Write(Handle, @LoopExtId, SizeOf(LoopExtId));
|
|
Write(Handle, @Repeats, SizeOf(Repeats));
|
|
Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator));
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
// Fill header with data, select size of largest image in array as
|
|
// logical screen size
|
|
FillChar(Header, Sizeof(Header), 0);
|
|
Header.Signature := GIFSignature;
|
|
Header.Version := GIFVersions[gv89];
|
|
FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
|
|
Header.PackedFields := GIFColorResolution; // Color resolution is 256
|
|
GetIO.Write(Handle, @Header, SizeOf(Header));
|
|
|
|
// Prepare default GC extension with delay
|
|
FillChar(GraphicExt, Sizeof(GraphicExt), 0);
|
|
GraphicExt.DelayTime := GIFDefaultDelay;
|
|
GraphicExt.BlockSize := 4;
|
|
|
|
SaveGlobalMetadata;
|
|
|
|
for I := FFirstIdx to FLastIdx do
|
|
begin
|
|
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
|
|
with GetIO, ImageToSave do
|
|
try
|
|
// Write Graphic Control Extension with default delay
|
|
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
|
|
Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
|
|
SetFrameDelay(I, GraphicExt);
|
|
Write(Handle, @GraphicExt, SizeOf(GraphicExt));
|
|
// Write frame marker and fill and write image descriptor for this frame
|
|
Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
|
|
FillChar(ImageDesc, Sizeof(ImageDesc), 0);
|
|
ImageDesc.Width := Width;
|
|
ImageDesc.Height := Height;
|
|
ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
|
|
Write(Handle, @ImageDesc, SizeOf(ImageDesc));
|
|
|
|
// Write local color table for each frame
|
|
for J := 0 to 255 do
|
|
begin
|
|
Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
|
|
Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
|
|
Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
|
|
end;
|
|
|
|
// Finally compress image data
|
|
LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
|
|
|
|
finally
|
|
if MustBeFreed then
|
|
FreeImage(ImageToSave);
|
|
end;
|
|
end;
|
|
|
|
GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo);
|
|
begin
|
|
ConvertImage(Image, ifIndex8);
|
|
end;
|
|
|
|
function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
|
|
var
|
|
Header: TGIFHeader;
|
|
ReadCount: Integer;
|
|
begin
|
|
Result := False;
|
|
if Handle <> nil then
|
|
begin
|
|
ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
|
|
GetIO.Seek(Handle, -ReadCount, smFromCurrent);
|
|
Result := (ReadCount >= SizeOf(Header)) and
|
|
(Header.Signature = GIFSignature) and
|
|
((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
RegisterImageFileFormat(TGIFFileFormat);
|
|
|
|
{
|
|
File Notes:
|
|
|
|
-- TODOS ----------------------------------------------------
|
|
- nothing now
|
|
|
|
-- 0.77 Changes/Bug Fixes -----------------------------------
|
|
- Fixed crash when resaving GIF with animation metadata.
|
|
- Writes frame delays of GIF animations from metadata.
|
|
- Reads and writes looping of GIF animations stored into/from metadata.
|
|
|
|
-- 0.26.5 Changes/Bug Fixes ---------------------------------
|
|
- Reads frame delays from GIF animations into metadata.
|
|
|
|
-- 0.26.3 Changes/Bug Fixes ---------------------------------
|
|
- Fixed bug - loading of GIF with NETSCAPE app extensions
|
|
failed with Delphi 2009.
|
|
|
|
-- 0.26.1 Changes/Bug Fixes ---------------------------------
|
|
- GIF loading and animation mostly rewritten, based on
|
|
modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
|
|
|
|
-- 0.25.0 Changes/Bug Fixes ---------------------------------
|
|
- Fixed loading of some rare GIFs, problems with LZW
|
|
decompression.
|
|
|
|
-- 0.24.3 Changes/Bug Fixes ---------------------------------
|
|
- Better solution to transparency for some GIFs. Background not
|
|
transparent by default.
|
|
|
|
-- 0.24.1 Changes/Bug Fixes ---------------------------------
|
|
- Made backround color transparent by default (alpha = 0).
|
|
|
|
-- 0.23 Changes/Bug Fixes -----------------------------------
|
|
- Fixed other loading bugs (local pal size, transparency).
|
|
- Added GIF saving.
|
|
- Fixed bug when loading multiframe GIFs and implemented few animation
|
|
features (disposal methods, ...).
|
|
- Loading of GIFs working.
|
|
- Unit created with initial stuff!
|
|
}
|
|
|
|
end.
|