rxgif.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

                    Corrupted := True;
                    Break;
                  end
                  else GifError(LoadStr(SGIFDecodeError));
                end;
                OutCode^[OutCount] := Suffix^[CurCode];
                Inc(OutCount);
                CurCode := Prefix^[CurCode];
              end;
              if Corrupted then Break;
              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(Stream, ReadCtxt);
            if Stream.Size > 0 then begin
              Temp := Trunc(100.0 * (Stream.Position / Stream.Size));
              if Assigned(ProgressProc) then ProgressProc(psRunning, Temp, '');
            end;
          end; { while }
          if Code = $FFFF then GifError(ResStr(SReadError));
        finally
          if Assigned(ProgressProc) then begin
            if ExceptObject = nil then ProgressProc(psEnding, 100, '')
            else ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
          end;
        end;
      finally
        FreeMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
      end;
    finally
      FreeMem(Suffix, SizeOf(TIntCodeTable));
    end;
  finally
    FreeMem(Prefix, SizeOf(TIntCodeTable));
  end;
end;

procedure WriteCode(Stream: TStream; Code: Longint;
  var Context: TWriteContext);
var
  BufIndex: Longint;
  Bytes: Byte;
begin
  BufIndex := Context.Inx shr 3;
  Code := Code shl (Context.Inx and 7);
  Context.Buf[BufIndex] := Context.Buf[BufIndex] or (Code);
  Context.Buf[BufIndex + 1] := (Code shr 8);
  Context.Buf[BufIndex + 2] := (Code shr 16);
  Context.Inx := Context.Inx + Context.CodeSize;
  if Context.Inx >= 255 * 8 then begin
    { Flush out full buffer }
    Bytes := 255;
    Stream.WriteBuffer(Bytes, 1);
    Stream.WriteBuffer(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(Stream: TStream; var Context: TWriteContext);
var
  Bytes: Byte;
begin
  Bytes := (Context.Inx + 7) shr 3;
  if Bytes > 0 then begin
    Stream.WriteBuffer(Bytes, 1);
    Stream.WriteBuffer(Context.Buf, Bytes);
  end;
  { Data block terminator - a block of zero Size }
  Bytes := 0;
  Stream.WriteBuffer(Bytes, 1);
end;

procedure FillColorTable(var ColorTable: TGIFColorTable;
  const Colors: TRGBPalette; Count: Integer);
var
  I: Byte;
begin
  FillChar(ColorTable, SizeOf(ColorTable), 0);
  ColorTable.Count := Min(256, Count);
  for I := 0 to ColorTable.Count - 1 do begin
    ColorTable.Colors[I].Red := Colors[I].rgbRed;
    ColorTable.Colors[I].Green := Colors[I].rgbGreen;
    ColorTable.Colors[I].Blue := Colors[I].rgbBlue;
  end;
end;

procedure WriteGIFData(Stream: TStream; var Header: TBitmapInfoHeader;
  Interlaced: Boolean; Data: Pointer; ProgressProc: TProgressProc);
  { LZW encode data }
var
  LineIdent: Longint;
  MinCodeSize, Col, Temp: Byte;
  InitCodeSize, X, Y: Longint;
  Pass: Integer;
  MaxCode: Longint; { 1 shl CodeSize }
  ClearCode, EndingCode, LastCode, Tail: Longint;
  I, HashValue: Longint;
  LenString: Word;
  Dict: PDictTable;
  HashTable: TList;
  PData: PByte;
  WriteCtxt: TWriteContext;
begin
  LineIdent := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
  Tail := 0; HashValue := 0;
  Dict := AllocMem(SizeOf(TDictTable));
  try
    HashTable := TList.Create;
    try
      for I := 0 to HASH_TABLE_SIZE - 1 do HashTable.Add(nil);
      { Initialise encoder variables }
      InitCodeSize := Header.biBitCount + 1;
      if InitCodeSize = 2 then Inc(InitCodeSize);
      MinCodeSize := InitCodeSize - 1;
      Stream.WriteBuffer(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(Stream, ClearCode, WriteCtxt);
      for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
      Data := HugeOffset(Data, (Header.biHeight - 1) * LineIdent);
      Y := 0; Pass := 0;
      if Assigned(ProgressProc) then ProgressProc(psStarting, 0, '');
      try
        while (Y < Header.biHeight) do begin
          PData := HugeOffset(Data, -(Y * LineIdent));
          for X := 0 to Header.biWidth - 1 do begin
            case Header.biBitCount of
              8: begin
                   Col := PData^;
                   PData := HugeOffset(PData, 1);
                 end;
              4: begin
                   if X and 1 <> 0 then begin
                     Col := PData^ and $0F;
                     PData := HugeOffset(PData, 1);
                   end
                   else Col := PData^ shr 4;
                 end;
              else { must be 1 }
                begin
                  if X and 7 = 7 then begin
                    Col := PData^ and 1;
                    PData := HugeOffset(PData, 1);
                  end
                  else Col := (PData^ shr (7 - (X and $07))) and $01;
                end;
            end; { case }
            Inc(LenString);
            if LenString = 1 then begin
              Tail := Col;
              HashValue := InitHash(Col);
            end
            else begin
              HashValue := HashValue * (Col + LenString + 4);
              I := HashValue mod HASH_TABLE_SIZE;
              HashValue := HashValue mod HASH_TABLE_SIZE;
              while (HashTable[I] <> nil) and
                ((PImageDict(HashTable[I])^.Tail <> Tail) or
                (PImageDict(HashTable[I])^.Col <> Col)) do
              begin
                Inc(I);
                if (I >= HASH_TABLE_SIZE) then I := 0;
              end;
              if (HashTable[I] <> nil) then { Found in the strings table }
                Tail := PImageDict(HashTable[I])^.Index
              else begin
                { Not found }
                WriteCode(Stream, 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 >= CODE_TABLE_SIZE - 2) then begin
                  { Reset tables }
                  WriteCode(Stream, Tail, WriteCtxt);
                  WriteCode(Stream, ClearCode, WriteCtxt);
                  LenString := 0;
                  LastCode := EndingCode;
                  WriteCtxt.CodeSize := InitCodeSize;
                  MaxCode := 1 shl InitCodeSize;
                  for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
                end;
              end;
            end;
          end; { for X loop }
          if Interlaced then Y := InterlaceStep(Y, Header.biHeight, Pass)
          else Inc(Y);
          Temp := Trunc(100.0 * (Y / Header.biHeight));
          if Assigned(ProgressProc) then ProgressProc(psRunning, Temp, '');
        end; { while Y loop }
        WriteCode(Stream, Tail, WriteCtxt);
        WriteCode(Stream, EndingCode, WriteCtxt);
        FlushCode(Stream, WriteCtxt);
      finally
        if Assigned(ProgressProc) then begin
          if ExceptObject = nil then ProgressProc(psEnding, 100, '')
          else ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
        end;
      end;
    finally
      HashTable.Free;
    end;
  finally
    FreeMem(Dict, SizeOf(TDictTable));
  end;
end;

{ TGIFItem }

destructor TGIFItem.Destroy;
begin
  FImageData.Free;
  inherited Destroy;
end;

procedure TGIFItem.FreeHandle;
begin
  if FImageData <> nil then FImageData.SetSize(0);
end;

{ TGIFData }

constructor TGIFData.Create;
begin
  inherited Create;
  FComment := TStringList.Create;
end;

destructor TGIFData.Destroy;
begin
  FComment.Free;
  inherited Destroy;
end;

procedure TGIFData.FreeHandle;
begin
  if FComment <> nil then FComment.Clear;
end;

{ TGIFFrame }

constructor TGIFFrame.Create(AOwner: TGIFImage);
begin
  FOwner := AOwner;
  inherited Create;
  NewImage;
end;

destructor TGIFFrame.Destroy;
begin
  FBitmap.Free;
  FreeExtensions(FExtensions);
  FImage.Release;
  inherited Destroy;
end;

procedure TGIFFrame.SetAnimateInterval(Value: Word);
begin
  if FAnimateInterval <> Value then begin
    FAnimateInterval := Value;
    if Value > 0 then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIFFrame.SetDisposalMethod(Value: TDisposalMethod);
begin
  if FDisposal <> Value then begin
    FDisposal := Value;
    if Value <> dmUndefined then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIFFrame.SetTopLeft(const Value: TPoint);
begin
  if (FTopLeft.X <> Value.X) or (FTopLeft.Y <> Value.Y) then begin
    FTopLeft.X := Value.X;
    FTopLeft.Y := Value.Y;
    FOwner.FScreenWidth := Max(FOwner.FScreenWidth,
      FImage.FSize.X + FTopLeft.X);
    FOwner.FScreenHeight := Max(FOwner.FScreenHeight,
      FImage.FSize.Y + FTopLeft.Y);
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIFFrame.SetTransparentColor(Value: TColor);
begin
  if FTransparentColor <> Value then begin
    FTransparentColor := Value;
    if Value <> clNone then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

function TGIFFrame.GetBitmap: TBitmap;
var
  Mem: TMemoryStream;
begin
  Result := FBitmap;
  if (Result = nil) or Result.Empty then begin
    NewBitmap;
    Result := FBitmap;
    if Assigned(FImage.FImageData) then
    try
      Mem := TMemoryStream.Create;
      try
        SaveToBitmapStream(Mem);
        FBitmap.LoadFromStream(Mem);
{$IFDEF RX_D3}
        if not FBitmap.Monochrome then FBitmap.HandleType := bmDDB;
{$ENDIF}
      finally
        Mem.Free;
      end;
    except
      raise;
    end;
  end;
end;

function TGIFFrame.GetHeight: Integer;
begin
  if Assigned(FBitmap) or Assigned(FImage.FImageData) then
    Result := Bitmap.Height
  else Result := 0;
end;

function TGIFFrame.GetWidth: Integer;
begin
  if Assigned(FBitmap) or Assigned(FImage.FImageData) then
    Result := Bitmap.Width
  else Result := 0;
end;

function TGIFFrame.GetColorCount: Integer;
begin
  Result := FImage.FColormap.Count;
  if (Result = 0) and Assigned(FBitmap) and (FBitmap.Palette <> 0) then
    Result := PaletteEntries(FBitmap.Palette);
end;

procedure TGIFFrame.GrayscaleImage(ForceEncoding: Boolean);
var
  Mem: TMemoryStream;
  TransIndex: Integer;
begin
  if not FGrayscale and (Assigned(FBitmap) or
    Assigned(FImage.FImageData)) then
  begin
    if Assigned(FImage.FImageData) and (FImage.FColorMap.Count > 0) then begin
      FBitmap.Free;
      FBitmap := nil;
      TransIndex := FindColorIndex(FImage.FColorMap, FTransparentColor);
      GrayColorTable(FImage.FColorMap);
      if TransIndex >= 0 then
        FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex])
      else FTransparentColor := clNone;
      FGrayscale := True;
      try
        GetBitmap;
      except
        on EAbort do;
        else raise;
      end;
    end
    else begin
      Mem := BitmapToMemoryStream(Bitmap, pf8bit, mmGrayscale);
      try
        FImage.Release;
        FImage := TGIFItem.Create;
        FImage.Reference;
        if ForceEncoding then EncodeBitmapStream(Mem);
        FGrayscale := True;
        if FTransparentColor <> clNone then
          FTransparentColor := GrayColor(FTransparentColor);
        FBitmap.LoadFromStream(Mem);
      finally
        Mem.Free;
      end;
    end;
  end;
end;

procedure TGIFFrame.Assign(Source: TPersistent);
var
  AComment: TStrings;
begin
  if Source = nil then begin
    NewImage;
    FBitmap.Free;
    FBitmap := nil;
  end
  else if (Source is TGIFFrame) then begin
    if Source <> Self then begin