home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / OOBPLS10.ZIP / DEGIF.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-11-06  |  12.3 KB  |  508 lines
  1. {$F+,A+,R-,S-,V-,O-,G+}    {not recommended for overlaying!  286 req'd}
  2.  
  3. {***********************************************}
  4. {*              DEGIF.PAS  3.0b                *}
  5. {*       Copyright (c) Steve Sneed 1991        *}
  6. {*            All Rights Reserved              *}
  7. {*                                             *}
  8. {*  Provided to TurboPower Software for their  *}
  9. {*   use or distribution with their products   *}
  10. {***********************************************}
  11.  
  12. {$IFNDEF Ver60}
  13. {$IFNDEF Ver70}
  14.   !! FATAL: This unit requires TP6 or later !!
  15. {$ENDIF}
  16. {$ENDIF}
  17.  
  18. unit DeGIF;             {basic GIF image decoder}
  19.  
  20. interface
  21.  
  22. const
  23.   UnitVers = '3.0b';
  24.   UnitDate = '08-Aug-92';
  25.  
  26. type
  27.   GetByteProc = function : Byte;
  28.   PutLineProc = procedure;
  29.  
  30.   TRasterLine  = Array[0..2047] of Byte;
  31.  
  32. type
  33.     {color map types needed}
  34.   MapType = (Global, Local);
  35.   GifBlockType = Array[0..255] of Byte;
  36.  
  37.   Primary = (RedVal,GreenVal,BlueVal);
  38.   MapEntry = array[RedVal..BlueVal] of Byte;
  39.  
  40.     {record of a color map}
  41.   GIFMap =
  42.     record
  43.       Map              : array[0..255] of MapEntry;
  44.       MapExists        : Boolean;
  45.       Sorted           : Boolean;
  46.       BitsPerPixel     : Word;
  47.       HighColorNum     : Word;
  48.       IsGlobal         : Boolean;             {only true  if Global}
  49.       BackgrColorIndex : Word;                {only valid if Global}
  50.       AspectRatio      : Word;                {only valid if Global}
  51.       BitsPerPrimary   : Word;                {only valid if Global}
  52.       Interlaced       : Boolean;             {only valid if Local }
  53.     end;
  54.  
  55. var
  56.   RasterLine   : TRasterLine;
  57.   RasterWidth  : Word;
  58.   GetByte      : GetByteProc;
  59.   PutLine      : PutLineProc;
  60.   GifFile      : File;
  61.  
  62. var
  63.   ExtendFunc : Byte;         {Function code for extension block}
  64.   GIFSig     : String[6];    {GIF ID string usually = 'GIF87a'}
  65.   ImageLeft,                 {Left edge of image relative to virtual screen}
  66.   ImageTop,                  {Top edge of image relative to virtual screen}
  67.   ImageWidth,                {in pixels}
  68.   ImageHeight,               {in pixels}
  69.   LeftEdge,
  70.   RightEdge,
  71.   ScrColors,
  72.   ScrHeight,                 {in pixels}
  73.   ScrWidth   : Word;         {in pixels}
  74.  
  75.     {vars used by decompressor}
  76.   PackedBits, I : Word;
  77.   A, B : Byte;
  78.   BytesInBlock : Byte;
  79.  
  80.     {color mapping services vars}
  81.   Maps        : Array[MapType] of GIFMap;
  82.   CurMap      : MapType;
  83.   TempMap     : GIFMap;
  84.   Color       : array[0..255] of byte;
  85.   MaxColors   : Integer;
  86.  
  87.  
  88.   {-GIF decode routines}
  89. procedure GetGIFSig;
  90. procedure GetImageDescription(var MapRec : GifMap);
  91. procedure GetScrDes(var MapRec : GifMap);
  92. procedure GetBlock(var Block : GifBlockType);
  93. function GetExtendFunc : Byte;
  94. function GetExtendBlock(var Block : GifBlockType) : Boolean;
  95. procedure SkipExtendBlock;
  96. function ExpandGIF : Integer;
  97.  
  98. implementation
  99.  
  100. const
  101.   LargestCode = 4095;
  102.  
  103. type
  104.   CodeEntry =
  105.     Record
  106.       Prefix: Integer;   { 2 bytes }
  107.       Suffix: Byte;      { 1 byte  }
  108.       Stack:  Byte;      { 1 byte  }
  109.     end;                 { 4096 * 4 = 16k }
  110.   TCodeTable   = Array[0..LargestCode] of CodeEntry;
  111.   PCodeTable   = ^TCodeTable;
  112.  
  113. const
  114.   Mask: Array[1..12] of Integer   = ($0001,$0003,$0007,$000F,
  115.                                      $001F,$003F,$007F,$00FF,
  116.                                      $01FF,$03FF,$07FF,$0FFF);
  117.  
  118. var
  119.   CodeSize,
  120.   ClearCode,
  121.   EOFCode,
  122.   FirstFree,
  123.   BitOffset,
  124.   BytOffset,
  125.   BitsLeft,
  126.   MaxCode,
  127.   FreeCode,
  128.   OldCode,
  129.   InputCode,
  130.   Code,
  131.   SuffixChar,
  132.   FinalChar,
  133.   MinimumCodeSize,
  134.   BytesUnRead      : Integer;
  135.   CodeBuffer       : Array[0..260] of Byte;
  136.   CodeTable        : PCodeTable;
  137.   RasterPos        : Word;
  138.   ExpError         : Integer;
  139.  
  140.  
  141.   function GetWord : word;
  142.     {-get two bytes and make a word}
  143.   begin
  144.     a := GetByte;
  145.     b := GetByte;
  146.     GetWord := (b shl 8) or a;
  147.   end;
  148.  
  149.   function GetWordFromBlock(var Block : GifBlockType; Index : byte) : word;
  150.     {-get a word from a block}
  151.   begin
  152.     GetWordFromBlock := (Block[succ(Index)] shl 8) or Block[Index];
  153.   end;
  154.  
  155.   procedure GetBlock(var Block : GifBlockType);
  156.     {-get next block of GIF stream}
  157.   begin
  158.     Block[0] := GetByte;
  159.     if Block[0] <> 0 then
  160.       for I := 1 to Block[0] do Block[I] := GetByte;
  161.   end;
  162.  
  163.   procedure GetGIFSig;
  164.     {-get the 6-byte GIF signature}
  165.   var I : Integer;
  166.   begin
  167.     GIFSig := '';
  168.     for I := 0 to 5 do
  169.       GIFSig := GIFSig + chr(GetByte);
  170.   end;
  171.  
  172.   procedure GetScrDes(var MapRec : GifMap);
  173.     {-get a screen descriptor record}
  174.   begin
  175.     ScrWidth := GetWord;
  176.     RasterWidth := ScrWidth;
  177.     ScrHeight := GetWord;
  178.     PackedBits := GetByte;
  179.     with MapRec do begin
  180.       IsGlobal := true;
  181.       Interlaced := false; {undefined}
  182.       BitsPerPrimary := ((PackedBits and $70) shr 4) + 1;
  183.       BackgrColorIndex := GetByte;
  184.       MapExists := (PackedBits and $80) <> 0;
  185.       BitsPerPixel := (PackedBits and $7) + 1;
  186.       HighColorNum := (1 shl BitsPerPixel)-1;
  187.       ScrColors := Succ(HighColorNum);
  188.       Sorted := (PackedBits and $04) <> 0;
  189.       AspectRatio := GetByte;
  190.       if MapExists then  {get the map}
  191.        for I := 0 to HighColorNum do begin
  192.          Map[I,RedVal] := GetByte;
  193.          Map[I,GreenVal] := GetByte;
  194.          Map[I,BlueVal] := GetByte
  195.        end;
  196.     end;
  197.   end;
  198.  
  199.   procedure GetImageDescription(var MapRec : GifMap);
  200.     {-get an image descriptor record}
  201.   begin
  202.     ImageLeft := GetWord;
  203.     ImageTop := GetWord;
  204.     ImageWidth := GetWord;
  205.     ImageHeight := GetWord;
  206.     PackedBits := GetByte;
  207.     with MapRec do begin
  208.       IsGlobal := false;
  209.       AspectRatio := 0;      {undefined}
  210.       BitsPerPrimary := 0;   {undefined}
  211.       BackgrColorIndex := 0; {undefined}
  212.       Interlaced := (PackedBits and $40) <> 0;
  213.       Sorted := (PackedBits and $20) <> 0;
  214.       MapExists := (PackedBits and $80) <> 0;
  215.       BitsPerPixel := (PackedBits and $7)+1;
  216.       HighColorNum := (1 shl BitsPerPixel)-1;
  217.       if MapExists then
  218.        for I := 0 to HighColorNum do begin
  219.          Map[I,RedVal] := GetByte;
  220.          Map[I,GreenVal] := GetByte;
  221.          Map[I,BlueVal] := GetByte
  222.        end;
  223.     end;
  224.   end;
  225.  
  226.   function GetExtendFunc : Byte;
  227.   begin
  228.     GetExtendFunc := GetByte;
  229.   end;
  230.  
  231.   function GetExtendBlock(var Block : GifBlockType) : Boolean;
  232.   begin
  233.     GetBlock(Block);
  234.     GetExtendBlock := (Block[0] <> 0);
  235.   end;
  236.  
  237.   procedure SkipExtendBlock;
  238.     {-skip 89a-spec extension block}
  239.   var
  240.     Block : GifBlockType;
  241.   begin
  242.     GetExtendFunc;
  243.     while GetExtendBlock(Block) do ;
  244.   end;
  245.  
  246.   procedure InitializeTable;
  247.   begin
  248.     CodeSize  := Succ(MinimumCodeSize);
  249.     ClearCode := 1 Shl MinimumCodeSize;
  250.     EOFCode   := Succ(ClearCode);
  251.     FirstFree := Succ(EOFCode);
  252.     FreeCode  := FirstFree;
  253.     MaxCode   := 1 Shl CodeSize;
  254.   end;
  255.  
  256.   procedure ReadBuffer;
  257.   var
  258.     I          : Integer;
  259.     B          : Byte;
  260.     BufPointer : Integer;
  261.     RC         : Integer;
  262.     Reading    : Boolean;
  263.   begin
  264.     BufPointer := 0;
  265.     for I := BytOffset to 63 do begin
  266.       CodeBuffer[BufPointer] := CodeBuffer[i];
  267.       Inc(BufPointer);
  268.     end;
  269.  
  270.     Reading := True;
  271.     While Reading do begin
  272.       If BytesUnRead = 0 then
  273.         BytesUnRead := GetByte;
  274.       If BytesUnRead < 1 then begin
  275.         Reading := False;
  276.         If BytesUnRead < 0 then
  277.           ExpError := BytesUnRead;
  278.       end;
  279.       If Reading then begin
  280.         CodeBuffer[BufPointer] := GetByte;
  281.         Dec(BytesUnRead);
  282.         Inc(BufPointer);
  283.         Reading := (BufPointer < 64);
  284.       end;
  285.     end;
  286.  
  287.     BitOffset := BitsLeft;
  288.     BytOffset := 0;
  289.   end;
  290.  
  291.  
  292.   function ReadCode : Integer;
  293.   var
  294.     L : LongInt;
  295.   begin
  296.     asm
  297.       mov    ax,BitOffset
  298.       push   ax
  299.       and    ax,0007
  300.       mov    BitsLeft,ax
  301.       pop    ax
  302.       shr    ax,3
  303.       mov    BytOffset,ax
  304.       cmp    ax,61
  305.       jb     @@NoLoad
  306.       call   ReadBuffer
  307. @@NoLoad:
  308.       mov    ax,BitOffset
  309.       add    ax,CodeSize
  310.       mov    BitOffset,ax
  311.       mov    si,offset CodeBuffer
  312.       mov    bx,[BytOffset]
  313.       mov    ax,[si+bx]
  314.       mov    dx,[si+bx+2]
  315.       xor    dh,dh
  316.       mov    cx,[BitsLeft]
  317.       jcxz   @@NoShift
  318. @@Shift1:
  319.       dec    cx
  320.       jl     @@NoShift
  321.       shr    dx,1
  322.       rcr    ax,1
  323.       jmp    @@Shift1
  324. @@NoShift:
  325.       mov    si,offset Mask
  326.       mov    bx,[CodeSize]
  327.       dec    bx
  328.       shl    bx,1
  329.       mov    cx,[si+bx]
  330.       and    ax,cx
  331.       mov    [bp-02],ax
  332.     end;
  333.   end;
  334.  
  335.   procedure PutByte(B : Byte);  Assembler;
  336.   asm
  337.     mov     al,B
  338.     mov     si,offset RasterLine
  339.     mov     bx,[RasterPos]
  340.     mov     [si+bx],al
  341.     inc     bx
  342.     cmp     bx,[ImageWidth]
  343.     jb      @@NoReset
  344.     call    PutLine
  345.     xor     bx,bx
  346. @@NoReset:
  347.     mov     [RasterPos],bx
  348.   end;
  349.  
  350.   function ExpandGif: Integer;
  351.   label
  352.     Breakout;
  353.   var
  354.     I, SPt : Integer;
  355.   begin
  356.     ExpandGIF := -2;
  357.     GetMem(CodeTable, SizeOf(TCodeTable));
  358.     if CodeTable = nil then
  359.       exit;
  360.     FillChar(CodeTable^,SizeOf(TCodeTable),0);
  361.  
  362.     Code := 0;
  363.     OldCode := 0;
  364.     SuffixChar := 0;
  365.     FinalChar := 0;
  366.     RasterPos := 0;
  367.     MinimumCodeSize := GetByte;
  368.  
  369.     If MinimumCodeSize < 0 then
  370.       ExpError := MinimumCodeSize
  371.     else if not (MinimumCodeSize in [2..9]) then begin
  372.       ExpandGIF := -1;
  373.       goto Breakout;
  374.     end
  375.     else begin
  376.       ExpandGIF := 0;
  377.       InitializeTable;
  378.       SPt := 0;
  379.       BytesUnRead := 0;
  380.       BitOffset := 64*8;
  381.  
  382.       asm
  383. @@Top:
  384.         call   ReadCode
  385.         mov    [Code],ax
  386.         cmp    ax,[EOFCode]
  387.         je     Breakout
  388.         cmp    ax,[ClearCode]
  389.         jne    @@Skip1
  390.  
  391.         call   InitializeTable
  392.         call   ReadCode
  393.         mov    [Code],ax
  394.         mov    [OldCode],ax
  395.         mov    [SuffixChar],ax
  396.         mov    [FinalChar],ax
  397.         mov    si,offset [Color]
  398.         add    si,ax
  399.         mov    ax,ds:[si]
  400.         push   ax
  401.         call   PutByte
  402.         jmp    @@Top
  403.  
  404. @@Skip1:
  405.         mov    ax,[Code]
  406.         mov    [InputCode],ax
  407.         cmp    ax,[FreeCode]
  408.         jb     @@Skip2
  409.         mov    ax,[OldCode]
  410.         mov    [Code],ax
  411.         les    di,CodeTable
  412.         mov    ax,[SPt]
  413.         push   ax
  414.         shl    ax,2
  415.         add    di,ax
  416.         mov    ax,[FinalChar]
  417.         mov    es:[di+3],ax
  418.         pop    ax
  419.         inc    ax
  420.         mov    [SPt],ax
  421.  
  422. @@Skip2:
  423.         mov    ax,[Code]
  424.         cmp    ax,[FirstFree]
  425.         jb     @@Skip3
  426.         shl    ax,2
  427.         les    di,CodeTable
  428.         add    di,ax
  429.         mov    dl,es:[di+2]
  430.         mov    ax,[SPt]
  431.         shl    ax,2
  432.         les    di,CodeTable
  433.         add    di,ax
  434.         mov    es:[di+3],dl
  435.         mov    ax,[Code]
  436.         shl    ax,2
  437.         les    di,CodeTable
  438.         add    di,ax
  439.         mov    ax,es:[di]
  440.         mov    [Code],ax
  441.         inc    word ptr [SPt]
  442.         jmp    @@Skip2
  443.  
  444. @@Skip3:
  445.         mov    [FinalChar],ax
  446.         mov    [SuffixChar],ax
  447.         mov    dx,ax
  448.         mov    ax,[SPt]
  449.         shl    ax,2
  450.         les    di,CodeTable
  451.         add    di,ax
  452.         mov    es:[di+3],dl
  453.         inc    [SPt]
  454.  
  455. @@Skip4:
  456.         cmp    [SPt],0
  457.         je     @@Skip5
  458.         dec    [SPt]
  459.         mov    ax,[SPt]
  460.         shl    ax,2
  461.         les    di,CodeTable
  462.         add    di,ax
  463.         mov    bl,es:[di+3]
  464.         xor    bh,bh
  465.         mov    si,offset [Color]
  466.         add    si,bx
  467.         mov    al,[si]
  468.         xor    ah,ah
  469.         push   ax
  470.         call   PutByte
  471.         jmp    @@Skip4
  472.  
  473. @@Skip5:
  474.         mov    ax,[FreeCode]
  475.         shl    ax,2
  476.         les    di,CodeTable
  477.         add    di,ax
  478.         mov    ax,[OldCode]
  479.         mov    es:[di],ax
  480.         add    di,2
  481.         mov    ax,[SuffixChar]
  482.         mov    es:[di],al
  483.         mov    ax,[InputCode]
  484.         mov    [OldCode],ax
  485.         mov    ax,[FreeCode]
  486.         inc    ax
  487.         mov    [FreeCode],ax
  488.         cmp    ax,[MaxCode]
  489.         jb     @@Skip6
  490.         mov    ax,[CodeSize]
  491.         cmp    ax,11
  492.         ja     @@Skip6
  493.         inc    ax
  494.         mov    [CodeSize],ax
  495.         mov    ax,[MaxCode]
  496.         shl    ax,1
  497.         mov    [MaxCode],ax
  498. @@Skip6:
  499.         jmp    @@Top
  500.       end;
  501.     end;
  502.  
  503. Breakout:
  504.     FreeMem(CodeTable, SizeOf(TCodeTable));
  505.   end;
  506.  
  507. end.
  508.