{****************************************************************************}
{Unit VNM_GIF - it is a addon unit for graphics library VenomGFX.            }
{It brings a loader for .GIF graphics files                                  }
{      written by Michael Knapp, adjusted by Laaca                           }
{****************************************************************************}
unit vnm_GIF;

{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}
{$ASMMODE INTEL}

interface
uses VenomGFX;


Function Load_GIF(s:string;var w:virtualwindow):byte;
{virtualwindow W will be initialized inside loader}
Function Load_AnimGIF(s:string;no:byte;var w:virtualwindow):byte;
{variant for animated GIFs}


implementation
uses GRPfile,VenomMng,objects;

{========================== LoadImageGIF ==================================}

FUNCTION LoadImageGIF(stream:pstream;var img:VirtualWindow;nr:longint):longint;
TYPE ppal=^tpal;
     tpal=array[0..255] of longint;

CONST ilstart:array[1..4] of longint=(0,4,2,1);
      ilstep:array[1..4] of longint=(8,8,4,2);
      bytperpix = 2;

  PROCEDURE DumpData;
  VAR count:byte;
  BEGIN
    REPEAT
      stream^.read(count,1);
{DBGns;
DBG('dump '+long2str(count)); }
      stream^.seek(stream^.getpos+count);
    UNTIL (count=0) OR (stream^.getpos>=stream^.getsize);
{DBG('');}
  END;

  PROCEDURE decodeGIFLZW(image:VirtualWindow;pal:ppal;interlaced:boolean);
  VAR xd,yd:longint;
  CONST tablen=4095;
  TYPE Pstr=^Tstr;
       Tstr=packed RECORD
         prefix:Pstr;
         suffix:longint;
       END;
       Pstrtab=^Tstrtab;
       Tstrtab=packed array[0..tablen] of Tstr;

  VAR strtab:Pstrtab;
      oldcode,curcode,clearcode,endcode:longint;
      codesize,codelen,codemask:longint;
      stridx:longint;
      bitbuf,bitsinbuf:longint;
      bytbuf:array[0..255] of byte;
      bytinbuf,bytbufidx:byte;
      endofsrc:boolean;
      xcnt,ycnt,pcnt,ystep,pass:longint;
      imageypos:pointer;

    PROCEDURE InitStringTable;
    VAR i:longint;
    BEGIN
      new(strtab);
      clearcode:=1 SHL codesize;
      endcode:=clearcode+1;
      stridx:=endcode+1;
      codelen:=codesize+1;
      codemask:=(1 SHL codelen)-1;
      FOR i:=0 TO clearcode-1 DO
        BEGIN
          strtab^[i].prefix:=nil;
          strtab^[i].suffix:=i;
        END;
      FOR i:=clearcode TO tablen DO
        BEGIN
          strtab^[i].prefix:=nil;
          strtab^[i].suffix:=0;
        END;
    END;

    PROCEDURE ClearStringTable;
    VAR i:longint;
    BEGIN
      clearcode:=1 SHL codesize;
      endcode:=clearcode+1;
      stridx:=endcode+1;
      codelen:=codesize+1;
      codemask:=(1 SHL codelen)-1;
      FOR i:=clearcode TO tablen DO
        BEGIN
          strtab^[i].prefix:=nil;
          strtab^[i].suffix:=0;
        END;
    END;

    PROCEDURE DoneStringTable;
    BEGIN
      dispose(strtab);
    END;

    FUNCTION GetNextCode:longint;
    BEGIN
      WHILE (bitsinbuf<codelen) DO
        BEGIN
          IF (bytinbuf=0) THEN
            BEGIN
              stream^.read(bytinbuf,1);
              IF (bytinbuf=0) THEN endofsrc:=TRUE;
              stream^.read(bytbuf,bytinbuf);
              bytbufidx:=0;
            END;
          bitbuf:=bitbuf OR (longint(byte(bytbuf[bytbufidx])) SHL bitsinbuf);
          inc(bytbufidx);
          dec(bytinbuf);
          inc(bitsinbuf,8);
        END;
      getnextcode:=bitbuf AND codemask;
{DBG(bitbuf AND codemask);}
      bitbuf:=bitbuf SHR codelen;
      dec(bitsinbuf,codelen);
    END;

    PROCEDURE AddStr2Tab(prefix:Pstr;suffix:longint);
    BEGIN
      strtab^[stridx].prefix:=prefix;
      strtab^[stridx].suffix:=suffix;
      inc(stridx);
      CASE stridx OF
      0..1:codelen:=1;
      2..3:codelen:=2;
      4..7:codelen:=3;
      8..15:codelen:=4;
      16..31:codelen:=5;
      32..63:codelen:=6;
      64..127:codelen:=7;
      128..255:codelen:=8;
      256..511:codelen:=9;
      512..1023:codelen:=10;
      1024..2047:codelen:=11;
      2048..4096:codelen:=12;
      END;
      codemask:=(1 SHL codelen)-1;
    END;

    FUNCTION Code2Str(code:longint):Pstr;
    BEGIN
      Code2Str:=addr(strtab^[code]);
    END;

    PROCEDURE WriteStr(s:Pstr);
    BEGIN
      IF (s^.prefix<>nil) THEN WriteStr(s^.prefix);
      IF (ycnt>=yd) THEN
        BEGIN
          IF interlaced THEN
            BEGIN
              WHILE (ycnt>=yd) AND (pass<5) DO
                BEGIN
                  inc(pass);
                  ycnt:=ilstart[pass];
                  ystep:=ilstep[pass];
                  imageypos:=pointer(img.VWOffset+ycnt*img.bytebreite);  {imageypos:=img^.pixeldata+ycnt*image^.bytesperline;}
                END;
{            END
          ELSE
            BEGIN
DBG('#########################');
              inc(pass); }
            END;
{          xcnt:=0; }
        END;
{       IF NOT finished THEN}
     {   BEGIN }
      move(pal^[s^.suffix],(imageypos+xcnt*bytperpix)^,bytperpix);
{putimage(0,0,image);}

{dbg(pal^[s^.suffix]);}
      inc(xcnt);
      IF (xcnt>=xd) THEN
        BEGIN
          inc(pcnt);
          xcnt:=0;
          inc(ycnt,ystep);
{DBGns;
DBG('line '+long2str(ycnt)+'/'+long2str(yd));}
          inc(imageypos,ystep*img.bytebreite  {image^.bytesperline});
          IF NOT interlaced THEN
            IF (ycnt>=yd) THEN
              BEGIN
                inc(pass);
{putimage(0,0,image);
DBG('%%%%%%%%%%%%%%%%%%%%%%%%%');}
              END;

{putimage(0,0,image);}
        END;
   {     END; }
    END;

    FUNCTION firstchar(s:Pstr):byte;
    BEGIN
      WHILE (s^.prefix<>nil) DO s:=s^.prefix;
      firstchar:=s^.suffix;
    END;

  BEGIN
{DBG('lzw start');}
    endofsrc:=FALSE;
    xd:=img.breite;
    yd:=img.hoehe;
    xcnt:=0;
    pcnt:=0;
    IF interlaced THEN
      BEGIN
        pass:=1;
        ycnt:=ilstart[pass];
        ystep:=ilstep[pass];
      END
    ELSE
      BEGIN
        pass:=4;
        ycnt:=0;
        ystep:=1;
      END;
    imageypos:=pointer(img.VWoffset+ycnt*img.bytebreite);
    oldcode:=0;
    bitbuf:=0;
    bitsinbuf:=0;
    bytinbuf:=0;
    bytbufidx:=0;
    codesize:=0;
    stream^.read(codesize,1);
{DBG(codesize);}
    InitStringTable;
    curcode:=getnextcode;
{DBG(curcode);}
    WHILE (curcode<>endcode) AND (pass<5) AND NOT endofsrc{ AND NOT finished} DO
      BEGIN
{DBG('-----');
DBG(curcode);
DBGw(stridx);}
        IF (curcode=clearcode) THEN
          BEGIN
            ClearStringTable;
            REPEAT
              curcode:=getnextcode;
{DBG('lzw clear');}
            UNTIL (curcode<>clearcode);
            IF (curcode=endcode) THEN break;
            WriteStr(code2str(curcode));
            oldcode:=curcode;
          END
        ELSE
          BEGIN
            IF (curcode<stridx) THEN
              BEGIN
                WriteStr(Code2Str(curcode));
                AddStr2Tab(Code2Str(oldcode),firstchar(Code2Str(curcode)));
                oldcode:=curcode;
              END
            ELSE
              BEGIN
                IF (curcode>stridx) THEN break;
                AddStr2Tab(Code2Str(oldcode),firstchar(Code2Str(oldcode)));
                WriteStr(Code2Str(stridx-1));
                oldcode:=curcode;
              END;
          END;
        curcode:=getnextcode;
      END;
    DoneStringTable;
{putimage(0,0,image);}
{DBG('lzw end');
DBG(bytinbuf);}
    IF NOT endofsrc THEN DumpData;
{DBG('lzw finished');}
  END;

TYPE TGIFSignature=packed array[1..6] of char;

     TGIFScreenDescriptor=packed RECORD
       width,height:word;
       flags,background,map:byte;
     END;

     TGIFImageDescriptor=packed RECORD
       x,y,xd,yd:word;
       flags:byte;
     END;

     TGIFExtensionBlock=packed RECORD
       functioncode:byte;
     END;

     TGIFGraphicControlExtension=packed RECORD
       flags:byte;
       delaytime:word;
       transcolor:byte;
     END;

     TRGB=packed RECORD
       r,g,b:byte;
     END;

VAR GIFSignature:TGIFSignature;
    GIFScreenDescriptor:TGIFScreenDescriptor;
    GIFBlockID:char;
    GIFImageDescriptor:TGIFImageDescriptor;
    GIFExtensionBlock:TGIFExtensionBlock;
    GIFGraphicControlExtension:TGIFGraphicControlExtension;
    xd,yd:longint;
    count:byte;
    transcolor:longint;
    transparency,imageloaded:boolean;

VAR i:longint;
    globalpal,localpal:tpal;
    pal:ppal;
    startpos:longint;
    rgb:trgb;

BEGIN
{DBG('GIF start');}
  LoadImageGIF:=-1;
  IF (nr<1) THEN exit;
  startpos:=stream^.getpos;
  transcolor:=0;
  transparency:=FALSE;
  imageloaded:=FALSE;
  stream^.Read(GIFSignature,sizeof(GIFSignature));
  IF (GIFSignature[1]='G') AND (GIFSignature[2]='I') AND (GIFSignature[3]='F') THEN
    BEGIN
{DBG('GIF ok');}
      stream^.read(GIFScreenDescriptor,sizeof(GIFScreenDescriptor));
      IF (GIFScreenDescriptor.flags AND $80=$80) THEN
        BEGIN
          pal:=@globalpal;
          FOR i:=0 TO (1 SHL (GIFScreenDescriptor.flags AND $07+1))-1 DO
             BEGIN
               stream^.read(rgb,3);
               globalpal[i]:=MyRGB2word(rgb.r,rgb.g,rgb.b);
             END;
        END;
      REPEAT
        stream^.read(GIFBlockID,sizeof(GIFBlockID));
{DBG(GIFBlockID);}
        CASE GIFBlockID OF
        ';':;
        ',':BEGIN  { Image separator }
              dec(nr);
              IF NOT imageloaded THEN
                BEGIN
                  pal:=@globalpal;
                  stream^.read(GIFImageDescriptor,sizeof(GIFImageDescriptor));
                  IF (GIFImageDescriptor.flags AND $80=$80) THEN
                    BEGIN
                      pal:=@localpal;
{DBG('#LP');
DBG((2 SHL (GIFImageDescriptor.flags AND $07)));}
                      FOR i:=0 TO (2 SHL (GIFImageDescriptor.flags AND $07))-1 DO
                        BEGIN
                          stream^.read(rgb,3);
                          localpal[i]:=MyRGB2word(rgb.r,rgb.g,rgb.b);
                        END;
                      END;
                  xd:=GIFImageDescriptor.xd;
                  yd:=GIFImageDescriptor.yd;
{IF yd>768 then exit;}
{DBG(xd);
DBG(yd);}
                  IF (nr<=0) THEN
                    BEGIN
{DBG('a');}
                      Init_VW(img,xd,yd,false);  {img:=createimagewh(xd,yd);}

{DBG('b');}
                      DecodeGIFLZW(img,pal,(GIFImageDescriptor.flags AND $40=$40));
                      imageloaded:=TRUE;
                      LoadImageGIF:=0;
                    END
                  ELSE
                    BEGIN
                      stream^.read(count,1);
                      DumpData;
                    END;
                END
              ELSE
                BEGIN
                  GIFBlockID:=';';
                END;
            END;
        '!':BEGIN
              stream^.read(GIFExtensionBlock,sizeof(GIFExtensionBlock));
{DBG(GIFExtensionBlock.functioncode);}
              CASE GIFExtensionBlock.functioncode OF
              $F9:BEGIN
                    stream^.read(count,1);
                    stream^.read(GIFGraphicControlExtension,count);
                 {   REPEAT
                      stream^.read(count,1);
                    UNTIL (count=0); }
                    transcolor:=pal^[GIFGraphicControlExtension.transcolor];
                    transparency:=TRUE;
                    DumpData;
                  END;
              ELSE
                BEGIN
                  DumpData;
                END;
              END;
            END;
        ELSE exit;
        END;
      UNTIL (GIFBlockID=';') OR (stream^.getpos>=stream^.getsize);
      IF transparency THEN
        IF (img.VWoffset<>0) THEN
          BEGIN
            {
            img^.flags:=img_transparency;
            img^.transparencycolor:=transcolor;
            }
          END;
    END;
{DBG('GIF end');}
  stream^.seek(startpos);
END;


Function Load_GIF(s:string;var w:virtualwindow):byte;
begin
Load_GIF:=Load_AnimGIF(s,1,w);
end;

Function Load_AnimGIF(s:string;no:byte;var w:virtualwindow):byte;
var grp:PGrpStream;
    l:longint;
begin
w.VWoffset:=0;
grp:=New(PGRPstream,Init(s,stOpenRead));
l:=-LoadImageGIF(grp,w,no {cislo obrazku v GIF souboru}); {OK = 0, chyba = 1}
if l=1 then
   begin
   if w.VWoffset<>0 then Kill_VW(w);
   w.VWoffset:=0;
   end;
Dispose(grp,Done);
Load_AnimGIF:=l
end;


Procedure Register_GIF_Loader;
begin
RegisterImageLoader('GIF',@Load_GIF);
end;

begin
Register_GIF_Loader;
end.
