unit GifLZW;

// Example of GIF-NONLZW compression and LZW decompression plug-in for ImageEn

{$I IE.INC}

interface

uses Windows, Graphics, classes, sysutils, ieutils;

procedure GIFNONLZWCompress(Stream: TStream; Height,Width:integer; Interlaced:boolean; FData:pchar; BitsPerPixel:integer);
procedure GIFLZWDecompress(Stream: TStream; Height,Width:integer; Interlaced:boolean; FData:pchar);


implementation

type

	TDecodeData = record
      ReadPos:integer;
      DataLen:integer;
      BitsLeft:Integer;
      CurrByte:Longint;
      PosY:Integer;
      InterlacePass:Integer;
      LZWCodeSize:Byte;
      CurrCodeSize:Integer;
      ClearCode:Integer;
      EndingCode:Integer;
      HighCode:Word;
	end;

	TCodeTable = record
      Suffix, Prefix: Array[1..4096] of Word;
      CodeSize: Byte;
      TableFull: Boolean;
      Firstprt, Nextprt: Word;
	end;

function GetNL(LineNo, Height: Integer; var InterlacePass: Integer): Integer;
begin
   result:=0;
   case InterlacePass of
      1: Result := LineNo + 8;
      2: Result := LineNo + 8;
      3: Result := LineNo + 4;
      4: Result := LineNo + 2;
   end;
   if Result >= Height then begin
      Inc(InterLacePass);
      case InterLacePass of
         2: Result := 4;
         3: Result := 2;
         4: Result := 1;
      end;
   end;
end;

procedure InitCompressionStream(InitLZWCodeSize: Byte; var DecData: TDecodeData);
begin
   with DecData do begin
      LZWCodeSize := InitLZWCodeSize;
      if not (LZWCodeSize in [2..9]) then
      	raise EInvalidGraphic.create('Corrupted GIF');
      CurrCodeSize := succ(LZWCodeSize);
      ClearCode := 1 shl LZWCodeSize;
      EndingCode := succ(ClearCode);
      HighCode := pred(ClearCode);
      BitsLeft := 0;
      PosY := 0;
      InterlacePass := 1;
   end;
end;

function NextCode(var ba:TIEByteArray; var DecData: TDecodeData): word;
const
	CodeMsk: array[0..12] of Word = (
	  0, $0001, $0003, $0007, $000F,
     $001F, $003F, $007F, $00FF,
     $01FF, $03FF, $07FF, $0FFF);
var
	LongResult: Longint;
begin
  with DecData do begin
     if BitsLeft = 0 then begin
        CurrByte :=ba.Data^[ReadPos];
        inc(ReadPos);
        BitsLeft := 8;
     end;
     LongResult := CurrByte shr (8 - BitsLeft);
     while CurrCodeSize > BitsLeft do begin
        CurrByte := ba.Data^[ReadPos];
        inc(ReadPos);
        LongResult := LongResult or (CurrByte shl BitsLeft);
        BitsLeft := BitsLeft + 8;
     end;
     BitsLeft := BitsLeft - CurrCodeSize;
     Result := LongResult and CodeMsk[CurrCodeSize];
  end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure GIFLZWDecompress(Stream: TStream; Height,Width:integer; Interlaced:boolean; FData:pchar);
var
  SP: integer;
  DecodeDat: array[0..4095] of byte;
  DecData: TDecodeData;
  Prefix: array[0..4095] of integer;
  Suffix: array[0..4095] of integer;
  CurrBuf: word;
  pix:pbytearray;
  LZWCodeSize:byte;
  CompData:TIEByteArray;
  procedure DecodeCode(var Code: word);
  begin
    while Code > DecData.HighCode do begin
       DecodeDat[SP] := Suffix[Code];
       inc(SP);
       Code := Prefix[Code];
    end;
    DecodeDat[SP] := Code;
    Inc(SP);
  end;
  procedure GetDat;
  begin
    with DecData do
    	while SP > 0 do begin
         dec(SP);
         pix^[PosY*Width+CurrBuf-1] := DecodeDat[SP];
         inc(CurrBuf);
         if CurrBuf > Width then begin
            if not InterLaced then Inc(PosY)
            else PosY := GetNL(PosY, Height, InterlacePass);
            CurrBuf := 1;
         end;
	 	end;
  end;
  procedure CheckprtValue(var prt, Topprt: Word; var MaxVal: Boolean);
  begin
    if prt >= Topprt then begin
      if DecData.CurrCodeSize < 12 then begin
        Topprt := Topprt shl 1;
        inc(DecData.CurrCodeSize)
      end else
        MaxVal := True;
    end;
  end;

var
   TempOldCode, OldCode: word;
   Code, C: word;
   MaxVal: boolean;
   prt     : Word;
   Topprt  : Word;
   b:byte;
begin
   Stream.Read(LZWCodeSize, 1);
   pix:=pbytearray(fData);
   InitCompressionStream(LZWCodeSize, DecData);
   DecData.DataLen:=0;
   CompData:=TIEByteArray.Create;
   repeat
     Stream.Read(b,1);
     if b=0 then break;
     CompData.AppendFromStream(Stream,b);
     DecData.DataLen:=DecData.DataLen+b;
   until false;
   DecData.ReadPos:=0;
   OldCode := 0;
   SP := 0;
   CurrBuf := 1;
   MaxVal := False;
   if DecData.ReadPos>=DecData.DataLen then begin
	   CompData.free;
      exit;
   end;
   C := NextCode(CompData, DecData);
   while C <> DecData.EndingCode do begin
      if C = DecData.ClearCode then begin
         DecData.CurrCodeSize := DecData.LZWCodeSize + 1;
         prt := DecData.EndingCode + 1;
         Topprt := 1 shl DecData.CurrCodeSize;
         while C = DecData.ClearCode do begin
           if DecData.ReadPos>=DecData.DataLen then begin
              CompData.free;
              exit;
           end;
           C := NextCode(CompData, DecData);
         end;
         if C = DecData.EndingCode then
            raise EInvalidGraphic.create('Corrupted GIF');
         if C >= prt then
            C := 0;
         OldCode := C;
         DecodeDat[SP] := C;
         inc(SP);
      end else begin
         Code := C;
         if Code < prt then begin
            DecodeCode(Code);
            if prt <= Topprt then begin
               Suffix[prt] := Code;
               Prefix[prt] := OldCode;
               inc(prt);
               CheckprtValue(prt, Topprt, MaxVal);
               OldCode := C;
            end;
         end else begin
            if Code <> prt then
                raise EInvalidGraphic.create('Corrupted GIF');
            TempOldCode := OldCode;
            while OldCode > DecData.HighCode do begin
               DecodeDat[SP] := Suffix[OldCode];
               OldCode := Prefix[OldCode];
            end;
            DecodeDat[SP] := OldCode;
            if prt <= Topprt then begin
               Suffix[prt] := OldCode;
               Prefix[prt] := TempOldCode;
               inc(prt);
               CheckprtValue(prt, Topprt, MaxVal);
            end;
            DecodeCode(Code);
            OldCode := C;
         end;
      end;
      GetDat;
      if DecData.ReadPos>=DecData.DataLen then begin
         CompData.free;
         exit;
      end;
      C := NextCode(CompData, DecData);
      if (MaxVal = True) and (C <> DecData.ClearCode) then
        	raise EInvalidGraphic.create('Corrupted GIF');
      MaxVal := False;
   end;
   CompData.free;
end;

/////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////

(*-----------------------------------------------------------------------
 *
 * miGIF Compression - mouse and ivo's GIF-compatible compression
 *
 *          -run length encoding compression routines-
 *
 * Copyright (C) 1998 Hutchison Avenue Software Corporation
 *               http://www.hasc.com
 *               info@hasc.com
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies and that both that
 * copyright notice and this permission notice appear in supporting
 * documentation.  This software is provided "AS IS." The Hutchison Avenue
 * Software Corporation disclaims all warranties, either express or implied,
 * including but not limited to implied warranties of merchantability and
 * fitness for a particular purpose, with respect to this code and accompanying
 * documentation.
 *
 * The miGIF compression routines do not, strictly speaking, generate files
 * conforming to the GIF spec, since the image data is not LZW-compressed
 * (this is the point: in order to avoid transgression of the Unisys patent
 * on the LZW algorithm.)  However, miGIF generates data streams that any
 * reasonably sane LZW decompresser will decompress to what we want.
 *
 * miGIF compression uses run length encoding. It compresses horizontal runs
 * of pixels of the same color. This type of compression gives good results
 * on images with many runs, for example images with lines, text and solid
 * shapes on a solid-colored background. It gives little or no compression
 * on images with few runs, for example digital or scanned photos.
 *
 *                               der Mouse
 *                      mouse@rodents.montreal.qc.ca
 *            7D C8 61 52 5D E7 2D 39  4E F1 31 3E E8 B3 27 4B
 *
 *                             ivo@hasc.com
 *
 * The Graphics Interchange Format(c) is the Copyright property of
 * CompuServe Incorporated.  GIF(sm) is a Service Mark property of
 * CompuServe Incorporated.
 *
 *
*)

type varblk = record
	rl_pixel:integer;
	rl_basecode:integer;
	rl_count:integer;
	rl_table_pixel:integer;
	rl_table_max:integer;
	just_cleared:integer;
	out_bits:integer;
	out_bits_init:integer;
	out_count:integer;
	out_bump:integer;
	out_bump_init:integer;
	out_clear:integer;
	out_clear_init:integer;
	max_ocodes:integer;
	code_clear:integer;
	code_eof:integer;
	obuf:dword;
	obits:integer;
	ofile:TStream;
	oblock: array [0..255] of byte;
	oblen:integer;
   //
   Data,Datap:pbyte;
   // interlaced
   fInterlaced:boolean;
   Pass,wlen,y,x:integer;
   iwidth,iheight:integer;
end;

/////////////////////////////////////////////////////////////////////////////////////
function isqrt(x:dword):dword;
var
	r:dword;
	v:dword;
begin
	if (x < 2) then begin
   	result:=x;
      exit;
   end;
   v:=x; r:=1;
   while v<>0 do begin
   	v:=v SHR 2;
      r:=r SHL 1;
   end;
	repeat
		v := trunc(((x / r) + r) / 2);
		if ((v = r) or (v = r+1)) then begin
      	result:=r;
         exit;
      end;
		r := v;
	until false;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure did_clear(var vb:varblk);
begin
	with vb do begin
		out_bits := out_bits_init;
		out_bump := out_bump_init;
		out_clear := out_clear_init;
		out_count := 0;
		rl_table_max := 0;
		just_cleared := 1;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure write_block(var vb:varblk);
begin
	with vb do begin
   	ofile.Write(oblen,1);
		ofile.Write(oblock[0],oblen);
		oblen := 0;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure block_out(var vb:varblk; c:byte);
begin
	with vb do begin
		oblock[oblen] := c;
      inc(oblen);
		if (oblen >= 255) then write_block(vb);
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure goutput(var vb:varblk; val:integer);
begin
   {$WARNINGS OFF}
	with vb do begin
		obuf := obuf or (val SHL obits);
		inc(obits,out_bits);
		while (obits >= 8) do begin
			block_out(vb,obuf and $ff);
		   obuf := obuf SHR  8;
		   dec(obits,8);
		end;
   end;
   {$WARNINGS ON}
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure output_plain(var vb:varblk; c:integer);
begin
	with vb do begin
		just_cleared := 0;
		goutput(vb,c);
		inc(out_count);
		if (out_count >= out_bump) then begin
			inc(out_bits);
			inc(out_bump , 1 SHL (out_bits - 1));
		end;
		if (out_count >= out_clear) then begin
			goutput(vb,code_clear);
			did_clear(vb);
		end;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure reset_out_clear(var vb:varblk);
begin
	with vb do begin
		out_clear := out_clear_init;
		if (out_count >= out_clear) then begin
			goutput(vb,code_clear);
			did_clear(vb);
      end;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure rl_flush_fromclear(var vb:varblk; count:integer);
var
	n:integer;
begin
	with vb do begin
		out_clear := max_ocodes;
		rl_table_pixel := rl_pixel;
		n := 1;
		while (count > 0) do begin
      	if (n = 1) then begin
         	rl_table_max := 1;
				output_plain(vb,rl_pixel);
				dec(count);
			end else if (count >= n) then begin
         	rl_table_max := n;
            output_plain(vb,rl_basecode+n-2);
       		dec(count, n);
			end else if (count = 1) then begin
         	inc(rl_table_max);
       		output_plain(vb,rl_pixel);
       		count := 0;
		   end else begin
         	inc(rl_table_max);
       		output_plain(vb,rl_basecode+count-2);
		      count := 0;
		   end;
		   if (out_count = 0) then n := 1 else inc(n);
		end;
	   reset_out_clear(vb);
	end;
end;

/////////////////////////////////////////////////////////////////////////////////////
function computetc(count:dword; nrepcodes:dword):dword;
var
	perrep:dword;
   n:dword;
begin
	result := 0;
	perrep := trunc((nrepcodes * (nrepcodes+1)) / 2);
	while (count >= perrep) do begin
		inc(result, nrepcodes);
		dec(count, perrep);
	end;
	if (count > 0) then begin
		n := isqrt(count);
		while ((n*(n+1)) >= 2*count) do dec(n);
		while ((n*(n+1)) < 2*count) do inc(n);
		inc(result, n);
	end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure rl_flush_clearorrep(var vb:varblk; count:integer);
var
	withclr:integer;
begin
	with vb do begin
		withclr := 1 + computetc(count,max_ocodes);
		if (withclr < count) then begin
			goutput(vb,code_clear);
			did_clear(vb);
			rl_flush_fromclear(vb,count);
		end else begin
	   	while count>0 do begin
	      	output_plain(vb,rl_pixel);
	         dec(count);
	      end;
		end;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure rl_flush_withtable(var vb:varblk; count:integer);
var
	repmax:integer;
	repleft:integer;
	leftover:integer;
begin
   {$WARNINGS OFF}
	with vb do begin
		repmax := trunc(count / rl_table_max);
		leftover := count mod rl_table_max;
      if leftover<>0 then repleft:=1 else repleft:=0;
	 	if (out_count+repmax+repleft > max_ocodes) then begin
      	repmax := max_ocodes - out_count;
			leftover := count - (repmax * rl_table_max);
			repleft := 1 + computetc(leftover,max_ocodes);
		end;
		if (1+computetc(count,max_ocodes) < repmax+repleft) then begin
      	goutput(vb,code_clear);
			did_clear(vb);
			rl_flush_fromclear(vb,count);
         exit;
		end;
		out_clear := max_ocodes;
      while repmax>0 do begin
			output_plain(vb,rl_basecode+rl_table_max-2);
         dec(repmax);
      end;
		if (leftover<>0) then begin
      	if (just_cleared<>0) then begin
         	rl_flush_fromclear(vb,leftover);
			end else if (leftover = 1) then begin
         	output_plain(vb,rl_pixel);
         end else begin
         	output_plain(vb,rl_basecode+leftover-2);
			end;
		end;
		reset_out_clear(vb);
   end;
   {$WARNINGS ON}
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure rl_flush(var vb:varblk);
begin
	with vb do begin
		if (rl_count = 1) then begin
      	output_plain(vb,rl_pixel);
			rl_count := 0;
         exit;
		end;
		if (just_cleared<>0) then begin
      	rl_flush_fromclear(vb,rl_count);
		end else if ((rl_table_max < 2) or (rl_table_pixel <> rl_pixel)) then begin
      	rl_flush_clearorrep(vb,rl_count);
		end else begin
      	rl_flush_withtable(vb,rl_count);
		end;
		rl_count := 0;
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
function GetNextPixel(var vb:varblk):integer;
begin
	with vb do begin
      dec(x);
      if (x<=0) then begin
        x:=iwidth;
        case(Pass) of
          0:
            begin
              inc(y, 8);
              if (y>=iheight) then begin
                inc(pass);
                y:=4;
              end;
            end;
          1:
            begin
              inc(y,8);
              if (y>=iheight) then begin
                inc(pass);
                y:=2;
              end;
            end;
          2:
            begin
              inc(y,4);
              if (y>=iheight) then begin
                inc(pass);
                Y:=1;
              end;
            end;
          3:
            inc(y,2);
        end;
        Datap:=pbyte(integer(Data)+(y*iWidth));
      end;
      result:=Datap^;
      inc(Datap);
   end;
end;

/////////////////////////////////////////////////////////////////////////////////////
procedure GIFNONLZWCompress(Stream: TStream; Height,Width:integer; Interlaced:boolean; FData:pchar; BitsPerPixel:integer);
var
	b:byte;
	c,bufdim:integer;
   vb:varblk;
   bufpos:integer;
begin
	bufdim:=Height*Width;	// only for 8 bitXpixel
   if BitsPerPixel=1 then BitsPerPixel:=2;
	b:=BitsPerPixel;
   Stream.Write(b,1);
   inc(BitsPerPixel);
   //
	bufpos:=0;
	with vb do begin
		ofile := Stream;
		obuf := 0;
		obits := 0;
		oblen := 0;
		code_clear := 1 SHL (BitsPerPixel - 1);
		code_eof := code_clear + 1;
		rl_basecode := code_eof + 1;
		out_bump_init := (1 SHL (BitsPerPixel - 1)) - 1;
      if (BitsPerPixel <= 3) then
			out_clear_init := 9
      else
			out_clear_init := out_bump_init-1;
		out_bits_init := BitsPerPixel;
		max_ocodes := $1000 - ((1 SHL (out_bits_init - 1)) + 3);
		did_clear(vb);
		goutput(vb,code_clear);
		rl_count := 0;
      y:=0;
      Pass:=0;
      iwidth:=width;
      iheight:=height;
		if Interlaced then
      	x:=iwidth
      else
      	x:=bufdim;
      Data:=pbyte(fData);
      Datap:=Data;
      fInterlaced:=Interlaced;
		repeat
      	if bufpos<bufdim then
            c:=GetNextPixel(vb)
         else
         	c := -1;
		   if (rl_count > 0) and (c <> rl_pixel) then
         	rl_flush(vb);
		   if c=-1 then
         	break;
		   if (rl_pixel = c) then
         	inc(rl_count)
			else begin
         	rl_pixel := c;
            rl_count := 1;
			end;
         inc(bufpos);
      until false;
		goutput(vb,code_eof);
      if (obits > 0) then
      	block_out(vb,obuf);
		if (oblen > 0) then
      	write_block(vb);
   end;
   //
	c:=0;
   Stream.Write(c,1);
end;



end.
