You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2197 lines
70 KiB
Plaintext
2197 lines
70 KiB
Plaintext
unit litegif1;
|
|
|
|
{***************************************************************}
|
|
{* htmlgif1.pas *}
|
|
{* *}
|
|
{* Thanks to Ron Collins for the Gif code in this module. *}
|
|
{* His copyright notice is below. *}
|
|
{* *}
|
|
{* This is only a portion of his code modified slightly *}
|
|
{* in a few places to accomodate my own needs. Ron's *}
|
|
{* full package may be found at www.Torry.net/gif.htm. *}
|
|
{* The zip file is rctgif.zip. *}
|
|
{* *}
|
|
{***************************************************************}
|
|
|
|
|
|
{ ============================================================================
|
|
|
|
TGif.pas copyright (C) 2000 R. Collins
|
|
rlcollins@ksaits.com
|
|
|
|
LEGAL STUFF:
|
|
|
|
This software is provided "as-is". This software comes without warranty
|
|
or garantee, explicit or implied. Use this software at your own risk.
|
|
The author will not be liable for any damage to equipment, data, or information
|
|
that may result while using this software.
|
|
|
|
By using this software, you agree to the conditions stated above.
|
|
|
|
This software may be used freely, provided the author's name and copyright
|
|
statement remain a part of the source code.
|
|
|
|
NOTE: CompuServe, Inc. holds the patent to the compression algorithym
|
|
used in creating a GIF file. Before you save a GIF file (using LZW
|
|
compression) that may be distributed for profit, make sure you understand
|
|
the full implications and legal ramifications of using the LZW compression.
|
|
|
|
============================================================================ }
|
|
|
|
interface
|
|
|
|
{$I forRnQConfig.inc}
|
|
{$I NoRTTI.inc}
|
|
|
|
uses
|
|
{$ifdef UseCLX}
|
|
SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,
|
|
QStdCtrls;
|
|
{$else}
|
|
Windows, Messages,
|
|
{$IFNDEF WIN32}
|
|
//WinTypes, //WinProcs,
|
|
{$ENDIF WIN32}
|
|
SysUtils, Classes, Graphics,
|
|
Controls, Forms;
|
|
{$endif}
|
|
|
|
|
|
// LZW encode table sizes
|
|
|
|
const
|
|
kGifCodeTableSize = 4096;
|
|
|
|
// By Rapid D ->
|
|
// GIFDelayExp:
|
|
// The following delay values should all be multiplied by this value to
|
|
// calculate the effective time (in mS).
|
|
// According to the GIF specs, this value should be 10.
|
|
// Since our paint routines are much faster than Mozilla's, you might need
|
|
// to increase this value if your animations loops too fast. The
|
|
// optimal value is impossible to determine since it depends on the
|
|
// speed of the CPU, the video card, memory bandwidth and many other factors.
|
|
GIFDelayExp: integer = 10; // Delay multiplier in mS.
|
|
|
|
// GIFDefaultDelay:
|
|
// Default animation delay.
|
|
// This value is used if no GCE is defined.
|
|
// (10 = 100 mS)
|
|
GIFDefaultDelay: integer = 10;
|
|
|
|
// GIFMinimumDelay:
|
|
// Minimum delay.
|
|
// The minumum delay used in the Mozilla source is 10mS (MINIMUM_DELAY_TIME).
|
|
// This corresponds to a value of 1. However, since our paint routines are
|
|
// much faster than Mozilla's, a value of 3 or 4 gives better results.
|
|
// (1 = 10 mS)
|
|
GIFMinimumDelay: integer = 2;
|
|
|
|
// GIFMaximumDelay:
|
|
// Maximum delay when painter is running in main thread (goAsync is not set).
|
|
// This value guarantees that a very long and slow GIF does not hang the
|
|
// system.
|
|
// (1000 = 10000 mS = 10 Seconds)
|
|
GIFMaximumDelay: integer = 1000;
|
|
// By Rapid D <---
|
|
|
|
|
|
// the parts of a GIF file
|
|
// yes, yes, I know ... I don't have to put in "type"
|
|
// before each record definition. I just think it makes it
|
|
// easier to read, especially when the definitions may be broken
|
|
// across the printed page. if you don't like it, take them out.
|
|
|
|
type {LDB}
|
|
TRGBQUAD = packed record
|
|
rgbBlue: Byte;
|
|
rgbGreen: Byte;
|
|
rgbRed: Byte;
|
|
rgbReserved: Byte;
|
|
end;
|
|
type
|
|
PGifDataBlock = ^TGifDataBlock;
|
|
TGifDataBlock = record // generic data clump
|
|
rSize: integer; // NOTE: array starts at "1"
|
|
rData: packed array[1..255] of byte;
|
|
end;
|
|
|
|
type
|
|
PGifSignature = ^TgifSignature;
|
|
TGifSignature = record // GIF87A or GIF89A
|
|
rSignature: packed array[1..6] of AnsiChar;
|
|
end;
|
|
|
|
type
|
|
PGifExtensionGraphic = ^TgifExtensionGraphic;
|
|
TGifExtensionGraphic = record // graphic control extension
|
|
rBlockSize: integer; // must always be 4
|
|
rDisposal: integer; // disposal method when drawing
|
|
rUserInputValid: boolean; // wait for user input?
|
|
rTransparentValid: boolean; // transparent color given?
|
|
rDelayTime: integer; // delay between display images
|
|
rTransparentIndex: integer; // into color table
|
|
end;
|
|
|
|
type
|
|
PGifExtensionComment = ^TgifExtensionComment;
|
|
TGifExtensionComment = record // comment extension
|
|
rDataBlockList: TList; // data blocks
|
|
end;
|
|
|
|
type
|
|
PGifExtensionText = ^TGifExtensionText;
|
|
TGifExtensionText = record // plain text extension
|
|
rBlockSize: integer; // must always be 12
|
|
rGridLeft: integer; // text grid position
|
|
rGridTop: integer;
|
|
rGridWidth: integer; // text grid size
|
|
rGridHeight: integer;
|
|
rCellWidth: integer; // size of a character cell
|
|
rCellHeight: integer;
|
|
rForegroundIndex: integer; // text foreground color
|
|
rBackgroundIndex: integer; // text background color
|
|
rDataBlockList: TList; // data blocks
|
|
end;
|
|
|
|
type
|
|
PGifExtensionApplication = ^TgifExtensionApplication;
|
|
TGifExtensionApplication = record // application extension
|
|
rBlockSize: integer; // must always be 11
|
|
rIdentifier: packed array[1..8] of AnsiChar;
|
|
rAuthentication: packed array[1..3] of AnsiChar;
|
|
rDataBlockList: TList; // data blocks
|
|
end;
|
|
|
|
type
|
|
PGifExtension = ^TGifExtension;
|
|
TGifExtension = record // for any extension type
|
|
case rLabel: byte of // cannot use CONST names
|
|
$f9: (rGraphic: TGifExtensionGraphic);
|
|
$fe: (rComment: TGifExtensionComment);
|
|
$01: (rText: TGifExtensionText);
|
|
$ff: (rApp: TGifExtensionApplication);
|
|
$00: (rDummy: longint);
|
|
end;
|
|
|
|
type
|
|
PGifScreenDescriptor = ^TGifScreenDescriptor;
|
|
TGifScreenDescriptor = record
|
|
rWidth: integer; // size of logical screen
|
|
rHeight: integer; // size of logical screen
|
|
rGlobalColorValid: boolean; // global color table found in file?
|
|
rColorResolution: integer; // bits per color
|
|
rSorted: boolean; // global colors are sorted?
|
|
rGlobalColorSize: integer; // size of global color table
|
|
rBackgroundIndex: integer; // background color index
|
|
rAspectRatio: integer; // pixel aspect ratio
|
|
rGlobalColorTable: integer; // default color table for all images
|
|
end;
|
|
|
|
type
|
|
PGifColorTable = ^TGifColorTable; // pointer to a color table
|
|
TGifColorTable = record
|
|
rSize: integer; // number of valid entries
|
|
rColors: array[0..255] of TColor; // the colors
|
|
end;
|
|
|
|
type
|
|
PGifImageDescriptor = ^TGifImageDescriptor;
|
|
TGifImageDescriptor = record
|
|
rIndex: integer; // which image is this?
|
|
rLeft: integer; // position of image
|
|
rTop: integer; // position of image
|
|
rWidth: integer; // size of image
|
|
rHeight: integer; // size of image
|
|
rLocalColorValid: boolean; // color table used?
|
|
rInterlaced: boolean; // interlaced lines?
|
|
rSorted: boolean; // color table sorted?
|
|
rLocalColorSize: integer; // number entries in local color table
|
|
rLocalColorTable: integer; // index into master list
|
|
rLZWSize: integer; // LZW minimum code size
|
|
rExtensionList: TList; // extensions read before this image
|
|
rPixelList: PByte; // decoded pixel indices
|
|
rPixelCount: longint; // number of pixels
|
|
rBitmap: TBitmap; // the actual image
|
|
end;
|
|
|
|
|
|
type
|
|
PGifZip = ^TGifZip;
|
|
TGifZip = record
|
|
rID: PGifImageDescriptor; // image parameters to decode
|
|
rCT: PGifColorTable; // color table for this image
|
|
rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
|
|
rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
|
|
rCodeStack: array[0..kGifCodeTableSize-1] of byte; // decode/encoded pixels
|
|
rSP: integer; // pointer into CodeStack
|
|
rClearCode: integer; // reset decode params
|
|
rEndCode: integer; // last code in input stream
|
|
rHighCode: integer; // highest LZW code possible
|
|
rCurSize: integer; // current code size
|
|
rBitString: integer; // steady stream of bits to be decoded
|
|
rBits: integer; // number of valid bits in BitString
|
|
rCurSlot: integer; // next stack index to store a code
|
|
rTopSlot: integer; // highest slot used so far
|
|
rMaxVal: boolean; // max code value found?
|
|
rCurX: integer; // position of next pixel
|
|
rCurY: integer; // position of next pixel
|
|
rCurPass: integer; // pixel line pass 1..4
|
|
rFirstSlot: integer; // for encoding an image
|
|
rNextSlot: integer; // for encoding
|
|
rCount: integer; // number of bytes read/written
|
|
rLast: integer; // last byte read in
|
|
rUnget: boolean; // read a new byte, or use zLast?
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
// define a GIF
|
|
|
|
type
|
|
TGif = class(TObject)
|
|
private
|
|
fIOStream: TMemoryStream; // read or write the image
|
|
fDataStream: TMemoryStream; // temp storage for LZW
|
|
fDataStreamSize : Int64;
|
|
fExtension: TList; // latest extensions read/written
|
|
|
|
fSignature: PGifSignature; // version of GIF
|
|
fScreenDescriptor: PGifScreenDescriptor; // logical screen descriptor
|
|
fImageDescriptorList: TList; // list of all images
|
|
fColorTableList: TList; // list of all color tables
|
|
fPaletteList: TList; // list of palettes from color tables
|
|
fZipData: PGifZip; // for encode/decode image
|
|
FLoopCount: integer; // number of animated iterations
|
|
|
|
|
|
// functions that override TGraphic items
|
|
|
|
protected
|
|
function GetHeight: integer;
|
|
function GetWidth: integer;
|
|
function GetTransparent: boolean;
|
|
|
|
// procedures to read a bitmap
|
|
|
|
private
|
|
procedure ReadSignature;
|
|
procedure ReadScreenDescriptor;
|
|
procedure ReadColorTable(Size: integer; var Table: integer);
|
|
procedure ReadImageDescriptor;
|
|
procedure ReadDataBlockList(List: TList);
|
|
procedure ReadExtension(var Done: boolean);
|
|
procedure ReadSourceInteger(size: integer; var value: integer);
|
|
|
|
// LZW encode and decode
|
|
|
|
procedure LZWDecode(pID: PGifImageDescriptor);
|
|
procedure LZWInit(pID: PGifImageDescriptor);
|
|
procedure LZWFinit;
|
|
procedure LZWReset;
|
|
function LZWGetCode: integer;
|
|
procedure LZWSaveCode(Code: integer); {$IFDEF HAS_INLINE}inline;{$ENDIF HAS_INLINE}
|
|
procedure LZWDecodeCode(var Code: integer);
|
|
procedure LZWSaveSlot(Prefix, Suffix: integer);
|
|
procedure LZWIncrPosition;
|
|
procedure LZWCheckSlot;
|
|
procedure LZWWriteBitmap;
|
|
function LZWReadBitmap: integer;
|
|
|
|
// procedures used to implement the PROPERTIES
|
|
|
|
function GetSignature: AnsiString;
|
|
function GetScreenDescriptor: PGifScreenDescriptor;
|
|
function GetImageCount: integer;
|
|
function GetImageDescriptor(image: integer): PGifImageDescriptor;
|
|
function GetBitmap(image: integer): TBitmap;
|
|
function GetColorTableCount: integer;
|
|
function GetColorTable(table: integer): PGifColorTable;
|
|
function GetImageDelay(Image: integer): integer; {LDB}
|
|
function GetImageDisposal(Image: integer): integer; {LDB}
|
|
function GetColorIndex(image, x, y: integer): integer;
|
|
function GetTransparentIndex(image: integer): integer;
|
|
function GetTransparentColor: TColor;
|
|
function GetImageLeft(image: integer): integer;
|
|
function GetImageTop(image: integer): integer;
|
|
function GetImageWidth(image: integer): integer;
|
|
function GetImageHeight(image: integer): integer;
|
|
function GetImageDepth(image: integer): integer;
|
|
|
|
// generally usefull routines
|
|
|
|
procedure FreeDataBlockList(var list: TList);
|
|
procedure FreeExtensionList(var list: TList);
|
|
procedure MakeBitmaps;
|
|
function FindGraphicExtension(image: integer): PGifExtensionGraphic;
|
|
function FindColorIndex(c: TColor; ct: PGifColorTable): integer;
|
|
procedure ExtractLoopCount(List: TList);
|
|
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure FreeImage;
|
|
|
|
procedure LoadFromStream(Source: TStream);
|
|
function GetStripBitmap(var Mask: TBitmap): TBitmap; {LDB}
|
|
|
|
property Signature: AnsiString read GetSignature;
|
|
property ScreenDescriptor: PGifScreenDescriptor read GetScreenDescriptor;
|
|
property ImageCount: integer read GetImageCount;
|
|
property ImageDescriptor[Image: integer]: PGifImageDescriptor read GetImageDescriptor;
|
|
property Bitmap[Image: integer]: TBitmap read GetBitmap;
|
|
property ColorTableCount: integer read GetColorTableCount;
|
|
property ColorTable[Table: integer]: PGifColorTable read GetColorTable;
|
|
property Height: integer read GetHeight;
|
|
property Width: integer read GetWidth ;
|
|
|
|
property ImageDelay[Image: integer]: integer read GetImageDelay;
|
|
property ImageDisposal[Image: integer]: integer read GetImageDisposal;
|
|
|
|
property Transparent: boolean read GetTransparent;
|
|
property TransparentIndex[Image: integer]: integer read GetTransparentIndex;
|
|
property TransparentColor: TColor read GetTransparentColor;
|
|
property ImageLeft[Image: integer]: integer read GetImageLeft;
|
|
property ImageTop[Image: integer]: integer read GetImageTop;
|
|
property ImageWidth[Image: integer]: integer read GetImageWidth;
|
|
property ImageHeight[Image: integer]: integer read GetImageHeight;
|
|
property ImageDepth[Image: integer]: integer read GetImageDepth;
|
|
property LoopCount: integer read FLoopCount;
|
|
|
|
end;
|
|
|
|
Function IntMax(A, B : Integer) : Integer;
|
|
|
|
implementation
|
|
// uses
|
|
// StdCtrls, ExtCtrls,
|
|
{$IFDEF UNICODE}
|
|
uses
|
|
AnsiStrings;
|
|
{$ENDIF UNICODE}
|
|
|
|
const
|
|
TransColor = $170725;
|
|
|
|
// GIF record separators
|
|
|
|
const
|
|
kGifImageSeparator: byte = $2c;
|
|
kGifExtensionSeparator: byte = $21;
|
|
kGifTerminator: byte = $3b;
|
|
kGifLabelGraphic: byte = $f9;
|
|
kGifLabelComment: byte = $fe;
|
|
kGifLabelText: byte = $01;
|
|
kGifLabelApplication: byte = $ff;
|
|
|
|
// define a set of error messages
|
|
|
|
const
|
|
kGifErrorMessages: array[0..27] of AnsiString = (
|
|
'no error', // 0
|
|
'Invalid GIF Signature Code', // 1
|
|
'No Local or Global Color Table for Image', // 2
|
|
'Unknown Graphics Extension Type', // 3
|
|
'Unknown Graphics Operation Code', // 4
|
|
'Invalid Extension Block Size', // 5
|
|
'[special message]', // 6
|
|
'Invalid Extension Block Terminator', // 7
|
|
'Invalid Integer Size', // 8
|
|
'No GIF Terminator Found', // 9
|
|
'Extension Block Out-Of-Order With Image Data', // 10
|
|
'Invalid Image Descriptor Index', // 11
|
|
'Invalid LZW Code Size', // 12
|
|
'Invalid LZW Data Format', // 13
|
|
'LZW Code Overflow', // 14
|
|
'Value Out Of Range', // 15
|
|
'NIL Pointer assigned', // 16
|
|
'Invalid Color Table Size', // 17
|
|
'No Image Description', // 18
|
|
'Invalid Bitmap Image', // 19
|
|
'Invalid Color Table Index', // 20
|
|
'Invalid Interlace Pass', // 21
|
|
'Invalid Bitmap', // 22
|
|
'Too Many Colors In Bitmap', // 23
|
|
'Unexpected end of file', // 24 {LDB}
|
|
'Animated GIF too large', // 25 {LDB}
|
|
'Zero width or height', // 26 {LDB}
|
|
'next message' //
|
|
);
|
|
|
|
var
|
|
GIF_ErrorCode: integer; // last error
|
|
GIF_ErrorString: String; // last error
|
|
|
|
Function IntMax(A, B : Integer) : Integer;
|
|
begin
|
|
if A > B then Result := A
|
|
else Result := B;
|
|
end;
|
|
|
|
procedure GIF_Error(n: integer); forward;
|
|
procedure GIF_ErrorMessage(m: string); forward;
|
|
|
|
procedure BoundGIFDelay(var Delay : integer);
|
|
begin
|
|
if (Delay <= 0) then
|
|
Delay := GIFDefaultDelay;
|
|
// Enforce minimum animation delay in compliance with Mozilla
|
|
if (Delay < GIFMinimumDelay) then
|
|
Delay := GIFMinimumDelay;
|
|
if (Delay > GIFMaximumDelay) then
|
|
Delay := GIFMaximumDelay;
|
|
// if (Speed <= 0) then
|
|
// Delay := GIFMaximumDelay;
|
|
// Delay := MulDiv(Delay * GIFDelayExp, 100, Speed)
|
|
end;
|
|
|
|
constructor TGif.Create;
|
|
begin
|
|
inherited Create;
|
|
|
|
// nothing defined yet
|
|
|
|
fIOStream := nil;
|
|
fDataStream := nil;
|
|
fDataStreamSize := 0;
|
|
fExtension := nil;
|
|
fSignature := nil;
|
|
fScreenDescriptor := nil;
|
|
fImageDescriptorList := nil;
|
|
fColorTableList := nil;
|
|
fPaletteList := nil;
|
|
fZipData := nil;
|
|
FLoopCount := -1; // -1 is no loop count entered
|
|
|
|
// some things, though, will always be needed
|
|
|
|
new(fSignature);
|
|
if (fSignature = nil) then OutOfMemoryError;
|
|
fSignature^.rSignature := '------';
|
|
|
|
new(fScreenDescriptor);
|
|
if (fScreenDescriptor = nil) then OutOfMemoryError;
|
|
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);
|
|
|
|
fImageDescriptorList := TList.Create;
|
|
fColorTableList := TList.Create;
|
|
fPaletteList := TList.Create;
|
|
|
|
end;
|
|
|
|
|
|
destructor TGif.Destroy;
|
|
begin
|
|
|
|
// clean up most of the data
|
|
|
|
FreeImage;
|
|
|
|
// and then the left-overs
|
|
|
|
dispose(fSignature);
|
|
dispose(fScreenDescriptor);
|
|
|
|
fImageDescriptorList.Free;
|
|
fColorTableList.Free;
|
|
fPaletteList.Free;
|
|
|
|
// and the ancestor
|
|
|
|
inherited;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ release all memory used to store image data }
|
|
|
|
procedure TGif.FreeImage;
|
|
var
|
|
i: integer;
|
|
id: PGifImageDescriptor;
|
|
ct: PGifColorTable;
|
|
begin
|
|
|
|
// temp input/output stream
|
|
|
|
if (fIOStream <> nil) then fIOStream.Free;
|
|
fIOStream := nil;
|
|
|
|
// temp encoded data
|
|
|
|
if (fDataStream <> nil) then fDataStream.Free;
|
|
fDataStream:= nil;
|
|
fDataStreamSize := 0;
|
|
// temp list of image extensions
|
|
|
|
if (fExtension <> nil) then FreeExtensionList(fExtension);
|
|
fExtension := nil;
|
|
|
|
// signature record stays, but is cleared
|
|
|
|
if (fSignature = nil) then new(fSignature);
|
|
fSignature^.rSignature := '------';
|
|
|
|
// ditto the screen descriptor
|
|
|
|
if (fScreenDescriptor = nil) then new(fScreenDescriptor);
|
|
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);
|
|
|
|
// delete all items from image list, but leave the list
|
|
|
|
if (fImageDescriptorList = nil) then fImageDescriptorList := TList.Create;
|
|
for i := 0 to (fImageDescriptorList.Count - 1) do
|
|
begin
|
|
id := fImageDescriptorList.Items[i];
|
|
if (id <> nil) then
|
|
begin
|
|
if (id^.rExtensionList <> nil) then FreeExtensionList(id^.rExtensionList);
|
|
if (id^.rPixelList <> nil) then freemem(id^.rPixelList);
|
|
if (id^.rBitmap <> nil) then id^.rBitmap.Free;
|
|
|
|
dispose(id);
|
|
end;
|
|
end;
|
|
fImageDescriptorList.Clear;
|
|
|
|
// release color tables, but keep the list
|
|
|
|
if (fColorTableList = nil) then fColorTableList := TList.Create;
|
|
for i := 0 to (fColorTableList.Count - 1) do
|
|
begin
|
|
ct := fColorTableList.Items[i];
|
|
if (ct <> nil) then dispose(ct);
|
|
end;
|
|
fColorTableList.Clear;
|
|
|
|
// once again, keep the palette list object, but not the data
|
|
|
|
if (fPaletteList = nil) then fPaletteList := TList.Create;
|
|
fPaletteList.Clear;
|
|
|
|
// don't need the zip/unzip data block
|
|
|
|
if (fZipData <> nil) then dispose(fZipData);
|
|
fZipData := nil;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ READ and WRITE A GIF ------------------------------------------------------- }
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read a GIF definition from a stream }
|
|
|
|
procedure TGif.LoadFromStream(Source: TStream);
|
|
var
|
|
done: boolean;
|
|
b: byte;
|
|
begin
|
|
|
|
// release old image that may be here ...
|
|
|
|
FreeImage;
|
|
|
|
// no error yet
|
|
|
|
GIF_ErrorCode := 0;
|
|
GIF_ErrorString := '';
|
|
|
|
// make a local copy of the source data
|
|
// memory streams are faster and easier to manipulate than file streams
|
|
|
|
fIOStream := TMemoryStream.Create;
|
|
Source.Position := 0;
|
|
fIOStream.LoadFromStream(Source);
|
|
|
|
// local temp vars
|
|
|
|
fDataStream := TMemoryStream.Create; // data to be un-zipped
|
|
fDataStreamSize := 0;
|
|
fExtension := nil; // extensions to an image
|
|
|
|
|
|
// read the signature GIF87A or GIF89A
|
|
|
|
ReadSignature;
|
|
|
|
// read the logical screen descriptor
|
|
|
|
ReadScreenDescriptor;
|
|
|
|
// read extensions and image data until end of file
|
|
|
|
done := false;
|
|
while (not done) do
|
|
try {LDB}
|
|
if (fIOStream.Position >= fIOStream.Size) then
|
|
//GIF_Error(9); {LDB}
|
|
b := 0 {LDB}
|
|
|
|
else fIOStream.Read(b, 1); {LDB} // image separator
|
|
|
|
if (b = 0) then // just skip this?
|
|
begin
|
|
b := 0;
|
|
Done := True; {LDB}
|
|
end
|
|
else if (b = kGifTerminator) then // got it all
|
|
begin
|
|
done := true;
|
|
end
|
|
else if (b = kGifImageSeparator) then // next bitmap
|
|
begin
|
|
ReadImageDescriptor;
|
|
end
|
|
else if (b = kGifExtensionSeparator) then // special operations
|
|
begin
|
|
ReadExtension(Done);
|
|
end
|
|
else // unknown
|
|
begin
|
|
GIF_Error(4);
|
|
end;
|
|
except {LDB}
|
|
if GetImageCount > 0 then
|
|
Done := True {use what images we have}
|
|
else
|
|
Raise;
|
|
end;
|
|
|
|
// must have an image
|
|
|
|
if (fImageDescriptorList.Count = 0) then GIF_Error(18);
|
|
|
|
// no longer need the source data in memory
|
|
|
|
fIOStream.Free;
|
|
fDataStream.Free;
|
|
fDataStreamSize := 0;
|
|
FreeExtensionList(fExtension);
|
|
|
|
fIOStream := nil;
|
|
fDataStream := nil;
|
|
fExtension := nil;
|
|
end;
|
|
|
|
|
|
function TGif.GetHeight: integer;
|
|
begin
|
|
GetHeight := fScreenDescriptor^.rHeight;
|
|
end;
|
|
|
|
function TGif.GetWidth: integer;
|
|
begin
|
|
GetWidth := fScreenDescriptor^.rWidth;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ TRANSPARENT is assument to be the same for all images; i.e., if the first }
|
|
{ image is transparent, they they are all transparent }
|
|
{ if SetTransparent(TRUE) then set default color index for transparent color }
|
|
{ this can be changed with TransparentColor after this call }
|
|
|
|
{LDB changed so that if any images are transparent, Transparent returns True}
|
|
function TGif.GetTransparent: boolean;
|
|
var
|
|
b: boolean;
|
|
gx: PGifExtensionGraphic;
|
|
i: integer;
|
|
begin
|
|
b := false;
|
|
for I := 0 to (fImageDescriptorList.Count - 1) do
|
|
begin
|
|
gx := FindGraphicExtension(I);
|
|
if (gx <> nil) then
|
|
b := gx^.rTransparentValid or b;
|
|
end;
|
|
|
|
GetTransparent := b;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ PROCEDURES TO READ A GIF FILE ---------------------------------------------- }
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read the GIF signature from the source stream }
|
|
{ this assumes the memory stream position is correct }
|
|
{ the signature is always 6 bytes, and must be either GIF87A or GIF89A }
|
|
|
|
procedure TGif.ReadSignature;
|
|
var
|
|
s: AnsiString;
|
|
begin
|
|
with fSignature^ do
|
|
begin
|
|
fIOStream.Read(rSignature, 6);
|
|
s := rSignature;
|
|
s := UpperCase(s);
|
|
if ((s <> AnsiString('GIF87A')) and (s <> AnsiString('GIF89A'))) then
|
|
GIF_Error(1);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read the GIF logical screen descriptor from the source stream }
|
|
{ this assumes the memory stream position is correct }
|
|
{ this always follows the GIF signature }
|
|
|
|
procedure TGif.ReadScreenDescriptor;
|
|
var
|
|
i,n: integer;
|
|
begin
|
|
with fScreenDescriptor^ do
|
|
begin
|
|
ReadSourceInteger(2, rWidth); // logical screen width
|
|
ReadSourceInteger(2, rHeight); // logical screen height
|
|
|
|
ReadSourceInteger(1, n); // packed bit fields
|
|
rGlobalColorValid := ((n and $80) <> 0);
|
|
rColorResolution := ((n shr 4) and $07) + 1;
|
|
rSorted := ((n and $08) <> 0);
|
|
|
|
i := (n and $07);
|
|
if (i = 0) then rGlobalColorSize := 2
|
|
else if (i = 1) then rGlobalColorSize := 4
|
|
else if (i = 2) then rGlobalColorSize := 8
|
|
else if (i = 3) then rGlobalColorSize := 16
|
|
else if (i = 4) then rGlobalColorSize := 32
|
|
else if (i = 5) then rGlobalColorSize := 64
|
|
else if (i = 6) then rGlobalColorSize := 128
|
|
else if (i = 7) then rGlobalColorSize := 256
|
|
else rGlobalColorSize := 256;
|
|
|
|
|
|
ReadSourceInteger(1, rBackgroundIndex); // background color
|
|
ReadSourceInteger(1, rAspectRatio); // pixel aspect ratio
|
|
|
|
// read the global color table from the source stream
|
|
// this assumes the memory stream position is correct
|
|
// the global color table is only valid if a flag is set in the logical
|
|
// screen descriptor. if the flag is set, the global color table will
|
|
// immediately follow the logical screen descriptor
|
|
|
|
rGlobalColorTable := -1;
|
|
if (rGlobalColorValid) then // a global color table?
|
|
ReadColorTable(rGlobalColorSize, rGlobalColorTable)
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read in any type of color table }
|
|
{ number of RGB entries is given by SIZE, and save the index into the }
|
|
{ master color table list in TABLE }
|
|
{ if SIZE is <= 0, then there is no table, and the TABLE becomes -1 }
|
|
|
|
procedure TGif.ReadColorTable(Size: integer; var Table: integer);
|
|
var
|
|
i,n: integer;
|
|
r,g,b: byte;
|
|
ct: PGifColorTable;
|
|
begin
|
|
Table := -1; // assume no table
|
|
if (Size > 0) then // OK, a table does exist
|
|
begin
|
|
new(ct); // make a anew color table
|
|
if (ct = nil) then OutOfMemoryError;
|
|
n := fColorTableList.Add(ct); // save it in master list
|
|
Table := n; // save index for a valid table
|
|
|
|
ct^.rSize := Size;
|
|
|
|
for i := 0 to (ct^.rSize-1) do // read a triplet for each TColor
|
|
begin
|
|
fIOStream.Read(r, 1); // red
|
|
fIOStream.Read(g, 1); // green
|
|
fIOStream.Read(b, 1); // blue
|
|
|
|
ct^.rColors[i] := r or (g shl 8) or (b shl 16);
|
|
end;
|
|
|
|
// make sure we store palette handle in same index slot as the color table
|
|
|
|
while (fPaletteList.Count < fColorTableList.Count) do fPaletteList.Add(nil);
|
|
fPaletteList.Items[Table] := Nil;
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read the next image descriptor }
|
|
{ the source stream position should be immediately following the }
|
|
{ special code image separator }
|
|
{ note: this routine only reads in the raw data; the LZW de-compression }
|
|
{ occurs later, after all the data has been read }
|
|
{ this probably makes for a bigger data chunk, but it doesn't much effect }
|
|
{ the speed, and it is certainly a more modular approach and is much easier }
|
|
{ to understand the mechanics later }
|
|
|
|
procedure TGif.ReadImageDescriptor;
|
|
var
|
|
i,n: integer;
|
|
ix: integer;
|
|
id: PGifImageDescriptor;
|
|
db: TGifDataBlock;
|
|
begin
|
|
|
|
// make a new image desctiptor record and add this record to main list
|
|
|
|
new(id);
|
|
if (id = nil) then OutOfMemoryError;
|
|
if (fImageDescriptorList = nil) then fImageDescriptorList := TList.Create;
|
|
ix := fImageDescriptorList.Add(id);
|
|
id^.rIndex := ix;
|
|
|
|
// initialize data
|
|
|
|
fillchar(id^, sizeof(TGifImageDescriptor), 0);
|
|
|
|
// init the sotrage for compressed data
|
|
|
|
fDataStream.Clear;
|
|
fDataStreamSize := 0;
|
|
|
|
// if extensions were read in earlier, save that list
|
|
// for this image descriptor
|
|
// if no extensions were read in, then we don't need this list at all
|
|
|
|
if (fExtension <> nil) then
|
|
begin
|
|
id^.rExtensionList := fExtension;
|
|
fExtension := nil;
|
|
end;
|
|
|
|
// shortcut to the record fields
|
|
|
|
with id^ do
|
|
begin
|
|
|
|
// read the basic descriptor record
|
|
|
|
ReadSourceInteger(2, rLeft); // left position
|
|
ReadSourceInteger(2, rTop); // top position
|
|
ReadSourceInteger(2, rWidth); // size of image
|
|
ReadSourceInteger(2, rHeight); // size of image
|
|
|
|
if rHeight > Height then {LDB make sure bad values don't overflow elsewhere}
|
|
rHeight := Height;
|
|
|
|
ReadSourceInteger(1, n); // packed bit field
|
|
rLocalColorValid := ((n and $80) <> 0);
|
|
rInterlaced := ((n and $40) <> 0);
|
|
rSorted := ((n and $20) <> 0);
|
|
|
|
i := (n and $07);
|
|
if (i = 0) then rLocalColorSize := 2
|
|
else if (i = 1) then rLocalColorSize := 4
|
|
else if (i = 2) then rLocalColorSize := 8
|
|
else if (i = 3) then rLocalColorSize := 16
|
|
else if (i = 4) then rLocalColorSize := 32
|
|
else if (i = 5) then rLocalColorSize := 64
|
|
else if (i = 6) then rLocalColorSize := 128
|
|
else if (i = 7) then rLocalColorSize := 256
|
|
else rLocalColorSize := 256;
|
|
|
|
|
|
// if a local color table is defined, read it
|
|
// otherwise, use the global color table
|
|
|
|
if (rLocalColorValid) then ReadColorTable(rLocalColorSize, rLocalColorTable)
|
|
else rLocalColorTable := fScreenDescriptor^.rGlobalColorTable;
|
|
|
|
// _something_ must have defined by now ...
|
|
|
|
if (rLocalColorTable < 0) then GIF_Error(2);
|
|
|
|
// the LZW minimum code size
|
|
|
|
ReadSourceInteger(1, rLZWSize);
|
|
|
|
// read data blocks until the end of the list
|
|
|
|
ReadSourceInteger(1, db.rSize);
|
|
while (db.rSize > 0) do
|
|
begin
|
|
if fIOStream.Read(db.rData, db.rSize) < db.rSize then
|
|
Gif_Error(24); {LDB}
|
|
fDataStream.Write(db.rData, db.rSize);
|
|
fDataStreamSize := fDataStream.Size;
|
|
ReadSourceInteger(1, db.rSize);
|
|
end;
|
|
|
|
// save the pixel list
|
|
|
|
rPixelCount := rWidth * rHeight;
|
|
if rPixelCount = 0 then {LDB}
|
|
Gif_Error(26);
|
|
rPixelList := allocmem(rPixelCount);
|
|
if (rPixelList = nil) then
|
|
OutOfMemoryError;
|
|
|
|
// uncompress the data and write the bitmap
|
|
|
|
LZWDecode(id);
|
|
end; // with id^
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read in a group of data blocks until a zero-length block is found }
|
|
{ store the data on the give TList }
|
|
|
|
procedure TGif.ReadDataBlockList(List: TList);
|
|
var
|
|
b: byte;
|
|
db: PGifDataBlock;
|
|
BytesRead: integer;
|
|
begin
|
|
|
|
// read data blocks until the end of the list
|
|
|
|
fIOStream.Read(b, 1); // size of next block
|
|
while (b > 0) do // more blocks to get?
|
|
begin
|
|
new(db); // new data block record
|
|
db^.rSize := b;
|
|
BytesRead := fIOStream.Read(db^.rData, db^.rSize); // read the data
|
|
List.Add(db); // save in given list
|
|
|
|
if BytesRead < db^.rSize then
|
|
Gif_Error(24); {LDB}
|
|
fIOStream.Read(b, 1); // size of next block
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read in any type of extension record }
|
|
{ assume that the source position is AFTER the extension separator, }
|
|
{ but BEFORE the specific extension label }
|
|
{ the extension record we read in is stored in the master extension }
|
|
{ list; however, the indexes for these exrtensions is stored in a }
|
|
{ temporary list which will be assigned to the next image descriptor }
|
|
{ record read in. this is because all extension blocks preceed the }
|
|
{ image descriptor to which they belong }
|
|
|
|
procedure TGif.ReadExtension(var Done: boolean);
|
|
var
|
|
n: integer;
|
|
b: byte;
|
|
eb: PGifExtension;
|
|
begin
|
|
|
|
// make a list exists
|
|
|
|
if (fExtension = nil) then fExtension := TList.Create;
|
|
|
|
// make a new extension record and add it to temp holding list
|
|
|
|
new(eb);
|
|
if (eb = nil) then OutOfMemoryError;
|
|
fillchar(eb^, sizeof(TGifExtension), 0);
|
|
fExtension.Add(eb);
|
|
|
|
// get the type of extension
|
|
|
|
fIOStream.Read(b, 1);
|
|
eb^.rLabel := b;
|
|
|
|
// "with eb^" gives us access to rGraphic, rText, rComment, and rApp
|
|
|
|
with eb^ do
|
|
begin
|
|
|
|
// a graphic extension
|
|
|
|
if (rLabel = kGifLabelGraphic) then
|
|
begin
|
|
ReadSourceInteger(1, rGraphic.rBlockSize); // block size
|
|
if (rGraphic.rBlockSize <> 4) then GIF_Error(5);
|
|
|
|
ReadSourceInteger(1, n); // packed bit field
|
|
rGraphic.rDisposal := ((n shr 2) and $07);
|
|
rGraphic.rUserInputValid := ((n and $02) <> 0);
|
|
rGraphic.rTransparentValid := ((n and $01) <> 0);
|
|
|
|
ReadSourceInteger(2, rGraphic.rDelayTime); // delay time
|
|
BoundGIFDelay(rGraphic.rDelayTime);
|
|
ReadSourceInteger(1, rGraphic.rTransparentIndex); // transparent color
|
|
ReadSourceInteger(1, n); // block terminator
|
|
if (n <> 0) then GIF_Error(7);
|
|
end
|
|
|
|
// a comment extension
|
|
|
|
else if (rLabel = kGifLabelComment) then
|
|
begin
|
|
rComment.rDataBlockList := TList.Create;
|
|
ReadDataBlockList(rComment.rDataBlockList);
|
|
end
|
|
|
|
// a plain text extension
|
|
|
|
else if (rLabel = kGifLabelText) then
|
|
begin
|
|
ReadSourceInteger(1, rText.rBlockSize); // block size
|
|
if (rText.rBlockSize <> 12) then GIF_Error(5);
|
|
ReadSourceInteger(2, rText.rGridLeft); // grid position
|
|
ReadSourceInteger(2, rText.rGridTop); // grid position
|
|
ReadSourceInteger(2, rText.rGridWidth); // grid size
|
|
ReadSourceInteger(2, rText.rGridHeight); // grid size
|
|
ReadSourceInteger(1, rText.rCellWidth); // character cell size {LDB}{was 2 bytes}
|
|
ReadSourceInteger(1, rText.rCellHeight); // character cell size
|
|
ReadSourceInteger(1, rText.rForegroundIndex); // foreground color
|
|
ReadSourceInteger(1, rText.rBackgroundIndex); // background color
|
|
rText.rDataBlockList := TList.Create; // list of text data blocks
|
|
ReadDataBlockList(rText.rDataBlockList);
|
|
end
|
|
|
|
// an application extension
|
|
|
|
else if (rLabel = kGifLabelApplication) then
|
|
begin
|
|
ReadSourceInteger(1, rApp.rBlockSize); // block size
|
|
if (rApp.rBlockSize <> 11) then //GIF_Error(5); {LDB} allow other blocksizes
|
|
begin
|
|
fIOStream.Position := fIOStream.Position+rApp.rBlockSize;
|
|
rApp.rDataBlockList := TList.Create;
|
|
ReadDataBlockList(rApp.rDataBlockList);
|
|
end
|
|
else
|
|
begin
|
|
fIOStream.Read(rApp.rIdentifier, 8); // application identifier
|
|
fIOStream.Read(rApp.rAuthentication, 3); // authentication code
|
|
rApp.rDataBlockList := TList.Create;
|
|
ReadDataBlockList(rApp.rDataBlockList);
|
|
if rApp.rIdentifier = 'NETSCAPE' then
|
|
ExtractLoopCount(rApp.rDataBlockList);
|
|
end;
|
|
end
|
|
|
|
// unknown type
|
|
|
|
else
|
|
begin
|
|
GIF_ErrorMessage('unknown extension: ' + IntToHex(rLabel, 4));
|
|
end;
|
|
end; // with eb^
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ read a 1 or 2-byte integer from the source stream }
|
|
|
|
procedure TGif.ReadSourceInteger(size: integer; var value: integer);
|
|
var
|
|
b: byte;
|
|
w: word;
|
|
begin
|
|
if (size = 1) then
|
|
begin
|
|
fIOStream.Read(b, 1);
|
|
value := b;
|
|
end
|
|
else if (size = 2) then
|
|
begin
|
|
fIOStream.Read(w, 2);
|
|
value := w;
|
|
end
|
|
else
|
|
begin
|
|
GIF_Error(8);
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ decode the compressed data blocks into a bitmap }
|
|
|
|
procedure TGif.LZWDecode(pID: PGifImageDescriptor);
|
|
var
|
|
pc: integer; // next compressed code parsed from input
|
|
cc: integer; // current code to translate
|
|
oc: integer; // old code translated
|
|
tt: integer; // temp storage for OldCode
|
|
Done: boolean;
|
|
begin
|
|
|
|
// init local data
|
|
|
|
LZWInit(pID);
|
|
LZWReset;
|
|
|
|
// do everything within the ZIP record
|
|
|
|
with fZipData^ do
|
|
begin
|
|
|
|
// parse next code from BitString
|
|
|
|
pc := LZWGetCode;
|
|
oc := pc;
|
|
Done := False;
|
|
while (pc <> rEndCode) and not Done do
|
|
begin
|
|
|
|
// reset decode parameters and save first code
|
|
|
|
if (pc = rClearCode) then
|
|
begin
|
|
rCurSize := rID^.rLZWSize + 1;
|
|
rCurSlot := rEndCode + 1;
|
|
rTopSlot := (1 shl rCurSize);
|
|
while (pc = rClearCode) do pc := LZWGetCode;
|
|
if (pc = rEndCode) then
|
|
GIF_Error(13);
|
|
if (pc >= rCurSlot) then pc := 0;
|
|
oc := pc;
|
|
LZWSaveCode(pc);
|
|
end
|
|
|
|
// find a code in the table and write out translation
|
|
|
|
else
|
|
begin
|
|
cc := pc;
|
|
if (cc < rCurSlot) then
|
|
begin
|
|
LZWDecodeCode(cc);
|
|
if (rCurSlot <= rTopSlot) then
|
|
begin
|
|
LZWSaveSlot(oc, cc);
|
|
oc := pc;
|
|
end;
|
|
LZWCheckSlot;
|
|
end
|
|
|
|
// add a new code to the decode table
|
|
|
|
else
|
|
begin
|
|
if (cc <> rCurSlot) then GIF_Error(13);
|
|
tt := oc;
|
|
while (oc > rHighCode) do oc := rPrefix[oc];
|
|
if (rCurSlot <= rTopSlot) then LZWSaveSlot(tt, oc);
|
|
LZWCheckSlot;
|
|
LZWDecodeCode(cc);
|
|
oc := pc;
|
|
end;
|
|
end;
|
|
|
|
// write out translated bytes to the image storage
|
|
|
|
LZWWriteBitmap;
|
|
// if fDataStream.Position < fDataStreamSize then
|
|
if fDataStream.Seek(0, soFromCurrent) < fDataStreamSize then
|
|
pc := LZWGetCode
|
|
else Done := True;
|
|
rMaxVal := false;
|
|
|
|
end; // while not EOI
|
|
|
|
end; // with
|
|
|
|
// done with stack space
|
|
|
|
LZWFinit;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
procedure TGif.LZWInit(pID: PGifImageDescriptor);
|
|
begin
|
|
|
|
// get a valid record?
|
|
|
|
if (pID = nil) then GIF_Error(11);
|
|
|
|
// make sure we can actually decode this turkey
|
|
|
|
// if ((pID^.rLZWSize < 2) or (pID^.rLZWSize > 9)) then GIF_Error(12);
|
|
|
|
// allocate stack space
|
|
|
|
new(fZipData);
|
|
if (fZipData = nil) then OutOfMemoryError;
|
|
|
|
// init data block
|
|
|
|
fillchar(fZipData^, sizeof(TGifZip), 0);
|
|
fZipData^.rID := pID;
|
|
fZipData^.rCT := fColorTableList.Items[pID^.rLocalColorTable];
|
|
|
|
// reset data stream
|
|
|
|
fDataStream.Position := 0;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
procedure TGif.LZWFinit;
|
|
begin
|
|
if (fZipData <> nil) then dispose(fZipData);
|
|
fZipData := nil;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
procedure TGif.LZWReset;
|
|
//var
|
|
// i: integer;
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
FillMemory(@rPrefix[0], kGifCodeTableSize * SizeOf(Integer), 0); // By Rapid D
|
|
FillMemory(@rSuffix[0], Length(rSuffix) * SizeOf(Integer), 0); // By Rapid D
|
|
{ for i := 0 to (kGifCodeTableSize - 1) do
|
|
begin
|
|
rPrefix[i] := 0;
|
|
rSuffix[i] := 0;
|
|
end;
|
|
}
|
|
rCurSize := rID^.rLZWSize + 1;
|
|
rClearCode := (1 shl rID^.rLZWSize);
|
|
rEndCode := rClearCode + 1;
|
|
rHighCode := rClearCode - 1;
|
|
rFirstSlot := (1 shl (rCurSize - 1)) + 2;
|
|
rNextSlot := rFirstSlot;
|
|
rMaxVal := false;
|
|
end; // with
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ get the next code from the BitString }
|
|
{ CurrentSize specifies the number of bits to get }
|
|
|
|
function TGif.LZWGetCode: integer;
|
|
const
|
|
cMasks : array[0..12] of integer = (0, $0001, $0003, $0007, $000f, $001f, $003f,
|
|
$007f, $00ff, $01ff, $03ff, $07ff, $0fff); // By Rapid D
|
|
var
|
|
n: integer;
|
|
cc: integer;
|
|
mask: integer;
|
|
b: byte;
|
|
curPos : Int64; // Added by Rapid D For Optimization!
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
|
|
// make sure we have enough bits
|
|
// curPos := fDataStream.Position; // Added by Rapid D
|
|
curPos := fDataStream.Seek(0, soFromCurrent); // Added by Rapid D For Optimization!
|
|
while (rCurSize > rBits) do
|
|
begin
|
|
// if (fDataStream.Position >= fDataStreamSize) then // Commented by Rapid D
|
|
if (curPos >= fDataStreamSize) then // Added by Rapid D For Optimization!
|
|
b := 0
|
|
else
|
|
begin
|
|
fDataStream.Read(b, 1);
|
|
inc(curPos);
|
|
end;
|
|
n := b;
|
|
n := (n shl rBits); // scoot bits over to avoid previous data
|
|
rBitString := (rBitString or n); // put bits in the BitString
|
|
inc(rBits, 8); // number of bits in a byte
|
|
end;
|
|
|
|
|
|
// get the code, then dump the bits we used from the BitString
|
|
if rCurSize in [0..12] then
|
|
mask := cMasks[rCurSize]
|
|
else
|
|
|
|
{ case rCurSize of
|
|
0: mask := 0;
|
|
1: mask := $0001;
|
|
2: mask := $0003;
|
|
3: mask := $0007;
|
|
4: mask := $000f;
|
|
5: mask := $001f;
|
|
6: mask := $003f;
|
|
7: mask := $007f;
|
|
8: mask := $00ff;
|
|
9: mask := $01ff;
|
|
10: mask := $03ff;
|
|
11: mask := $07ff;
|
|
12: mask := $0fff;
|
|
else}
|
|
begin
|
|
GIF_Error(12);
|
|
Mask := 0; //stop warning
|
|
end;
|
|
// end;
|
|
|
|
cc := (rBitString and mask); // mask off bits wanted
|
|
rBitString := (rBitString shr rCurSize); // delete bits we just took
|
|
dec(rBits, rCurSize); // number of bits left in BitString
|
|
end; // with
|
|
|
|
// done
|
|
|
|
LZWGetCode := cc;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ save a code value on the code stack }
|
|
|
|
procedure TGif.LZWSaveCode(Code: integer);
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
rCodeStack[rSP] := Code;
|
|
inc(rSP);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ decode the CurrentCode into the clear-text pixel value }
|
|
{ mainly, just save the CurrentCode on the output stack, along with }
|
|
{ whatever prefixes go with it }
|
|
|
|
procedure TGif.LZWDecodeCode(var Code: integer);
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
while (Code > rHighCode) do
|
|
begin
|
|
LZWSaveCode(rSuffix[Code]);
|
|
Code := rPrefix[Code];
|
|
end;
|
|
LZWSaveCode(Code);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ save a new prefix/suffix pair }
|
|
|
|
procedure TGif.LZWSaveSlot(Prefix, Suffix: integer);
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
rPrefix[rCurSlot] := Prefix;
|
|
rSuffix[rCurSlot] := Suffix;
|
|
rCurSlot := rCurSlot + 1;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ given current line number, compute the next line to be filled }
|
|
{ this gets a little tricky if an interlaced image }
|
|
{ what is the purpose of this interlace, anyway? it doesn't save space, }
|
|
{ and I can't imagine it makes for any faster image disply or loading }
|
|
|
|
procedure TGif.LZWIncrPosition;
|
|
var
|
|
n: integer;
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
|
|
// if first pass, make sure CurPass was initialized
|
|
|
|
if (rCurPass = 0) then rCurPass := 1;
|
|
|
|
// incr X position
|
|
|
|
inc(rCurX);
|
|
|
|
// bumping Y ?
|
|
|
|
if (rCurX >= rID^.rWidth) then
|
|
begin
|
|
rCurX := 0;
|
|
|
|
// if not interlaced image, then just move down the page
|
|
|
|
if (not rID^.rInterlaced) then
|
|
begin
|
|
inc(rCurY);
|
|
end
|
|
|
|
// interlaced images select the next line by some archane black-magical sheme
|
|
|
|
else
|
|
begin
|
|
case rCurPass of // delta to next row on this pass
|
|
1, 2: n := 8;
|
|
// 2: n := 8;
|
|
3: n := 4;
|
|
4: n := 2;
|
|
else
|
|
begin
|
|
GIF_Error(21);
|
|
n := 0; //prevent warning
|
|
end;
|
|
end;
|
|
|
|
inc(rCurY, n);
|
|
|
|
// if past the end of the bitmap, start next pass
|
|
|
|
if (rCurY >= rID^.rHeight) then
|
|
begin
|
|
inc(rCurPass);
|
|
if (rCurPass = 5) then rCurPass := 1;
|
|
case rCurPass of // first line for given pass
|
|
1: n := 0;
|
|
2: n := 4;
|
|
3: n := 2;
|
|
4: n := 1;
|
|
else GIF_Error(21);
|
|
end;
|
|
|
|
rCurY := n;
|
|
end;
|
|
end;
|
|
end;
|
|
end; // with
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ see if it is time to add a new slot to the decoder tables }
|
|
|
|
procedure TGif.LZWCheckSlot;
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
if (rCurSlot >= rTopSlot) then
|
|
begin
|
|
if (rCurSize < 12) then
|
|
begin
|
|
rTopSlot := (rTopSlot shl 1);
|
|
rCurSize := rCurSize + 1;
|
|
end
|
|
else
|
|
begin
|
|
rMaxVal := true;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ empty the Codes stack and write to the Bitmap }
|
|
|
|
procedure TGif.LZWWriteBitmap;
|
|
var
|
|
i,n: integer;
|
|
j: longint;
|
|
p: PByte;
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
for n := (rSP - 1) downto 0 do
|
|
begin
|
|
inc(rCount);
|
|
|
|
// get next code from the stack, and index into PixelList
|
|
|
|
i := rCodeStack[n];
|
|
j := (rCurY * rID^.rWidth) + rCurX;
|
|
if ((0 <= j) and (j < rID^.rPixelCount)) then
|
|
begin
|
|
|
|
// store the pixel index into PixelList
|
|
|
|
p := rID^.rPixelList + j;
|
|
p^ := byte(i);
|
|
end;
|
|
|
|
LZWIncrPosition;
|
|
end;
|
|
|
|
rSP := 0;
|
|
end; // with
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ get the next pixel from the bitmap, and return it as an index into }
|
|
{ the colormap }
|
|
|
|
function TGif.LZWReadBitmap: integer;
|
|
var
|
|
n: integer;
|
|
j: longint;
|
|
p: PByte;
|
|
begin
|
|
with fZipData^ do
|
|
begin
|
|
if (rUnget) then
|
|
begin
|
|
n := rLast;
|
|
rUnget := false;
|
|
end
|
|
else
|
|
begin
|
|
inc(rCount);
|
|
j := (rCurY * rID^.rWidth) + rCurX;
|
|
if ((0 <= j) and (j < rID^.rPixelCount)) then
|
|
begin
|
|
p := rID^.rPixelList + j;
|
|
n := byte(p^);
|
|
end
|
|
else
|
|
begin
|
|
n := 0;
|
|
end;
|
|
|
|
LZWIncrPosition;
|
|
end;
|
|
|
|
rLast := n;
|
|
end; // with
|
|
|
|
LZWReadBitmap := n;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ PROCEDURES TO IMPLEMENT PROPERTIES ----------------------------------------- }
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetSignature: AnsiString;
|
|
var
|
|
s: AnsiString;
|
|
begin
|
|
s := fSignature^.rSignature;
|
|
GetSignature := s;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ return screen descriptor data pointer, or set a new record block }
|
|
|
|
function TGif.GetScreenDescriptor: PGifScreenDescriptor;
|
|
begin
|
|
GetScreenDescriptor := fScreenDescriptor;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetImageCount: integer;
|
|
begin
|
|
GetImageCount := fImageDescriptorList.Count;
|
|
end;
|
|
|
|
|
|
function TGif.GetImageDescriptor(image: integer): PGifImageDescriptor;
|
|
begin
|
|
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
|
|
GetImageDescriptor := fImageDescriptorList.Items[image];
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetBitmap(image: integer): TBitmap;
|
|
var
|
|
p: PGifImageDescriptor;
|
|
b: TBitmap;
|
|
begin
|
|
p := GetImageDescriptor(image);
|
|
if (p^.rBitmap = nil) then MakeBitmaps;
|
|
b := p^.rBitmap;
|
|
|
|
GetBitmap := b;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetColorTableCount: integer;
|
|
begin
|
|
GetColorTableCount := fColorTableList.Count;
|
|
end;
|
|
|
|
|
|
function TGif.GetColorTable(table: integer): PGifColorTable;
|
|
begin
|
|
if ((table < 0) or (table >= fColorTableList.Count)) then GIF_Error(15);
|
|
GetColorTable := fColorTableList.Items[table];
|
|
end;
|
|
|
|
function TGif.GetImageDelay(Image: integer): integer;
|
|
var
|
|
gx: PGifExtensionGraphic;
|
|
begin
|
|
gx := FindGraphicExtension(Image);
|
|
if (gx <> nil) then
|
|
begin
|
|
Result := gx^.rDelayTime;
|
|
if Result < 1 then
|
|
Result := 1;
|
|
end
|
|
else Result := 1;
|
|
end;
|
|
|
|
function TGif.GetImageDisposal(Image: integer): integer;
|
|
var
|
|
gx: PGifExtensionGraphic;
|
|
begin
|
|
gx := FindGraphicExtension(Image);
|
|
if (gx <> nil) then
|
|
Result := gx^.rDisposal and 3
|
|
else Result := 0;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetColorIndex(image, x, y: integer): integer;
|
|
var
|
|
i,n: integer;
|
|
id: PGifImageDescriptor;
|
|
p: PByte;
|
|
begin
|
|
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
|
|
id := fImageDescriptorList.Items[image];
|
|
if ((x < 0) or (x >= id^.rWidth)) then GIF_Error(15);
|
|
if ((y < 0) or (y >= id^.rHeight)) then GIF_Error(15);
|
|
|
|
n := (y * id^.rWidth) + x;
|
|
p := id^.rPixelList + n;
|
|
i := byte(p^);
|
|
|
|
GetColorIndex := i;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ transparent color for each individual image.
|
|
returns -1 if none. }
|
|
|
|
function TGif.GetTransparentIndex(image: integer): integer;
|
|
var
|
|
i: integer;
|
|
gx: PGifExtensionGraphic;
|
|
begin
|
|
i := -1;
|
|
gx := FindGraphicExtension(image);
|
|
if (gx <> nil) and (gx^.rTransparentValid) then {LDB}
|
|
i := gx^.rTransparentIndex;
|
|
|
|
GetTransparentIndex := i;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ transparent color for all images }
|
|
{LDB Changed to always return the standard used for the transparent color}
|
|
|
|
function TGif.GetTransparentColor: TColor;
|
|
begin
|
|
GetTransparentColor := TransColor;
|
|
end;
|
|
|
|
procedure TGif.ExtractLoopCount(List: TList);
|
|
begin
|
|
if List.Count > 0 then
|
|
with PGifDataBlock(List[0])^ do
|
|
if rSize = 3 then
|
|
FLoopCount := rData[2] + rData[3]*256;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
function TGif.GetImageLeft(image: integer): integer;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
begin
|
|
id := GetImageDescriptor(image);
|
|
GetImageLeft := id^.rLeft;
|
|
end;
|
|
|
|
function TGif.GetImageTop(image: integer): integer;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
begin
|
|
id := GetImageDescriptor(image);
|
|
GetImageTop := id^.rTop;
|
|
end;
|
|
|
|
function TGif.GetImageWidth(image: integer): integer;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
begin
|
|
id := GetImageDescriptor(image);
|
|
GetImageWidth := id^.rWidth;
|
|
end;
|
|
|
|
function TGif.GetImageHeight(image: integer): integer;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
begin
|
|
id := GetImageDescriptor(image);
|
|
GetImageHeight := id^.rHeight;
|
|
end;
|
|
|
|
function TGif.GetImageDepth(image: integer): integer;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
ct: PGifColorTable;
|
|
begin
|
|
id := GetImageDescriptor(image);
|
|
ct := fColorTableList.Items[id^.rLocalColorTable];
|
|
GetImageDepth := ct^.rSize;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ GENERAL INTERNAL ROUTINES -------------------------------------------------- }
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
procedure TGif.FreeDataBlockList(var list: TList);
|
|
var
|
|
i: integer;
|
|
db: PGifDataBlock;
|
|
begin
|
|
if (list <> nil) then
|
|
begin
|
|
for i := 0 to (list.Count - 1) do
|
|
begin
|
|
db := list.Items[i];
|
|
if (db <> nil) then dispose(db);
|
|
end;
|
|
|
|
list.Free;
|
|
end;
|
|
|
|
list := nil;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
|
|
procedure TGif.FreeExtensionList(var list: TList);
|
|
var
|
|
i: integer;
|
|
ex: PGifExtension;
|
|
begin
|
|
if (list <> nil) then
|
|
begin
|
|
for i := 0 to (list.Count - 1) do
|
|
begin
|
|
ex := list.Items[i];
|
|
if (ex <> nil) then
|
|
begin
|
|
if (ex^.rLabel = kGifLabelComment) then FreeDataBlockList(ex^.rComment.rDataBlockList)
|
|
else if (ex^.rLabel = kGifLabelText) then FreeDataBlockList(ex^.rText.rDataBlockList)
|
|
else if (ex^.rLabel = kGifLabelApplication) then FreeDataBlockList(ex^.rApp.rDataBlockList);
|
|
|
|
dispose(ex);
|
|
end;
|
|
end;
|
|
|
|
list.Free;
|
|
end;
|
|
|
|
list := nil;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ after an image has been LZW decoded, write a bitmap from the string of pixels }
|
|
|
|
{----------------TGif.MakeBitmaps}
|
|
procedure TGif.MakeBitmaps;
|
|
type
|
|
LayoutType = Packed Record
|
|
BFH: TBitmapFileHeader;
|
|
BIH: TBitmapInfoHeader;
|
|
end;
|
|
PLayoutType = ^LayoutType;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
ct: PGifColorTable;
|
|
FullWidth, PixelSize, FileSize: integer;
|
|
Stream: TMemoryStream;
|
|
PL: PLayoutType;
|
|
Color: TColor;
|
|
Index: integer;
|
|
Pix, P: PByte;
|
|
I, X, Y, N: integer;
|
|
TrIndex: integer;
|
|
begin
|
|
for i := 0 to (fImageDescriptorList.Count - 1) do
|
|
begin
|
|
id := fImageDescriptorList.Items[i];
|
|
if ((id <> nil) and (id^.rBitmap = nil)) then // don't do it again
|
|
with id^ do
|
|
begin
|
|
FullWidth := rWidth * 3;
|
|
if FullWidth and $3 <> 0 then
|
|
FullWidth := (FullWidth and $FFFFFFFC) + $4;
|
|
PixelSize := FullWidth * rHeight;
|
|
FileSize := Sizeof(LayoutType)+PixelSize;
|
|
Stream := TMemoryStream.Create;
|
|
try
|
|
Stream.Size := FileSize;
|
|
PL := Stream.Memory;
|
|
FillChar(PL^, FileSize, 0);
|
|
|
|
with PL^.BFH do
|
|
begin
|
|
bfType := 19778;
|
|
bfSize := FileSize;
|
|
bfReserved1 := 0;
|
|
bfReserved2 := 0;
|
|
bfOffBits := Sizeof(LayoutType);
|
|
end;
|
|
with PL^.BIH do
|
|
begin
|
|
biSize := Sizeof(TBitmapInfoHeader);
|
|
biWidth := rWidth;
|
|
biHeight := rHeight;
|
|
biPlanes := 1;
|
|
biBitCount := 24;
|
|
biCompression := 0;
|
|
biSizeImage := 0;
|
|
biXPelsPerMeter := 0;
|
|
biYPelsPerMeter := 0;
|
|
biClrUsed := 0;
|
|
biClrImportant := 0;
|
|
end;
|
|
|
|
ct := fColorTableList.Items[rLocalColorTable];
|
|
TrIndex := GetTransparentIndex(i);
|
|
if (TrIndex >= 0) and (TrIndex < ct^.rSize) then
|
|
{change transparent color to something that won't likely match any other color}
|
|
ct^.rColors[TrIndex] := TransColor;
|
|
|
|
N := 0;
|
|
// Pix := PByte(PL) + Sizeof(LayoutType);
|
|
Pix := PByte(PL) + Sizeof(LayoutType);
|
|
for Y := rHeight-1 downto 0 do
|
|
begin
|
|
P := PByte(Pix) + (Y * FullWidth);
|
|
for X := 0 to rWidth-1 do
|
|
begin
|
|
Index := Integer((PByte(rPixelList) + N)^);
|
|
Color := ct^.rColors[Index];
|
|
P^ := Byte((Color shr 16) and $FF);
|
|
Inc(P);
|
|
P^ := Byte((Color shr 8) and $FF);
|
|
Inc(P);
|
|
P^ := Byte(Color and $FF);
|
|
Inc(P);
|
|
Inc(N);
|
|
end;
|
|
end;
|
|
rBitmap := TBitmap.Create;
|
|
{$ifndef UseCLX}
|
|
rBitmap.HandleType := bmDIB;
|
|
{$endif}
|
|
rBitmap.LoadFromStream(Stream);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
|
|
// is bitmap transparent?
|
|
|
|
if ((0 <= TrIndex) and (TrIndex < ct^.rSize)) then
|
|
begin
|
|
rBitmap.Transparent := true;
|
|
rBitmap.TransparentMode := tmFixed;
|
|
rBitmap.TransparentColor := ct^.rColors[TrIndex];
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TGif.GetStripBitmap}
|
|
function TGif.GetStripBitmap(var Mask: TBitmap): TBitmap; {LDB}
|
|
{This is a single bitmap containing all the frames. A mask is also provided
|
|
if the GIF is transparent. Each Frame is set up so that it can be transparently
|
|
blted to a background.}
|
|
type
|
|
LayoutType = Packed Record
|
|
BFH: TBitmapFileHeader;
|
|
BIH: TBitmapInfoHeader;
|
|
end;
|
|
PLayoutType = ^LayoutType;
|
|
var
|
|
id: PGifImageDescriptor;
|
|
ct: PGifColorTable;
|
|
// FullWidth,
|
|
FullHeight,
|
|
RowByteSize,
|
|
// vBottom,
|
|
vTopByte, vLeftByte,
|
|
PixelSize, FileSize: integer;
|
|
DeltaBytes{, vRowDelta} : Integer; // Delta between frames
|
|
Stream, MStream: TMemoryStream;
|
|
PL, MPL: PLayoutType;
|
|
Color: TColor;
|
|
Index: integer;
|
|
Pix, P, MPix, MP, PRight: PByte;
|
|
I, X, Y, N: integer;
|
|
TrIndex: integer;
|
|
// C: char;
|
|
C: Byte;
|
|
IsTransparent: boolean;
|
|
vWidth : Integer; // Added for Optimization by Rapid D!
|
|
begin
|
|
MStream := Nil;
|
|
Result := Nil;
|
|
Mask := Nil;
|
|
MP := Nil;
|
|
MPix := Nil;
|
|
vWidth := Width;
|
|
FullHeight := Height * ImageCount;
|
|
{find size needed for strip bitmap}
|
|
//RowByteSize := vWidth * 3 * ImageCount; {3 bytes per pixel}
|
|
RowByteSize := vWidth * 3; {3 bytes per pixel}
|
|
if RowByteSize and $3 <> 0 then {make sure it is DWord boundary}
|
|
RowByteSize := (RowByteSize and $FFFFFFFC) + $4;
|
|
PixelSize := FullHeight * RowByteSize;
|
|
FileSize := Sizeof(LayoutType)+PixelSize;
|
|
if (FileSize > 200000000) or Transparent and (FileSize > 100000000) then
|
|
GIF_Error(25);
|
|
Stream := TMemoryStream.Create;
|
|
try
|
|
Stream.Size := FileSize;
|
|
PL := Stream.Memory;
|
|
FillChar(PL^, FileSize, 0);
|
|
|
|
with PL^.BFH do
|
|
begin {set up the bitmap file header}
|
|
bfType := 19778;
|
|
bfSize := FileSize;
|
|
bfReserved1 := 0;
|
|
bfReserved2 := 0;
|
|
bfOffBits := Sizeof(LayoutType);
|
|
end;
|
|
with PL^.BIH do
|
|
begin {and the bitmap info header}
|
|
biSize := Sizeof(TBitmapInfoHeader);
|
|
biWidth := Width;
|
|
biHeight := FullHeight;
|
|
biPlanes := 1;
|
|
biBitCount := 24; {will use 24 bit pixel}
|
|
biCompression := 0;
|
|
biSizeImage := 0;
|
|
biXPelsPerMeter := 0;
|
|
biYPelsPerMeter := 0;
|
|
biClrUsed := 0;
|
|
biClrImportant := 0;
|
|
end;
|
|
|
|
Pix := PByte(PByte(PL) + Sizeof(LayoutType)); {where pixels start}
|
|
|
|
IsTransparent := Transparent;
|
|
if IsTransparent then
|
|
begin {set up a mask similarly}
|
|
MStream := TMemoryStream.Create;
|
|
MStream.Size := FileSize;
|
|
MPL := MStream.Memory;
|
|
Move(PL^, MPL^, FileSize); {for now, this is a direct copy}
|
|
MPix := PByte(PByte(MPL) + Sizeof(LayoutType)); {where mask pixels start}
|
|
FillChar(MPix^, PixelSize, $FF); {Need to make first frame totally transparent}
|
|
end;
|
|
|
|
for i := 0 to (fImageDescriptorList.Count - 1) do {for all the frames}
|
|
begin
|
|
vTopByte := (fImageDescriptorList.Count - i - 1) * Height * RowByteSize;
|
|
id := fImageDescriptorList.Items[i];
|
|
if (id <> nil) then
|
|
with id^ do
|
|
begin
|
|
ct := fColorTableList.Items[rLocalColorTable];
|
|
TrIndex := GetTransparentIndex(i);
|
|
|
|
vLeftByte := rLeft*3;
|
|
|
|
N := 0; {pixel index in rPixelList, the frame source pixels}
|
|
// for Y := Height-1 downto IntMax(Height-rHeight, ImageTop[I]) do
|
|
for Y := Height-1 downto IntMax(Height-rHeight, rTop) do
|
|
begin
|
|
{find the start of each frame row in destination. Note that the source
|
|
frame may be smaller than the destination and positioned according to
|
|
imagetop and imageleft}
|
|
P := PByte(Pix) + vTopByte + ((Y-rTop) * RowByteSize) + vLeftByte;
|
|
PRight := PByte(P) + RowByteSize - vLeftByte;
|
|
// PRight := PByte(Cardinal(P) + rWidth * 3);
|
|
if IsTransparent then {same for mask}
|
|
MP := PByte(MPix) + vTopByte + ((Y-rTop) * RowByteSize) + vLeftByte;
|
|
for X := 0 to rWidth-1 do
|
|
begin
|
|
if PByte(P) < PByte(PRight) then {prevent write beyond proper right side in case rwidth to wide}
|
|
begin
|
|
Index := Integer((PByte(rPixelList) + N)^); {Source pixel index in colortable}
|
|
Color := ct^.rColors[Index]; {its color}
|
|
{for frames after the 0th, only the non transparent pixels are written
|
|
as writing transparent ones might cover results copied from the previous frame}
|
|
if (Index <> trIndex) then
|
|
begin
|
|
P^ := Byte((Color shr 16) and $FF);
|
|
Inc(P);
|
|
P^ := Byte((Color shr 8) and $FF);
|
|
Inc(P);
|
|
P^ := Byte(Color and $FF);
|
|
Inc(P);
|
|
end
|
|
else if i = 0 then
|
|
begin {transparent pixel, first frame, write black}
|
|
P^ := 0;
|
|
Inc(P);
|
|
P^ := 0;
|
|
Inc(P);
|
|
P^ := 0;
|
|
Inc(P);
|
|
end
|
|
else Inc(P, 3); {ignore transparent pixel}
|
|
if IsTransparent then {also do the mask}
|
|
begin
|
|
if Index = trIndex then
|
|
C := $FF {transparent part is white}
|
|
else C := 0; {non transparent is black}
|
|
{again for frames after the 0th, only non-transparent pixels are written}
|
|
if (i = 0) or (C = 0) then
|
|
begin
|
|
MP^ := C;
|
|
Inc(MP);
|
|
MP^ := C;
|
|
Inc(MP);
|
|
MP^ := C;
|
|
Inc(MP);
|
|
end
|
|
else Inc(MP, 3);
|
|
end;
|
|
end;
|
|
Inc(N); {bump source pixel index}
|
|
end;
|
|
end;
|
|
end;
|
|
{Now copy this frame to the next (unless it the last one). This serves as a
|
|
background for the next image. This is all that's needed for the dtDoNothing
|
|
disposal method but will be fixed up for dtBackground below}
|
|
if (i < fImageDescriptorList.Count-1) then
|
|
begin
|
|
DeltaBytes := Height * RowByteSize;
|
|
// MskDeltaBytes := Height * Width;
|
|
// vTopByte := i * DeltaBytes;
|
|
(*
|
|
// For Horizontal
|
|
for Y := Height-1 downto 0 do
|
|
begin {copy line by line}
|
|
// vRowDelta := Y * vWidth;
|
|
vRowDelta := Y * RowByteSize;
|
|
P := PByte(Cardinal(Pix) + vTopByte + vRowDelta);
|
|
if IsTransparent then
|
|
MP := PByte(Cardinal(MPix) + vTopByte + vRowDelta);
|
|
Move(P^, PByte(Cardinal(P) + DeltaBytes)^, RowByteSize);
|
|
if IsTransparent then
|
|
Move(MP^, PByte(Cardinal(MP)+ DeltaBytes)^, RowByteSize);
|
|
end;
|
|
*)
|
|
// For vertical:
|
|
P := PByte(Pix) + vTopByte;
|
|
if IsTransparent then
|
|
MP := PByte(MPix) + vTopByte;
|
|
Move(P^, (PByte(P) - DeltaBytes)^, DeltaBytes);
|
|
if IsTransparent then
|
|
Move(MP^, (PByte(MP) - DeltaBytes)^, DeltaBytes);
|
|
|
|
{for dtBackground, fill the mask area occupied by the current copied image with
|
|
white. This makes it transparent so the original background will appear here
|
|
(although the next image will no doubt write on part of this area.}
|
|
if IsTransparent and (ImageDisposal[i] in [2,3]) then {dtToPrevious run as dtBackground as it seems other browsers do this}
|
|
with id^ do
|
|
for Y := Height-1 downto IntMax(Height-rHeight, rTop) do
|
|
begin
|
|
MP := PByte(MPix) + vTopByte - DeltaBytes + ((Y-rTop) * RowByteSize) + rLeft*3;
|
|
FillChar(MP^, rWidth*3, $FF);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Result := TBitmap.Create;
|
|
{$ifndef UseCLX}
|
|
Result.HandleType := bmDIB;
|
|
{$endif}
|
|
Result.LoadFromStream(Stream); {turn the stream just formed into a TBitmap}
|
|
if IsTransparent then
|
|
begin
|
|
Mask := TBitmap.Create;
|
|
Mask.HandleType := bmDIB;
|
|
Mask.LoadFromStream(MStream);
|
|
Mask.Monochrome := True; {crunch mask into a monochrome TBitmap}
|
|
end;
|
|
Stream.Free;
|
|
MStream.Free;
|
|
except
|
|
Stream.Free;
|
|
MStream.Free;
|
|
Mask.Free;
|
|
Result.Free;
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ find the graphic extension for an image }
|
|
|
|
function TGif.FindGraphicExtension(image: integer): PGifExtensionGraphic;
|
|
var
|
|
n: integer;
|
|
id: PGifImageDescriptor;
|
|
ex: PGifExtension;
|
|
gx: PGifExtensionGraphic;
|
|
begin
|
|
gx := nil;
|
|
id := fImageDescriptorList.Items[image];
|
|
if (id^.rExtensionList <> nil) then
|
|
begin
|
|
for n := 0 to (id^.rExtensionList.Count - 1) do
|
|
begin
|
|
ex := id^.rExtensionList.Items[n];
|
|
if ((ex^.rLabel = kGifLabelGraphic) and (gx = nil)) then
|
|
begin
|
|
gx := @(ex^.rGraphic);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
FindGraphicExtension := gx;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ find the color within the color table; returns 0..255 }
|
|
{ return -1 if color not found }
|
|
|
|
function TGif.FindColorIndex(c: TColor; ct: PGifColorTable): integer;
|
|
var
|
|
i,n: integer;
|
|
begin
|
|
n := -1;
|
|
for i := 0 to (ct^.rSize - 1) do
|
|
begin
|
|
if ((n < 0) and (ct^.rColors[i] = c)) then n := i;
|
|
end;
|
|
|
|
FindColorIndex := n;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------------- }
|
|
{ RAISE AN ERROR ------------------------------------------------------------- }
|
|
|
|
procedure GIF_Error(n: integer);
|
|
begin
|
|
GIF_ErrorCode := n;
|
|
GIF_ErrorString := String(kGifErrorMessages[n]);
|
|
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
|
|
end;
|
|
|
|
|
|
procedure GIF_ErrorMessage(m: string);
|
|
begin
|
|
GIF_ErrorCode := 6;
|
|
GIF_ErrorString := m;
|
|
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
|
|
end;
|
|
|
|
end.
|