gifunit.pas

Delphi direct support for GIF files

    end;
    DecodeStack[SP] := Code;           { put the last code onto the decode stack }
    Inc(SP);                           { increment the decode stack index }
  end;  { DecodeCode }

  procedure PopStack;
  { pops off the decode stack and puts into the line buffer }
  begin { PopStack }
    with DecodeRecord do
    while SP > 0 do
    begin
      dec(SP);
      LineBytes[CurrBuf] := DecodeStack[SP];
      inc(CurrBuf);
      if CurrBuf > ImageDescriptor.ImageWidth       { is the line full ? }
      then begin
        if ImageDescriptor.ImageHeight > 200
        then ShowProgress((CurrentY+1)/ImageDescriptor.ImageHeight);
        Application.ProcessMessages;
        Pixels.SetRow(CurrentY+1, LineBytes);
        { addition of one necessary because CurrentY is
          zero-based while ImagePixels is one-based }
        if not InterLaced
        then Inc(CurrentY)
        else CurrentY := NextLineNo(CurrentY, ImageDescriptor.ImageHeight,
                                              InterlacePass);
        CurrBuf := 1;
      end;
    end; { while SP > 0 }
  end;  { PopStack }

  procedure CheckSlotValue(var Slot, TopSlot: Word; var MaxVal: Boolean);
  begin { CheckSlotValue }
    if Slot >= TopSlot then      { have reached the top slot for bit size }
    begin                        { increment code bit size }
      if DecodeRecord.CurrCodeSize < 12 then  { new bit size not too big? }
      begin
        TopSlot := TopSlot shl 1;  { new top slot }
        inc(DecodeRecord.CurrCodeSize)       { new code size }
      end else
        MaxVal := True;       { Must check next code is a start code }
    end;
  end;  { CheckSlotValue }

var
  TempOldCode, OldCode: word;
  Code, C: word;
  MaxVal: boolean;
  Slot     : Word;     { position that the next new code is to be added }
  TopSlot  : Word;     { highest slot position for the current code size }
begin { TGifSubImage.DecodeRasterData }
  InitCompressionStream(LZWCodeSize, DecodeRecord); { Initialize decoding parameters }
  CompressedRasterData.Reset;
  LineBytes := TBigByteArray.Create(ImageDescriptor.ImageWidth);
  OldCode := 0;
  SP := 0;
  CurrBuf := 1;
  MaxVal := False;
  try
  try
    C := NextCode(CompressedRasterData, DecodeRecord);  { get the initial code - should be a clear code }
    while C <> DecodeRecord.EndingCode do  { main loop until ending code is found }
    begin
      if C = DecodeRecord.ClearCode then   { code is a clear code - so clear }
      begin
        DecodeRecord.CurrCodeSize := DecodeRecord.LZWCodeSize + 1;  { reset the code size }
        Slot := DecodeRecord.EndingCode + 1;           { set slot for next new code }
        TopSlot := 1 shl DecodeRecord.CurrCodeSize;    { set max slot number }
        while C = DecodeRecord.ClearCode do
          C := NextCode(CompressedRasterData, DecodeRecord);
            { read until all clear codes gone - shouldn't happen }
        if C = DecodeRecord.EndingCode then
          raise EGifException.Create('Bad code');     { ending code after a clear code }
        if C >= Slot then { if the code is beyond preset codes then set to zero }
          C := 0;
        OldCode := C;
        DecodeStack[SP] := C;   { output code to decoded stack }
        inc(SP);                { increment decode stack index }
      end else   { the code is not a clear code or an ending code so  }
      begin      { it must be a code code - so decode the code }
        Code := C;
        if Code < Slot then     { is the code in the table? }
        begin
          DecodeCode(Code);            { decode the code }
          if Slot <= TopSlot then
          begin                        { add the new code to the table }
            Suffix[Slot] := Code;      { make the suffix }
            Prefix[Slot] := OldCode;   { the previous code - a link to the data }
            inc(Slot);                 { increment slot number }
            CheckSlotValue(Slot, TopSlot, MaxVal);
            OldCode := C;              { set oldcode }
          end;
        end else
        begin  { the code is not in the table }
          if Code <> Slot then
            raise EGifException.Create('Bad code'); { so error out }
            { the code does not exist so make a new entry in the code table
              and then translate the new code }
          TempOldCode := OldCode;  { make a copy of the old code }
          while OldCode > DecodeRecord.HighCode { translate the old code and }
          do begin                              { place it on the decode stack }
            DecodeStack[SP] := Suffix[OldCode]; { do the suffix }
            OldCode := Prefix[OldCode];         { get next prefix }
          end;
          DecodeStack[SP] := OldCode;  { put the code onto the decode stack }
                                    { but DO NOT increment stack index }
              { the decode stack is not incremented because we are }
              { only translating the oldcode to get the first character }
          if Slot <= TopSlot then
          begin   { make new code entry }
            Suffix[Slot] := OldCode;       { first char of old code }
            Prefix[Slot] := TempOldCode;   { link to the old code prefix }
            inc(Slot);                     { increment slot }
            CheckSlotValue(Slot, TopSlot, MaxVal);
          end;
          DecodeCode(Code); { now that the table entry exists decode it }
          OldCode := C;     { set the new old code }
        end;
      end; { else (if code < slot) }
      PopStack;  { the decoded string is on the decode stack; put in linebuffer }
      C := NextCode(CompressedRasterData, DecodeRecord);  { get the next code and go at is some more }
      if (MaxVal = True) and (C <> DecodeRecord.ClearCode) then
        raise EGifException.Create('Code size overflow');
      MaxVal := False;
    end; { while C <> EndingCode }
  except
    on E: EListError do;
    on E: EStringListError do;
  end;
  finally
  LineBytes.Free;
  end;
end;  { TGifSubImage.DecodeRasterData }

procedure TGifSubImage.LoadFromStream(Stream: TStream);
begin { TGifSubImage.LoadFromStream }
  ReadImageDescriptor(Stream);
  ReadLocalColorMap(Stream);
  Pixels.Free;
  Pixels := TByteArray2D.Create(ImageDescriptor.ImageWidth,
                                ImageDescriptor.ImageHeight);
  ReadRasterData(Stream);
  DecodeRasterData;
end;  { TGifSubImage.LoadFromStream }

(***** write routines *****)

procedure AppendPixel(var PixelString: TByteBuffer;
                      Pixels: TBigByteArray;
                      var NextPixelNo: Longint);
begin { AppendPixel }
  PixelString.AddByte(Pixels[NextPixelNo]);
  Inc(NextPixelNo);
end;  { AppendPixel }

procedure GoBackPixel(var PixelString: TByteBuffer;
                      var NextPixelNo: Longint);
begin { GoBackPixel }
  PixelString.DeleteLastByte;
  Dec(NextPixelNo);
end;  { GoBackPixel }

procedure TGifSubImage.EncodeStatusbyte;
begin { TGifSubImage.EncodeStatusbyte }
  with ImageDescriptor
  do begin
    PackedFields := 0;
    if HasLocalColorMap
    then PackedFields := PackedFields or idLocalColorTable;
    if Interlaced
    then PackedFields := PackedFields or idInterlaced;
    if HasLocalColorMap
    then PackedFields := PackedFields or (BitsperPixel-1);
  end;
end;  { TGifSubImage.EncodeStatusbyte }

procedure TGifSubImage.WriteImageDescriptor(Stream: TStream);
var OldStatusByte: Byte;
begin { TGifSubImage.WriteImageDescriptor }
  OldStatusByte := ImageDescriptor.PackedFields;
  EncodeStatusByte;
  {if ImageDescriptor.PackedFields <> OldStatusByte
  then ShowMessage('PackedFields value has been changed');}
  Stream.Write(ImageDescriptor, SizeOf(ImageDescriptor));
end;  { TGifSubImage.WriteImageDescriptor }

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

procedure TGifSubImage.EncodeRasterdata;
var
  PixelArray: TBigByteArray;
  CodeTable: TCodeTable;
  ClearCode: Word;
  EndCode: Word;
  FirstPixel: Byte;
  OldCode, Code: Integer;
  PixelString: TByteBuffer;
  NextPixelNo: Longint;
  Found: Boolean;
  PrevFoundIndex, FoundIndex: Integer;
  EncodedBytes: TEncodedBytes;
begin { TGifSubImage.EncodeRasterdata }
  MakeFlat(Pixels, Interlaced, PixelArray);
  CodeTable := TCodeTable.Create;
  CodeTable.Clear(LZWCodeSize+1);
  PixelString := TByteBuffer.Create;
  ClearCode := 1 shl LZWCodeSize;
  EndCode := ClearCode + 1;
  EncodedBytes := TEncodedBytes.Create;
  EncodedBytes.AppendCode(ClearCode, CodeTable.CodeSize);
  NextPixelNo := 1;
  FirstPixel := PixelArray[NextPixelNo];
  EncodedBytes.AppendCode(FirstPixel, CodeTable.CodeSize);
  OldCode := FirstPixel;
  Inc(NextPixelNo);
  ShowProgress(0);
  repeat
    PixelString.Clear;
    AppendPixel(PixelString, PixelArray, NextPixelNo);
    CodeTable.AddEntry(OldCode, PixelString.FirstByte);
    Found := True;
    PrevFoundIndex := PixelString.FirstByte;
    while Found and (NextPixelNo <= PixelArray.Count)
    do begin
      AppendPixel(PixelString, PixelArray, NextPixelNo);
      Found := CodeTable.IsInTable(PixelString, PrevFoundIndex, FoundIndex)
    end;
    if not Found
    then begin
      GoBackPixel(PixelString, NextPixelNo);
      Code := PrevFoundIndex
    end
    else Code := FoundIndex;
    EncodedBytes.AppendCode(Code, CodeTable.CodeSize);
    if CodeTable.TableFull and (NextPixelNo <= PixelArray.Count)
    then begin
      EncodedBytes.AppendCode(ClearCode, CodeTable.CodeSize);
      CodeTable.Clear(LZWCodeSize+1);
      FirstPixel := PixelArray[NextPixelNo];
      EncodedBytes.AppendCode(FirstPixel, CodeTable.CodeSize);
      OldCode := FirstPixel;
      Inc(NextPixelNo);
      ShowProgress(NextPixelNo/PixelArray.Count);
    end
    else OldCode := Code;
  until (NextPixelNo > PixelArray.Count);
  EncodedBytes.Finish(EndCode, CodeTable.CodeSize);
  CompressedRasterData := EncodedBytes.Value;
  PixelString.Free;
  CodeTable.Free;
  EncodedBytes.Free;
  PixelArray.Free;
  ShowProgress(1);
end;  { TGifSubImage.EncodeRasterdata }

procedure TGifSubImage.WriteRasterData(Stream: TStream);
var
  StringNo: Integer;
  Block: String;
  BlokByteCount: Byte;
begin { TGifSubImage.WriteRasterData }
  Stream.Write(LZWCodeSize, 1);
  for StringNo := 1 to CompressedRasterData.StringCount
  do begin
    Block := CompressedRasterData.Strings[StringNo];
    BlokByteCount := Length(Block);
    Stream.Write(BlokByteCount, 1);
    Stream.Write(Block[1], BlokByteCount);
  end;
  BlokByteCount := 0;
  Stream.Write(BlokByteCount, 1);
end;  { TGifSubImage.WriteRasterData }

procedure TGifSubImage.SaveToStream(Stream: TStream);
{ Saves it as a .bmp! }

  procedure CreateBitHeader(Image: TGifSubImage;
                            var bmHeader: TBitmapInfoHeader);
  { This routine takes the values from the GIF image
    descriptor and fills in the appropriate values in the
    bit map header struct. }
  begin { CreateBitHeader }
    with BmHeader do
    begin
      biSize           := Sizeof(TBitmapInfoHeader);
      biWidth          := Image.ImageDescriptor.ImageWidth;
      biHeight         := Image.ImageDescriptor.ImageHeight;
      biPlanes         := 1;            {Arcane and rarely used}
      biBitCount       := 8;            {Hmmm Should this be hardcoded ?}
      biCompression    := BI_RGB;       {Sorry Did not implement compression in this version}
      biSizeImage      := 0;            {Valid since we are not compressing the image}
      biXPelsPerMeter  :=143;           {Rarely used very arcane field}
      biYPelsPerMeter  :=143;           {Ditto}
      biClrUsed        := 0;            {all colors are used}
      biClrImportant   := 0;            {all colors are important}
    end;
  end;  { CreateBitHeader }

var
  BitFile: TBitmapFileHeader;
  BmHeader: TBitmapInfoHeader; {File Header for bitmap file}
  i: integer;
  Line: integer;
  ch: char;
  x: integer;
  LineBytes: TBigByteArray;
begin { TGifSubImage.SaveToStream }
  with BitFile do begin
    with ImageDescriptor do
    bfSize := (3*255) + Sizeof(TBitmapFileHeader) +
              Sizeof(TBitmapInfoHeader) + (Longint(ImageHeight)*
                                           Longint(ImageWidth));
    bfReserved1 := 0; {not currently used}
    bfReserved2 := 0; {not currently used}
    bfOffBits := (4*256)+ Sizeof(TBitmapFileHeader)+
                          Sizeof(TBitmapInfoHeader);
  end;
  CreateBitHeader(Self, bmHeader);
  {Write the file header}
  with Stream do begin
    Position:=0;
    ch:='B';
    Write(ch,1);
    ch:='M';
    Write(ch,1);
    Write(BitFile.bfSize,sizeof(BitFile.bfSize));
    Write(BitFile.bfReserved1,sizeof(BitFile.bfReserved1));
    Write(BitFile.bfReserved2,sizeof(BitFile.bfReserved2));
    Write(BitFile.bfOffBits,sizeof(BitFile.bfOffBits));
    {Write the bitmap image header info}
    Write(BmHeader,sizeof(BmHeader));
    {Write the BGR palete information to this file}
    if HasLocalColorMap then {Use the local color table}
    begin
      for i:= 0 to 255 do
      begin
        Write(LocalColormap.CT.Colors[i].Blue,1);
        Write(LocalColormap.CT.Colors[i].Green,1);
        Write(LocalColormap.CT.Colors[i].Red,1);
        Write(ch,1); {Bogus palette entry required by windows}
      end;
    end else {Use the global table}
    begin
      with FGifFile do
      for i := 0 to 255 do
      begin
        Write(GlobalColormap.CT.Colors[i].Blue,1);
        Write(GlobalColormap.CT.Colors[i].Green,1);
        Write(GlobalColormap.CT.Colors[i].Red,1);
        Write(ch,1); {Bogus palette entry required by windows}
      end;
    end;
    for Line := ImageDescriptor.ImageHeight downto 1
    do begin
 {Use reverse order since gifs are stored top to bottom.
  Bmp file need to be written bottom to top}
      LineBytes := Pixels.CopyRow(Line);
      x := ImageDescriptor.ImageWidth;
      Write(LineBytes.Address^, x);
      ch := chr(0);
      while (x and 3) <> 0 do { Pad up to 4-byte boundary with zeroes }
      begin
        Inc(x);
        Write(ch, 1);
      end;
      LineBytes.Free;
      if ImageDescriptor.ImageHeight > 500
      then ShowProgress(1-(Line-1)/ImageDescriptor.ImageHeight);
    end;
    Position := 0; { reset memory stream}
  end;
end;  { TGifSubImage.SaveToStream }

(***** end of TGifSubImage *****)

(***** TGifFile *****)

constructor TGifFile.Create;
begin { TGifFile.Create }
  inherited Create;
  Header.Signature := 'GIF';
  Header.Version := '87a';
  ScreenDescriptor.ScreenWidth := 0;
  ScreenDescriptor.ScreenHeight := 0;
  ScreenDescriptor.PackedFields := 0;
  ScreenDescriptor.BackGroundcolorIndex := 0;
  ScreenDescriptor.AspectRatio := 0;
  HasGlobalColorMap := True;
  BitsPerPixel := 1;  { arbitrary; other choices would be 4 or 8 }
  GlobalColorMap := TColorTable.Create(0);
  SubImages := TList.Create;