Load static GIF image

gif.pas

function LoadGIF(const Stream: TStream; out Data: PByteArray; out Width, Height: LongInt): Boolean;

  procedure DecompressLZW(InitCodeSize: Byte; Source, Dest: Pointer; PackedSize, UnpackedSize: LongInt);
  const
    NoLZWCode = 4096;
  var
    I: LongInt;
    Data, Bits, Code : LongWord;
    SourcePtr : ^Byte;
    InCode : LongWord;
    CodeSize, CodeMask, FreeCode, OldCode : LongWord;
    Prefix : array [0..4095] of LongWord;
    Suffix, Stack : array [0..4095] of Byte;
    StackPointer,Target : ^Byte;
    FirstChar : Byte;
    ClearCode, EOICode : Word;
  begin
    Target    := Dest;
    SourcePtr := Source;
    CodeSize  := InitCodeSize + 1;
    ClearCode := 1 shl InitCodeSize;
    EOICode   := ClearCode+1;
    FreeCode  := ClearCode+2;
    OldCode   := NoLZWCode;
    CodeMask  := (1 shl CodeSize) - 1;
    for i := 0 to ClearCode - 1 do
    begin
      Prefix[i] := NoLZWCode;
      Suffix[i] := i;
    end;
    StackPointer := @Stack;
    FirstChar := 0;
    Data := 0;
    Bits := 0;
    while (UnpackedSize > 0) and (PackedSize > 0) do
    begin
    // read code from bit stream
      Inc(Data, SourcePtr^ shl Bits);
      Inc(Bits, 8);
      while Bits >= CodeSize do
      begin
      // current code
        Code := Data and CodeMask;
      // prepare next run
        Data := Data shr CodeSize;
        Dec(Bits, CodeSize);
      // decoding finished?
        if Code = EOICode then
          break;
      // handling of clear codes
        if Code = ClearCode then
        begin
        // reset of all variables
          CodeSize := InitCodeSize + 1;
          CodeMask:=(1 shl CodeSize)-1;
          FreeCode:=ClearCode+2;
          OldCode:=NoLZWCode;
          continue;
        end;
      // check whether it is a valid, already registered code
        if Code > FreeCode then
          break;
      // handling for the first LZW code: print and keep it
        if OldCode = NoLZWCode then
        begin
          FirstChar := Suffix[Code];
          Target^    := FirstChar;
          Inc(Target);
          Dec(UnpackedSize);
          OldCode := Code;
          continue;
        end;
      // keep the passed LZW code
        InCode := Code;
      // the first LZW code is always smaller than FFirstCode
        if Code = FreeCode then
        begin
          StackPointer^ := FirstChar;
          Inc(StackPointer);
          Code := OldCode;
        end;
      // loop to put decoded bytes onto the stack
        while Code > ClearCode do
        begin
          StackPointer^ := Suffix[Code];
          Inc(StackPointer);
          Code := Prefix[Code];
        end;
      // place new code into code table
        FirstChar     := Suffix[Code];
        Stackpointer^ := FirstChar;
        Inc(Stackpointer);
        Prefix[FreeCode] := OldCode;
        Suffix[FreeCode] := FirstChar;
      // increase code size if necessary
        if (FreeCode = CodeMask) and (CodeSize < 12) then
        begin
          Inc(CodeSize);
          CodeMask := 1 shl CodeSize - 1;
        end;
        if FreeCode < 4095 then
          Inc(FreeCode);
      // put decoded bytes (from the stack) into the target Buffer
        OldCode := InCode;
        repeat
          Dec(StackPointer);
          Target^ := StackPointer^;
          Inc(Target);
          Dec(UnpackedSize);
        until StackPointer = @Stack;
      end;
      Inc(SourcePtr);
      Dec(PackedSize);
    end;
  end;

const
  GIF_TABLE_FLAG  = $80;
  GIF_TABLE_SIZE  = $07;
  GIF_BLOCK_IMAGE = $2C;
  GIF_BLOCK_EXT   = $21;
  GIF_BLOCK_END   = $3B;
  GIF_INTERLACED  = $40;

  PASS_S : array [0..4] of Byte = (0, 0, 4, 2, 1);
  PASS_I : array [0..4] of Byte = (1, 8, 8, 4, 2);

var
  Header : packed record
    Magic   : array [0..2] of Byte;
    Version : array [0..2] of Byte;
    Width   : Word;
    Height  : Word;
    Flags   : Byte;
    BgColor : Byte;
    Aspect  : Byte;
  end;

  Image : packed record
    Left, Top     : Word;
    Width, Height : Word;
    Flags         : Byte;
  end;

  Pallete : array [Byte, 0..4] of Byte;
  ChunkName, Size, Ext, Flag, b, InitCodeSize : Byte;
  Buffer : PByteArray;
  BufSize : LongInt;
  IndexBuffer : PByteArray;
  i, x, y : LongInt;
begin
  Result := False;
  Stream.Read(Header, SizeOf(Header));
  if Header.Flags and GIF_TABLE_FLAG > 0 then
    for i := 0 to (1 shl (Header.Flags and GIF_TABLE_SIZE + 1)) - 1 do
    begin
      Pallete[i][2] := Stream.ReadUInt8;
      Pallete[i][1] := Stream.ReadUInt8;
      Pallete[i][0] := Stream.ReadUInt8;
      Pallete[i][3] := 255;
    end;
//  Log('gPallete: ', 1 shl (Header.Flags and GIF_TABLE_SIZE + 1));
  while Stream.Position < Stream.Size do
  begin
    Stream.Read(ChunkName, SizeOf(ChunkName));
  //  Log(ConvHex(ChunkName, 1));
    case ChunkName of
      GIF_BLOCK_IMAGE :
        begin
          Stream.Read(Image, SizeOf(Image));
          if Image.Flags and GIF_TABLE_FLAG > 0 then
          begin
            Stream.Position := Stream.Position + (1 shl (Image.Flags and GIF_TABLE_SIZE + 1)) * 3;
//            Log('lPallete: ', 1 shl (Image.Flags and GIF_TABLE_SIZE + 1));
          end;
          Stream.Read(InitCodeSize, SizeOf(InitCodeSize));

          if not Result then
          begin
            Width  := Header.Width;
            Height := Header.Height;
            Data := GetMemory(Width * Height * 4);
            Result := True;
          end;
        // get compressed data size
          BufSize := 0;
          i := Stream.Position;
          repeat
            Stream.Read(Size, SizeOf(Size));
            Inc(BufSize, Size);
            Stream.Position := Stream.Position + Size;
          until (Size = 0);
          Stream.Position := i;
        // get compressed data
          i := 0;
          Buffer := GetMemory(BufSize);
          repeat
            Stream.Read(Size, SizeOf(Size));
            Stream.Read(Buffer[i], Size);
            Inc(i, Size);
          until (Size = 0);
        // decompress data
          IndexBuffer := GetMemory(Width * (Height + 1)); // with reserved
          FillChar(IndexBuffer^, Width * (Height + 1), 0); // temp
          DecompressLZW(InitCodeSize, Buffer, IndexBuffer, BufSize, Width * (Height + 1));
          FreeMemory(Buffer);
        // fill data from pallete indices
          Buffer := IndexBuffer;
          x := Byte(Image.Flags and GIF_INTERLACED > 0);
          y := x * 4;
          for i := x to y do
          begin
            y := PASS_S[i];
            while y < Height do
            begin
              for x := 0 to Width - 1 do
                Move(Pallete[Buffer^[x]], Data^[((Height - y - 1) * Width + x) * 4], 4);
              Buffer := @Buffer^[Width];
              Inc(y, PASS_I[i]);
            end;
          end;
          FreeMemory(IndexBuffer);
          Exit; // load only first frame
        end;
      GIF_BLOCK_EXT :
        begin
          Stream.Read(Ext, SizeOf(Ext));
          Stream.Read(Size, SizeOf(Size));
          Flag := Stream.ReadUInt8;
          case Ext of
            $F9 : // Frame information
              begin
                Stream.ReadUInt16; // delay...
                b := Stream.ReadUInt8;
                if Flag and 1 > 0 then
                  Pallete[b][3] := 0; // Transparent color
                Size := 0;
              end;
          end;
          while Size > 0 do
          begin
            Stream.Position := Stream.Position + Size;
            Stream.Read(Size, SizeOf(Size));
          end;
        end;
      GIF_BLOCK_END :
        break;
    end;
  end;
end;