Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GIFPASSE.ZIP/NGIF.PAS

Pascal/Delphi Source File | 1989-02-27 | 10.3 KB | 411 lines

unit ngif;

       { Steve Enns Feb.26 1989
         Copyright 1989 Steve Enns   All rights reserved.
         Synergrafix - Graphical and Numerical Software
         2425 Haultain Ave. Saskatoon, Sask. Canada  S7J 1R2

         GIF ENcoding for BGI graphics
         Must be in graphics mode before call

         This software is provided for unlimited use and
         distribution EXCEPT for the following conditions:
           - No fee is to be charged for the use or distribution
             of this software, including any works which include
             the source code or compiled form of this software.
           - Any derived software or software which uses the source
             code or compiled versions of this software must include
             the source code of the derived software, and this notice.
           - This software is to be distributed in the original
             archived form, with the SAME name, GIFPASSE,
             i.e. GIFPASSE.ZIP, GIFPASSE.ARC.

         This software is provided without warranty of any kind,
         express or implied. YOU, the user assume complete
         responsibility for any and all incidental or consequential
         damages arising out of the use of this program. Use
         at your own risk.

         This license is intended to encourage the distribution of
         programs which include source code!

         'GIF' and 'Graphics Interchange Format' are trademarks
          of Compuserve, Inc., an H&R Block Company. }

interface

const bigbitsmax=12;
      hsizemax=5003;
      maxcolarray=255;
      masks :array[0..16] of longint=($0000,$0001,$0003,$0007,$000F,
                                      $001F,$003F,$007F,$00FF,
                                      $01FF,$03FF,$07FF,$0FFF,
                                      $1FFF,$3FFF,$7FFF,$FFFF);

type colarray=array[0..maxcolarray] of integer;

var htab     :array[0..hsizemax-1] of longint;
    codetab  :array[0..hsizemax-1] of integer;

Function engif(fname          :string; { filename for the GIF file }
               startx,starty,          { upper left corner of image }
               stopx,stopy    :integer;{ lower right corner of image }
               colormap,               { TRUE for colormap }
               interlace      :boolean;{ TRUE for interlace encoding }
               background,             { background color index }
               bitsperpixel   :integer;{ 1 shl bitsperpixel=numcolors }
               red,green,blue :colarray{ color components for colormap }
              ):boolean;               { returns FALSE for failure }

implementation

uses dos,                    { REGISTERS, MSDOS }
     graph;                  { PUTPIXEL, GETPIXEL }

{$R-,S-}                     { Speed }
{ DEFINE SHOWPROGRESS}       { To erase pixels as they are read }

Function engif(fname          :string;
               startx,starty,
               stopx,stopy    :integer;
               colormap,
               interlace      :boolean;
               background,
               bitsperpixel   :integer;
               red,green,blue :colarray):boolean;

var ioerror                       :boolean;
    width,height,rwidth,rheight,
    leftofs,topofs,resolution,
    colormapsize,initcodesize,
    i,b,n_bits,maxbits,maxcode,
    maxmaxcode,free_ent,exit_stat,
    clear_flg,offset,clearcode,
    eofcode,cur_bits,a_count,
    curx,cury,pass,g_init_bits    :integer;
    hsize,fsize,in_count,
    out_count,countdown,cur_accum :longint;
    accum                         :array[0..255] of char;
    fp                            :text;

{$I-}

Procedure flush_char;
var i:byte;
begin
   if a_count>0 then
   begin
      write(fp,chr(a_count));
      for i:=0 to a_count-1 do
         write(fp,accum[i]);
      a_count:=0
   end
end;

Procedure char_out(c:integer);
begin
   accum[a_count]:=chr(c);
   inc(a_count);
   if a_count>=254 then
      flush_char
end;

Procedure output(code:longint);
begin
   cur_accum:=cur_accum and masks[ cur_bits ];
   if cur_bits>0 then
      cur_accum:=cur_accum or (code shl cur_bits)
   else
      cur_accum:=code;
   inc(cur_bits,n_bits);
   while cur_bits>=8 do
   begin
      char_out(cur_accum and $ff);
      cur_accum:=cur_accum shr 8;
      dec(cur_bits,8)
   end;
   if (free_ent>maxcode) or (clear_flg<>0) then
   begin
      if clear_flg<>0 then
      begin
         n_bits:=g_init_bits;
         maxcode:={ maxcodef(n_bits); } (1 shl n_bits)-1;
         clear_flg:=0;
      end else
      begin
         inc(n_bits);
         if n_bits=maxbits then
            maxcode:=maxmaxcode
         else
            maxcode:={ maxcodef(n_bits) } (1 shl n_bits)-1
      end
   end;
   if code=eofcode then
   begin
      while cur_bits>0 do
      begin
         char_out(cur_accum and $ff);
     cur_accum:=cur_accum shr 8;
     dec(cur_bits,8)
      end;
      flush_char;
      flush(fp)
   end
end;

Procedure cl_hash(hsize:longint);      { reset code table }
var i :word;
begin
   for i:=0 to hsize-1 do
      htab[i]:=-1
end;

Procedure cl_block;                    { table clear for block compress }
begin
   cl_hash(hsize);
   free_ent:=clearcode+2;
   clear_flg:=1;
   output(clearcode)
end;

Procedure putword(w:integer);
begin
   write(fp,chr(w and $ff));
   write(fp,chr((w shr 8) and $ff))
end;

Procedure setrawmode(handle:word);
var regs :registers;
begin
   with regs do
   begin
      ax:=$4401;                       { Set the new device status }
      bx:=handle;
      dx:=dx and $00DF;                { Clear the RAW bit }
      inc(dx,32);
      msdos(regs)
   end
end;

Procedure bumppixel;
begin
   inc(curx);

   if curx>stopx then
   begin
      curx:=startx;
      if not interlace then
         inc(cury)
      else
      case pass of
         0:begin
              inc(cury,8);
              if cury>=(stopy+1) then
              begin
                 inc(pass);
                 cury:=4+starty
              end;
           end;
         1:begin
              inc(cury,8);
              if cury>=(stopy+1) then
              begin
                 inc(pass);
                 cury:=2+starty
              end
           end;
         2:begin
              inc(cury,4);
              if cury>=(stopy+1) then
              begin
                 inc(pass);
                 cury:=1+starty
              end
           end;
         3:inc(cury,2)
      end
   end
end;

Function gifnextpixel(var c:integer):integer;
begin
   if countdown=0 then
   begin
      c:=-1;
      gifnextpixel:=-1
   end else
   begin
      dec(countdown);
      c:=getpixel(curx,cury);
      gifnextpixel:=c;
{$IFDEF SHOWPROGRESS}
      putpixel(curx,cury,0);
{$ENDIF}
      bumppixel
   end
end;

Procedure compress(init_bits:integer);
label loop,probe,nomatch;
var fcode           :longint;
    c,hshift,i,ent,
    disp,hsize_reg  :integer;
begin
   i:=0;
   g_init_bits:=init_bits;
   offset:=0;
   out_count:=0;
   clear_flg:=0;
   in_count:=1;
   n_bits:=g_init_bits;
   maxcode:={maxcodef(n_bits);} (1 shl n_bits)-1;
   clearcode:=1 shl (init_bits-1);
   eofcode:=clearcode+1;
   free_ent:=clearcode+2;
   a_count:=0;
   ent:=gifnextpixel(c);
   hshift:=0;
   fcode:=hsize;
   while fcode<65536 do
   begin
      fcode:=fcode*2;
      inc(hshift)
   end;
   hshift:=8-hshift;                  { set hash code range bound }
   hsize_reg:=hsize;
   cl_hash(hsize_reg);                { clear hash table }
   output(clearcode);

   while gifnextpixel(c)<>-1 do
   begin
      inc(in_count);
      fcode:=(c shl maxbits)+ent;
      i:=(c shl hshift) xor ent;       { xor hashing }
      if htab[i]=fcode then
      begin
         ent:=codetab[i];
         goto loop
      end
      else if htab[i]<0 then           { empty slot }
              goto nomatch;
      disp:=hsize_reg-i;             { secondary hash (after G. Knott) }
      if i=0 then
         disp:=1;
      probe:
      dec(i,disp);
      if i<0 then
         inc(i,hsize_reg);
      if htab[i]=fcode then
      begin
         ent:=codetab[i];
         goto loop
      end;
      if htab[i]>0 then
         goto probe;
      nomatch:
      output(ent);
      inc(out_count);
      ent:=c;
      if free_ent<maxmaxcode then
      begin
         codetab[i]:=free_ent;         { code -> hashtable }
         inc(free_ent);
         htab[i]:=fcode
      end else
         cl_block;
      loop:
   end;

   output(ent);
   inc(out_count);
   output(eofcode)

end;


begin
   maxbits:=bigbitsmax;
   maxmaxcode:=1 shl bigbitsmax;
   hsize:=hsizemax;
   free_ent:=0;
   exit_stat:=0;
   clear_flg:=0;
   in_count:=1;
   out_count:=0;
   cur_accum:=0;
   cur_bits:=0;
   colormapsize:=1 shl bitsperpixel;

   width:=stopx-startx+1;  {gwidth;}
   height:=stopy-starty+1; {gheight;}

   rwidth:=width;
   rheight:=height;

   leftofs:=0; topofs:=0;

   resolution:=bitsperpixel;
   countdown:=round(width)*round(height);
   pass:=0;
   if bitsperpixel<=1 then
      initcodesize:=2
   else
      initcodesize:=bitsperpixel;

   curx:=startx;
   cury:=starty;

   assign(fp,fname);
   rewrite(fp);
   setrawmode(textrec(fp).handle);
   ioerror:=(ioresult<>0);

   if not ioerror then
   begin
      write(fp,'GIF87a');
      putword(rwidth);
      putword(rheight);
      if colormap then
         b:=$80           { Yes, there is a color map }
      else
         b:=0;
      b:=b or ((resolution - 1) shl 5);
      b:=b or (bitsperpixel - 1);
      write(fp,chr(b));
      write(fp,chr(background));
      write(fp,chr(0));
      if colormap then
         for i:=0 to colormapsize-1 do
         begin
            write(fp,chr(red[i]));
            write(fp,chr(green[i]));
            write(fp,chr(blue[i]))
         end;
      write(fp,',');
      putword(leftofs);
      putword(topofs);
      putword(width);
      putword(height);
      if interlace then
         write(fp,chr($40))
      else
         write(fp,chr(0));
      write(fp,chr(initcodesize));

      compress(initcodesize+1);

      write(fp,chr(0));
      write(fp,';');

      close(fp)
   end;

   ioerror:=(ioresult<>0);
   engif:=not ioerror

{$I+}

end;

begin
end.