aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity
CentrED/Imaging/ImagingGif.pas

1240 lines
38 KiB
Plaintext
Raw Blame History

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