gifunit.pas

Delphi direct support for GIF files

  end;
  if Bitmap.PixelFormat = pf8bit
  then begin
    BitmapToPixelmatrix8bpp(Bitmap, ColorTable, Pixels);
    Exit;
  end;
{$endif UseScanlines}

  PrevPixelVal := $FFFFFFFF;
  with Bitmap
  do begin
    ShowProgress(0);
    Pixels := TByteArray2D.Create(Width, Height);
    for j := 1 to Height
    do begin
      H := Bitmap.Canvas.Handle; { within the loop becuase ShowProgress
                                   corrupts this handle }
      for i := 1 to Width
      do begin
        {PixelVal := Canvas.Pixels[i-1, j-1];}
        PixelVal := GetPixel(H, i-1, j-1);
        if PixelVal <> PrevPixelVal
        then begin
          ColorIndex := ColorTable.GetColorIndex(PixelVal);
          if ColorIndex = -1
          then begin
            ColorTable.FCT.Colors[ColorTable.Count] := PixelVal;
            ColorIndex := ColorTable.Count;
            ColorTable.Count := COlorTable.Count + 1; { no check on > 256 yet }
          end;
          PrevPixelVal := PixelVal;
        end;
        Pixels[i, j] := ColorIndex;
      end;
      ShowProgress(j/Height);
    end;
  end; { with }
  ColorTable.AdjustColorCount;
  ColorTable.CompactColors;
end;  { BitmapToPixelmatrix }


procedure MakeFlat(PixelMatrix: TByteArray2D;
                   Interlaced: Boolean;
                   var PixelArray: TBigByteArray);
{ Convert a matrix of pixels into a linear array of pixels,
taking interlacing into account if necessary }
var
  InterlacePass: Integer;
  i, j, Index, LineNo: Longint;
begin { MakeFlat }
  InterlacePass := 1;
  with PixelMatrix
  do begin
    PixelArray := TBigByteArray.Create(Count1 * Count2);
    Index := 1;
    LineNo := 0;
    for j := 1 to Count2
    do begin
      for i := 1 to Count1
      do begin
        PixelArray[Index] := PixelMatrix[i, LineNo+1];
        Inc(Index);
      end;
      if not Interlaced
      then Inc(LineNo)
      else LineNo := NextLineNo(LineNo, Count2, InterlacePass);
    end;
  end; { with }
end;  { MakeFlat }

procedure WriteColor(Stream: TStream; Color: TColor);
var r, g, b: Byte;
begin { WriteColor }
  r := (Color shr 4) and $FF;
  g := (Color shr 2) and $FF;
  b := Color and $FF;
  Stream.Write(r, 1);
  Stream.Write(g, 1);
  Stream.Write(b, 1);
end;  { WriteColor }

(***** TGifSubImage *****)

constructor TGifSubImage.Create(NColors: Word; Parent: TGifFile);
begin { TGifSubImage.Create }
  inherited Create;
  FGifFile := Parent;
  FExtensions := TExtensionList.Create;
  CompressedRasterData := TByteBuffer.Create;
  Pixels := TByteArray2D.Create(0, 0);
  ImageDescriptor.ImageLeftPos := 0;
  ImageDescriptor.ImageTopPos := 0;
  ImageDescriptor.ImageWidth := 0;
  ImageDescriptor.ImageHeight := 0;
  ImageDescriptor.PackedFields := 0;
  HasLocalColorMap := False;
  Interlaced := False;
  case NColors of
    2: BitsPerPixel := 1;
    4: BitsPerPixel := 2;
    8: BitsPerPixel := 3;
    16: BitsPerPixel := 4;
    32: BitsPerPixel := 5;
    64: BitsPerPixel := 6;
    128: BitsPerPixel := 7;
    256: BitsPerPixel := 8;
    else raise EGifException.Create('Number of colors ('+IntToStr(NColors)+') wrong; must be a power of 2');
  end;  { case }
  LZWCodeSize := BitsPerPixel;
  if LZWCodeSize = 1
  then Inc(LZWCodeSize);
  {TColorTable_Create(LocalColorMap, NColors);}
  LocalColormap := TColorTable.Create(NColors);
  EncodeStatusByte;
end;  { TGifSubImage.Create }

constructor TGifSubImage.CreateEmpty;
begin { TGifSubImage.CreateEmpty }
  inherited Create;
end;  { TGifSubImage.CreateEmpty }

destructor TGifSubImage.Destroy;
begin { TGifSubImage.Destroy }
  LocalColormap.Free;
  Pixels.Free;
  CompressedRasterData.Free;
  FExtensions.Free;
  FBitmap.Free;
  inherited Destroy;
end;  { TGifSubImage.Destroy }

(***** TGifSubImage: end of constructors/desctructors *****)
(***** TGifSubImage: property access methods *****)

function TGifSubImage.GetAnimateInterval: Word;
{ Returns the delay time between this (sub)image and the next one.
In centiseconds! }
var ExtNo: Integer;
    Extension: GifDecl.TExtension;
begin { TGifSubImage.GetAnimateInterval }
  if Extensions.Count = 0
  then Result := 0
  else begin
    Result := 0;
    for ExtNo := 1 to Extensions.Count
    do begin
      Extension := Extensions[ExtNo-1];
      if Extension.Extrec.ExtensionType = etGCE
      then Result := Extension.ExtRec.GCE.DelayTime;
    end;
  end;
end;  { TGifSubImage.GetAnimateInterval }

function TGifSubImage.GetBGColor: TColor;
var
  Index: Integer;
begin { TGifSubImage.GetBGColor }
  Index := FGifFile.ScreenDescriptor.BackGroundColorIndex;
  if HasLocalColormap
  then Result := LocalColormap.GetColor(index)
  else Result := FGifFile.GlobalColorMap.GetColor(index)
end;  { TGifSubImage.GetBGColor }

procedure TGifSubImage.SetAnimateInterval(NewValue: Word);
{ Sets the delay time between this (sub)image and the next one.
In centiseconds! }
var ExtNo: Integer;
    Extension: GifDecl.TExtension;
begin { TGifSubImage.SetAnimateInterval }
  if Extensions.Count <> 0
  then begin
    for ExtNo := 1 to Extensions.Count
    do begin
      Extension := Extensions[ExtNo-1];
      if Extension.Extrec.ExtensionType = etGCE
      then Extension.ExtRec.GCE.DelayTime := NewValue;
    end;
  end;
end;  { TGifSubImage.SetAnimateInterval }

procedure TGifSubImage.SetExtensions(NewValue: TExtensionList);
var
  ExtNo: Integer;
  Ext: GifDecl.TExtension;
begin { TGifSubImage.SetExtensions }
  FExtensions := NewValue;

  FDisposalMethod := dmNone;
  FIsTransparent := False;
  if Extensions <> nil
  then for ExtNo := 1 to Extensions.Count
  do begin
    Ext := Self.Extensions[ExtNo-1];
    case Ext.ExtRec.ExtensionType of
    etGCE: begin
           FDisposalMethod := TDisposalMethod((Ext.ExtRec.GCE.PackedFields shr 2) and $07);
           FIsTransparent := (Ext.ExtRec.GCE.PackedFields and $01) <> 0;
           end;
    etPTE:  ;
    etAPPE: ;
    etCE:   ;
    end;
  end;
end;  { TGifSubImage.SetExtensions }

(***** TGifSubImage: end of property access methods *****)

function TGifSubImage.AsBitmap: TBitmap;
var Stream: TMemoryStream;
begin { TGifSubImage.AsBitmap }
  if FBitmap = nil
  then begin
    Stream := TMemoryStream.Create;
    try
      SaveToStream(Stream);
      FBitmap := TBitmap.Create;
      FBitmap.LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
  Result := FBitmap;
end;  { TGifSubImage.AsBitmap }

function TGifSubImage.TransparentColor: TColor;
var
  Found: Boolean;
  ExtNo: Integer;
  Ext: GifDecl.TExtension;
  index: Byte;
begin { TGifSubImage.TransparentColor }
  Found := False;
  ExtNo := 1;
  while not Found and (ExtNo <= Extensions.Count)
  do begin
    Ext := Extensions[ExtNo-1];
    Found := (Ext.ExtRec.ExtensionType = etGCE) and
             ((Ext.ExtRec.GCE.PackedFields and $01) <> 0);
    Inc(ExtNo);
  end;
  if not Found
  then Result := -1
  else begin
    index := Ext.ExtRec.GCE.TransparentColorIndex;
    if HasLocalColormap
    then Result := LocalColormap.GetColor(index)
    else Result := FGifFile.GlobalColormap.GetColor(index)
  end;
end;  { TGifSubImage.TransparentColor }

function TGifSubImage.TransparentColorIndex: Integer;
var
  Found: Boolean;
  ExtNo: Integer;
  Ext: GifDecl.TExtension;
begin { TGifSubImage.TransparentColorIndex }
  Found := False;
  ExtNo := 1;
  while not Found and (ExtNo <= Extensions.Count)
  do begin
    Ext := Extensions[ExtNo-1];
    Found := (Ext.ExtRec.ExtensionType = etGCE) and
             ((Ext.ExtRec.GCE.PackedFields and $01) <> 0);
    Inc(ExtNo);
  end;
  if not Found
  then Result := -1
  else Result := Ext.ExtRec.GCE.TransparentColorIndex;
end;  { TGifSubImage.TransparentColorIndex }

(***** read routines *****)

procedure TGifSubImage.DecodeStatusByte;
begin { TGifSubImage.DecodeStatusByte }
  with ImageDescriptor
  do begin
    HasLocalColorMap := (PackedFields and idLocalColorTable) = idLocalColorTable;
    Interlaced := (ImageDescriptor.PackedFields and idInterlaced) = idInterlaced;
    BitsPerPixel := 1 + ImageDescriptor.PackedFields and $07;
    LocalColorMap.Count := 1 shl BitsPerPixel;
  end;
end;  { TGifSubImage.DecodeStatusByte }

procedure TGifSubImage.ReadImageDescriptor(Stream: TStream);
begin { TGifSubImage.ReadImageDescriptor }
  Stream.Read(ImageDescriptor, SizeOf(ImageDescriptor));
  DecodeStatusByte;
end;  { TGifSubImage.ReadImageDescriptor }

procedure TGifSubImage.ReadLocalColorMap(Stream: TStream);
begin { TGifSubImage.ReadLocalColorMap }
  if HasLocalColorMap
  then
    with LocalColorMap
    do Stream.Read(CT.Colors[0], Count*SizeOf(TColorItem));
end;  { TGifSubImage.ReadLocalColorMap }

procedure TGifSubImage.ReadRasterData(Stream: TStream);
var
  NewString: String;
  BlokByteCount: Byte;
  ReadBytes: Integer;
begin { TGifSubImage.ReadRasterData }
  Stream.Read(LZWCodeSize, 1);
  Stream.Read(BlokByteCount, 1);
  while (BlokByteCount <> 0) and not (Stream.Position >= Stream.Size)
  do begin
{$ifdef ver80}
    NewString[0] := Chr(BlokByteCount);
{$else}
    SetLength(NewString, BlokByteCount);
{$endif ver80}
    ReadBytes := Stream.Read(NewString[1], BlokByteCount);
    if ReadBytes < BlokByteCount
    then
  {$ifdef ver80}
      NewString[0] := Chr(ReadBytes)
  {$else}
      SetLength(NewString, ReadBytes)
  {$endif ver80}
    else Stream.Read(BlokByteCount, 1);
    CompressedRasterData.AddString(NewString);
  end;
end;  { TGifSubImage.ReadRasterData }

procedure InitCompressionStream(InitLZWCodeSize: Byte;
                                var DecodeRecord: TDecodeRecord);
begin { InitCompressionStream }
  with DecodeRecord
  do begin
    LZWCodeSize := InitLZWCodeSize;
    if not (LZWCodeSize in [2..9])    { valid code sizes 2-9 bits }
    then raise EGifException.Create('Bad code Size');
    CurrCodeSize := succ(LZWCodeSize);
    ClearCode := 1 shl LZWCodeSize;
    EndingCode := succ(ClearCode);
    HighCode := pred(ClearCode);      { highest code not needing decoding }
    BitsLeft := 0;
    CurrentY := 0;
    InterlacePass := 1;
  end;
end;  { InitCompressionStream }

function NextCode(CompressedRasterData: TByteBuffer;
                  var DecodeRecord: TDecodeRecord): word;
{ returns a code of the proper bit size }
var LongResult: Longint;
begin { NextCode }
  with DecodeRecord
  do begin
    if BitsLeft = 0 then       { any bits left in byte ? }
    begin                      { any bytes left }
      CurrByte := CompressedRasterData.GetNextByte;   { get a byte }
      BitsLeft := 8;                 { set bits left in the byte }
    end;
    LongResult := CurrByte shr (8 - BitsLeft); { shift off any previously used bits}
    while CurrCodeSize > BitsLeft do          { need more bits ? }
    begin
      CurrByte := CompressedRasterData.GetNextByte;      { get another byte }
      LongResult := LongResult or (CurrByte shl BitsLeft);
                                 { add the remaining bits to the return value }
      BitsLeft := BitsLeft + 8;               { set bit counter }
    end;
    BitsLeft := BitsLeft - CurrCodeSize;      { subtract the code size from bitsleft }
    Result := LongResult and CodeMask[CurrCodeSize];{ mask off the right number of bits }
  end;
end;  { NextCode }

procedure UpdateBitsPerPixel(const ColorCount: Integer;
                             var BitsPerPixel: Byte);
begin { UpdateBitsPerPixel }
  while ColorCount > 1 shl BitsPerPixel
  do Inc(BitsPerPixel)
end;  { UpdateBitsPerPixel }

procedure TGifSubImage.DecodeRasterData;
{ decodes the LZW encoded raster data }
var
  SP: integer; { index to the decode stack }
  DecodeStack: array[0..CodeTableSize-1] of byte;
               { stack for the decoded codes }
  DecodeRecord: TDecodeRecord;
  Prefix: array[0..CodeTableSize-1] of integer; { array for code prefixes }
  Suffix: array[0..CodeTableSize-1] of integer; { array for code suffixes }
  LineBytes: TBigByteArray;
  CurrBuf: word;  { line buffer index }

  procedure DecodeCode(var Code: word);
  { decodes a code and puts it on the decode stack }
  begin { DecodeCode }
    while Code > DecodeRecord.HighCode do
            { rip thru the prefix list placing suffixes }
    begin                    { onto the decode stack }
      DecodeStack[SP] := Suffix[Code]; { put the suffix on the decode stack }
      inc(SP);                         { increment decode stack index }
      Code := Prefix[Code];            { get the new prefix }