home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / gif / tpgif / cmprss.inc next >
Encoding:
Text File  |  1992-03-09  |  10.3 KB  |  231 lines
  1.  (*
  2.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  3.  []                              Cmp.Inc                               []
  4.  []                                                                    []
  5.  [] A Turbo Pascal Implementation of the CompuServe GIF LZW compress   []
  6.  [] algorithm.                                                         []
  7.  []                                                                    []
  8.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  9.  []                                                                    []
  10.  [] Usage:                                                             []
  11.  []        {$I Cmp.Inc }                                               []
  12.  []                                                                    []
  13.  []        Function GetByte;                                           []
  14.  []          begin                                                     []
  15.  []            GetByte:= ???;      { return a byte from the image }    []
  16.  []                                { return -1 at end-of-image }       []
  17.  []          end;                                                      []
  18.  []                                                                    []
  19.  []        Procedure PutByte;                                          []
  20.  []          begin                                                     []
  21.  []            ???(Lo(B));         { write the byte to the GIF file }  []
  22.  []          end;                                                      []
  23.  []                                                                    []
  24.  []        begin                                                       []
  25.  []          { open the GIF file }                                     []
  26.  []          GifResult:= CompressGif(MinCodeSize);                     []
  27.  []          { close the GIF file }                                    []
  28.  []        end.                                                        []
  29.  []                                                                    []
  30.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  31.  []                                                                    []
  32.  []   As noted, forward referenced procedure GetByte should return a   []
  33.  [] byte from the image to be compressed to GIF, and a -1 to indicate  []
  34.  [] end of image.                                                      []
  35.  []                                                                    []
  36.  []   To retain a close parallel with the C source, PutByte is passed  []
  37.  [] an integer, although the Lo() portion is the byte to move to the   []
  38.  [] output GIF file.                                                   []
  39.  []                                                                    []
  40.  []   As much as I hate labels and goto's, the compress routine uses   []
  41.  [] one, again to stay parallel with the C code.                       []
  42.  []                                                                    []
  43.  []   Although I haven't seen any documentation concerning MinCodeSize []
  44.  [] and its effect, GIF files that I've examined all seem to use 4.    []
  45.  []                                                                    []
  46.  []   As in Exp.Inc, I have kept the New() and Dispose() of CodeTable  []
  47.  [] in the CompressGIF function, although personal preference would be []
  48.  [] to move them to the program MainLine.                              []
  49.  []                                                                    []
  50.  []                                              Bob Berry [76555,167] []
  51.  []                                                                    []
  52.  [][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][][]
  53.  *)
  54.  
  55. Function GetByte: Integer;              Forward;
  56. Procedure PutByte(B: Integer);          Forward;
  57.  
  58. Const LargestCode                     = 4095;
  59.       TableSize                       = 5003;
  60.  
  61. Type  CodeEntry                       = Record
  62.                                           PriorCode: Integer; { 2 bytes }
  63.                                           CodeID:    Integer; { 2 bytes }
  64.                                           AddedChar: Byte;    { 1 byte  }
  65.                                         end;                  { 5 * 5004=24k+}
  66.       CodeTableType                   = Array[0..TableSize] of CodeEntry;
  67.       TablePointer                    = ^CodeTableType;
  68.  
  69. Var   CodeSize,   ClearCode,
  70.       EOFCode,    MinCode,
  71.       BitOffset,  ByteOffset,
  72.       BitsLeft,   MaxCode,
  73.       FreeCode,   PrefixCode,
  74.       SuffixChar,
  75.       Hx,         D:                    Integer;
  76.       CmpError:                         Integer;
  77.       CodeBuffer:                       Array[0..259] of Byte;
  78.       CodeTable:                        TablePointer;
  79.  
  80. Procedure InitializeTable(MinCodeSize: Byte);
  81.   Var I: Integer;
  82.   begin
  83.     CodeSize:=  Succ(MinCodeSize);
  84.     ClearCode:= 1 Shl MinCodeSize;
  85.     EOFCode:=   Succ(ClearCode);
  86.     FreeCode:=  Succ(EOFCode);
  87.     MaxCode:=   1 Shl CodeSize;
  88.     For I:=0 to Pred(TableSize) do CodeTable^[I].CodeID:=0;
  89.   end;   { Procedure InitializeTable }
  90.  
  91. Procedure FlushBuffer(N: Integer);
  92.   Var I: Integer;
  93.   begin
  94.     PutByte(N);
  95.     For I:=0 to Pred(N) do PutByte(CodeBuffer[I]);
  96.   end;   { Procedure FlushBuffer }
  97.  
  98. Procedure WriteCode(Code: Integer);
  99.   Var
  100.     AX,DX,I: Integer;
  101.   begin
  102.     ByteOffset:= BitOffset Shr 3;
  103.     BitsLeft:=   BitOffset And 7;
  104.     If ByteOffset>=254 then
  105.       begin
  106.         FlushBuffer(ByteOffset);
  107.         CodeBuffer[0]:=CodeBuffer[ByteOffset];
  108.         BitOffset:=BitsLeft;
  109.         ByteOffset:=0;
  110.       end;
  111.     If BitsLeft>0 then
  112.       Inline(
  113.       $8B/$46/<CODE      {     mov   ax,<Code[bp]       ; Ax:=Code;           }
  114.       /$31/$D2           {     xor   dx,dx              ; Dx:=0;              }
  115.       /$8B/$0E/>BITSLEFT {     mov   cx,[>BitsLeft]     ; Cx:=BitsLeft;       }
  116.       /$49               {A1:  dec   cx                 ; count a bit         }
  117.       /$7C/$06           {     jl    A2                 ; ( do cx shifts )    }
  118.       /$D1/$E0           {     shl   ax,1               ; shift bit into carry}
  119.       /$D1/$D2           {     rcl   dx,1               ; shift carry into Dx }
  120.       /$EB/$F7           {     jmp short A1             ; continue            }
  121.       /$BE/>CODEBUFFER   {A2:  mov   si,>CodeBuffer     ; point to CodeBuffer }
  122.       /$8B/$1E/>BYTEOFFSET{     mov   bx,[>ByteOffset]   ; index to ByteOffset}
  123.       /$08/$00           {     or    [si+bx],al         ; OR low eight bits   }
  124.       /$88/$60/$01       {     mov   [si+bx+1],ah       ;   move next 16 bits }
  125.       /$88/$50/$02)      {     mov   [si+bx+2],dl       ;  to ByteOffset +1,+2}
  126.     else
  127.       begin
  128.         CodeBuffer[ByteOffset]:=   Lo(Code);
  129.         CodeBuffer[ByteOffset+1]:= Hi(Code);
  130.       end;
  131.     BitOffset:=BitOffset+CodeSize;
  132.   end;   { Procedure WriteCode }
  133.  
  134. { ---------------------------------------------------------------------------
  135.   NOTE: For simplicity, CompressGIF does not test MinCodeSize for valid
  136.         values (in [2..9]), primarily since I was too lazy. As mentioned,
  137.         the "customary" value seems to be 4.
  138.  
  139.         "While True" and "GoTo Break" are used to parallel the C coding of
  140.         "For (;;)" and "break".
  141.   --------------------------------------------------------------------------- }
  142. Function CompressGIF(MinCodeSize: Byte): Integer;
  143.   Var   MAvail:   Integer;
  144.         MemAvail: Real;
  145.   Label Break;
  146.  
  147.   Function SuffixCharEqualGetByte: Integer;
  148.     begin
  149.       SuffixChar:=GetByte;
  150.       SuffixCharEqualGetByte:=SuffixChar;
  151.     end;   { Function SuffixCharEqualGetByte }
  152.  
  153.   begin
  154.     CmpError:=0; CompressGIF:=CmpError;
  155.  
  156. (*    MAvail:=MaxAvail;
  157.     If MAvail<0 then MemAvail:=65536.0+MAvail
  158.     else             MemAvail:=    0.0+MAvail;
  159.     MemAvail:=16.0*MemAvail;
  160.     If MemAvail<SizeOf(CodeTableType) then
  161. *)
  162.     If MaxAvail<SizeOf(CodeTableType) then      {update for TP 4.0 and above}
  163.       begin
  164.         CmpError:=-2; CompressGif:=CmpError; Exit;
  165.       end
  166.     else New(CodeTable);
  167.     PutByte(MinCodeSize); BitOffset:=0; InitializeTable(MinCodeSize);
  168.     WriteCode(ClearCode);
  169.  
  170.     SuffixChar:=GetByte;
  171.     If SuffixChar>=0 then
  172.       begin
  173.         PrefixCode:=SuffixChar;
  174.         While SuffixCharEqualGetByte>=0 do
  175.           begin
  176.             Hx:=(PrefixCode Xor (SuffixChar Shl 5)) mod TableSize;
  177.             D:=1;
  178.             While True do
  179.               begin
  180.                 If CodeTable^[Hx].CodeID=0 then
  181.                   begin
  182.                     WriteCode(PrefixCode);
  183.                     D:=FreeCode;
  184.                     If FreeCode<=LargestCode then
  185.                       begin
  186.                         CodeTable^[Hx].PriorCode:= PrefixCode;
  187.                         CodeTable^[Hx].AddedChar:= SuffixChar;
  188.                         CodeTable^[Hx].CodeID:=    FreeCode;
  189.                         FreeCode:=                 Succ(FreeCode);
  190.                       end;
  191.                     If D=MaxCode then
  192.                       If CodeSize<12 then
  193.                         begin
  194.                           CodeSize:=Succ(CodeSize); MaxCode:=MaxCode Shl 1;
  195.                         end
  196.                       else
  197.                         begin
  198.                           WriteCode(ClearCode); InitializeTable(MinCodeSize);
  199.                         end;
  200.                     PrefixCode:=SuffixChar;
  201.                     GoTo Break;
  202.                   end;
  203.                 If (CodeTable^[Hx].PriorCode=PrefixCode) and
  204.                    (CodeTable^[Hx].AddedChar=SuffixChar) then
  205.                   begin
  206.                     PrefixCode:=CodeTable^[Hx].CodeID;
  207.                     GoTo Break;
  208.                   end;
  209.                 Hx:=Hx+D; D:=D+2;
  210.                 If Hx>=TableSize then Hx:=Hx-TableSize;
  211.               end;
  212. Break:
  213.           end;
  214.         If SuffixChar<>-1 then
  215.           begin
  216.             CmpError:=SuffixChar; CompressGIF:=CmpError; Exit;
  217.           end;
  218.         WriteCode(PrefixCode);
  219.       end
  220.     else
  221.       If SuffixChar<>-1 then
  222.         begin
  223.           CmpError:=SuffixChar; CompressGif:=CmpError; Exit;
  224.         end;
  225.     WriteCode(EOFCode);
  226.     If BitOffset>0 then FlushBuffer((BitOffset+7) div 8);
  227.     FlushBuffer(0);
  228.     Dispose(CodeTable);
  229.   end;   { Function CompressGIF }
  230.  
  231.