home *** CD-ROM | disk | FTP | other *** search
/ Intermedia 1998 January / inter1_98.iso / www / rozi / GIF.ZIP / LOAD_GIF.PAS < prev    next >
Pascal/Delphi Source File  |  1997-01-17  |  12KB  |  441 lines
  1. program load_Gif;
  2.  
  3. uses
  4.   crt,graph;
  5.  
  6. type
  7.   BufferArray = array[0..63999] of byte;
  8.   BufferPointer = ^BufferArray;
  9.  
  10. var
  11.   GifFile : file of BufferArray;
  12.   InputFileName : string;
  13.   RawBytes : BufferPointer;   { The heap array to hold it, raw    }
  14.   Buffer : BufferPointer;     { The Buffer data stream, unblocked }
  15.   Buffer2 : BufferPointer;    { More Buffer data stream if needed }
  16.   Byteoffset,                 { Computed byte position in Buffer array }
  17.   BitIndex                    { Bit offset of next code in Buffer array }
  18.    : longint;
  19.  
  20.   Width,      {Read from GIF header, image width}
  21.   Height,     { ditto, image height}
  22.   LeftOfs,    { ditto, image offset from left}
  23.   TopOfs,     { ditto, image offset from top}
  24.   RWidth,     { ditto, Buffer width}
  25.   RHeight,    { ditto, Buffer height}
  26.   ClearCode,  {GIF clear code}
  27.   EOFCode,    {GIF end-of-information code}
  28.   OutCount,   {Decompressor output 'stack count'}
  29.   MaxCode,    {Decompressor limiting value for current code size}
  30.   CurCode,    {Decompressor variable}
  31.   OldCode,    {Decompressor variable}
  32.   InCode,     {Decompressor variable}
  33.   FirstFree,  {First free code, generated per GIF spec}
  34.   FreeCode,   {Decompressor, next free slot in hash table}
  35.   RawIndex,     {Array pointers used during file read}
  36.   BufferPtr,
  37.   XC,YC,      {Screen X and Y coords of current pixel}
  38.   ReadMask,   {Code AND mask for current code size}
  39.   I           {Loop counter, what else?}
  40.   :word;
  41.  
  42.   Interlace,  {true if interlaced image}
  43.   AnotherBuffer, {true if file > 64000 bytes}
  44.   ColorMap    {true if colormap present}
  45.   : boolean;
  46.  
  47.   ch : char;
  48.   a,              {Utility}
  49.   Resolution,     {Resolution, read from GIF header}
  50.   BitsPerPixel,   {Bits per pixel, read from GIF header}
  51.   Background,     {Background color, read from GIF header}
  52.   ColorMapSize,   {Length of color map, from GIF header}
  53.   CodeSize,       {Code size, read from GIF header}
  54.   InitCodeSize,   {Starting code size, used during Clear}
  55.   FinChar,        {Decompressor variable}
  56.   Pass,           {Used by video output if interlaced pic}
  57.   BitMask,        {AND mask for data size}
  58.   R,G,B
  59.   :byte;
  60.  
  61.     {The hash table used by the decompressor}
  62.   Prefix: array[0..4095] of word;
  63.   Suffix: array[0..4095] of byte;
  64.  
  65.     {An output array used by the decompressor}
  66.   PixelValue : array[0..1024] of byte;
  67.  
  68.     {The color map, read from the GIF header}
  69.   Red,Green,Blue: array [0..255] of byte;
  70.   MyPalette : PaletteType;
  71.  
  72.   TempString : String;
  73.  
  74. Const
  75.  MaxCodes: Array [0..9] of Word = (4,8,16,$20,$40,$80,$100,$200,$400,$800);
  76.  CodeMask:Array [1..4] of byte= (1,3,7,15);
  77.  PowersOf2: Array [0..8] of word=(1,2,4,8,16,32,64,128,256);
  78.  Masks: Array [0..9] of integer = (7,15,$1f,$3f,$7f,$ff,$1ff,$3ff,$7ff,$fff);
  79.  BufferSize : Word = 64000;
  80.  
  81. function NewExtension(FileName,Extension : string) : string;
  82. {
  83. Places a new extension on to the file name.
  84. }
  85. var
  86.   I : integer;
  87. begin
  88.   if (Extension[1] = '.') then delete(Extension,1,1);
  89.   delete(Extension,4,251);
  90.   I := pos('.',FileName);
  91.   if (I = 0) then
  92.   begin
  93.     while (length(FileName) > 0) and (FileName[length(FileName)] = ' ')
  94.       do delete(FileName,length(FileName),1);
  95.     NewExtension := FileName + '.' + Extension;
  96.   end else begin
  97.     delete(FileName,I + 1,254 - I);
  98.     NewExtension := FileName + Extension;
  99.   end;
  100. end; { NewExtension }
  101.  
  102. function Min(I,J : longint) : longint;
  103. begin
  104.   if (I < J) then Min := I else Min := J;
  105. end; { Min }
  106.  
  107. procedure AllocMem(var P : BufferPointer);
  108. var
  109.   ASize : longint;
  110. begin
  111.   ASize := MaxAvail;
  112.   if (ASize < BufferSize) then begin
  113.     Textmode(15);
  114.     writeln('Insufficient memory available!');
  115.     halt;
  116.   end else getmem(P,BufferSize);
  117. end; { AllocMem }
  118.  
  119. function Getbyte : byte;
  120. begin
  121.   if (RawIndex >= BufferSize) then exit;
  122.   Getbyte := RawBytes^[RawIndex];
  123.   inc(RawIndex);
  124. end;
  125.  
  126. function Getword : word;
  127. var
  128.   W : word;
  129. begin
  130.   if (succ(RawIndex) >= BufferSize) then exit;
  131.   move(RawBytes^[RawIndex],W,2);
  132.   inc(RawIndex,2);
  133.   Getword := W;
  134. end; { GetWord }
  135.  
  136. procedure ReadBuffer;
  137. var
  138.   BlockLength : byte;
  139.   I,IOR : integer;
  140. begin
  141.   BufferPtr := 0;
  142.   Repeat
  143.     BlockLength := Getbyte;
  144.     For I := 0 to Blocklength-1 do
  145.     begin
  146.       if RawIndex = BufferSize then
  147.       begin
  148.         {$I-}
  149.         Read (GIFFile,RawBytes^);
  150.         {$I+}
  151.         IOR := IOResult;
  152.         RawIndex := 0;
  153.       end;
  154.       if not AnotherBuffer
  155.         then Buffer^[BufferPtr] := Getbyte
  156.         else Buffer2^[BufferPtr] := Getbyte;
  157.       BufferPtr := Succ (BufferPtr);
  158.       if BufferPtr=BufferSize then begin
  159.         AnotherBuffer := true;
  160.         BufferPtr := 0;
  161.         AllocMem (Buffer2);
  162.       end;
  163.     end;
  164.   Until Blocklength=0;
  165. end; { ReadBuffer }
  166.  
  167. procedure InitEGA;
  168. var
  169.   Driver,Mode : integer;
  170. begin
  171.   DetectGraph(Driver,Mode);
  172.   InitGraph(Driver,Mode,'e:\bp\bgi');
  173.   SetAllPalette(MyPalette);
  174.   if (Background <> 0) then begin
  175.     SetFillStyle(SolidFill,Background);
  176.     bar(0,0,Width,Height);
  177.   end;
  178. end; { InitEGA }
  179.  
  180. procedure DetColor(var PValue : byte; MapValue : Byte);
  181. {
  182. Determine the palette value corresponding to the GIF colormap intensity
  183. value.
  184. }
  185. var
  186.   Local : byte;
  187. begin
  188.   PValue := MapValue div 64;
  189.   if (PValue = 1)
  190.     then PValue := 2
  191.     else if (PValue = 2)
  192.       then PValue := 1;
  193. end; { DetColor }
  194.  
  195. procedure Init;
  196. var
  197.   I : integer;
  198. begin
  199.   XC := 0;          {X and Y screen coords back to home}
  200.   YC := 0;
  201.   Pass := 0;        {Interlace pass counter back to 0}
  202.   BitIndex := 0;   {Point to the start of the Buffer data stream}
  203.   RawIndex := 0;      {Mock file read pointer back to 0}
  204.   AnotherBuffer := false;    {Over 64000 flag off}
  205.   AllocMem(Buffer);
  206.   AllocMem(RawBytes);
  207.   InputFileName := NewExtension(InputFileName,'GIF');
  208.   {$I-}
  209.   Assign(giffile,InputFileName);
  210.   Reset(giffile);
  211.   I := IOResult;
  212.   if (I <> 0) then begin
  213.     textmode(15);
  214.     writeln('Error opening file ',InputFileName,'. Press any key ');
  215.     readln;
  216.     halt;
  217.   end;
  218.   read(GIFFile,RawBytes^);
  219.   I := IOResult;
  220. {$I+}
  221. end; { Init }
  222.  
  223. procedure ReadGifHeader;
  224. var
  225.   I : integer;
  226. begin
  227.   TempString := '';
  228.   for I := 1 to 6 do TempString := TempString + chr(Getbyte);
  229.   if (TempString <> 'GIF89a') then begin
  230.     textmode(15);
  231.     writeln('Not a GIF file, or header read error. Press enter.');
  232.     readln;
  233.     halt;
  234.   end;
  235. {
  236. Get variables from the GIF screen descriptor
  237. }
  238.   RWidth := Getword;         {The Buffer width and height}
  239.   RHeight := Getword;
  240. {
  241. Get the packed byte immediately following and decode it
  242. }
  243.   B := Getbyte;
  244.   Colormap := (B and $80 = $80);
  245.   Resolution := B and $70 shr 5 + 1;
  246.   BitsPerPixel := B and 7 + 1;
  247.   ColorMapSize := 1 shl BitsPerPixel;
  248.   BitMask := CodeMask[BitsPerPixel];
  249.   Background := Getbyte;
  250.   B := Getbyte;         {Skip byte of 0's}
  251. {
  252. Compute size of colormap, and read in the global one if there. Compute
  253. values to be used when we set up the EGA palette
  254. }
  255.   MyPalette.Size := Min(ColorMapSize,16);
  256.   if Colormap then begin
  257.     for I := 0 to pred(ColorMapSize) do begin
  258.       Red[I] := Getbyte;
  259.       Green[I] := Getbyte;
  260.       Blue[I] := Getbyte;
  261.       DetColor(R,Red[I]);
  262.       DetColor(G,Green [I]);
  263.       DetColor(B,Blue [I]);
  264.       MyPalette.Colors[I] := B and 1 +
  265.                     ( 2 * (G and 1)) + ( 4 * (R and 1)) + (8 * (B div 2)) +
  266.                     (16 * (G div 2)) + (32 * (R div 2));
  267.     end;
  268.   end;
  269. {
  270. Now read in values from the image descriptor
  271. }
  272.   B := Getbyte;  {skip image seperator}
  273.   Leftofs := Getword;
  274.   Topofs := Getword;
  275.   Width := Getword;
  276.   Height := Getword;
  277.   A := Getbyte;
  278.   Interlace := (A and $40 = $40);
  279.   if Interlace then begin
  280.     textmode(15);
  281.     writeln('unable to display interlaced GIF pictures.');
  282.     halt;
  283.   end;
  284. end; { ReadGifHeader }
  285.  
  286. procedure PrepDecompressor;
  287. begin
  288.   Codesize := Getbyte;
  289.   ClearCode := PowersOf2[Codesize];
  290.   EOFCode := ClearCode + 1;
  291.   FirstFree := ClearCode + 2;
  292.   FreeCode := FirstFree;
  293.   inc(Codesize); { since zero means one... }
  294.   InitCodeSize := Codesize;
  295.   Maxcode := Maxcodes[Codesize - 2];
  296.   ReadMask := Masks[Codesize - 3];
  297. end; { PrepDecompressor }
  298.  
  299. procedure DisplayGIF;
  300. {
  301. Decompress and display the GIF data.
  302. }
  303. var
  304.   Code : word;
  305.  
  306.   procedure DoClear;
  307.   begin
  308.     CodeSize := InitCodeSize;
  309.     MaxCode := MaxCodes[CodeSize-2];
  310.     FreeCode := FirstFree;
  311.     ReadMask := Masks[CodeSize-3];
  312.   end; { DoClear }
  313.  
  314.   procedure ReadCode;
  315.   var
  316.     Raw : longint;
  317.   begin
  318.     if (CodeSize >= 8) then begin
  319.       move(Buffer^[BitIndex shr 3],Raw,3);
  320.       Code := (Raw shr (BitIndex mod 8)) and ReadMask;
  321.     end else begin
  322.       move(Buffer^[BitIndex shr 3],Code,2);
  323.       Code := (Code shr (BitIndex mod 8)) and ReadMask;
  324.     end;
  325.     if AnotherBuffer then begin
  326.       ByteOffset := BitIndex shr 3;
  327.       if (ByteOffset >= 63000) then begin
  328.         move(Buffer^[Byteoffset],Buffer^[0],BufferSize-Byteoffset);
  329.         move(Buffer2^[0],Buffer^[BufferSize-Byteoffset],63000);
  330.         BitIndex := BitIndex mod 8;
  331.         FreeMem(Buffer2,BufferSize);
  332.       end;
  333.     end;
  334.     BitIndex := BitIndex + CodeSize;
  335.   end; { ReadCode }
  336.  
  337.   procedure OutputPixel(Color : byte);
  338.   begin
  339.     putpixel(XC,YC,Color); { about 3x faster than using the DOS interrupt! }
  340.     inc(XC);
  341.     if (XC = Width) then begin
  342.       XC := 0;
  343.       inc(YC);
  344.       if (YC mod 10 = 0) and keypressed and (readkey = #27) then begin
  345.         textmode(15);  { let the user bail out }
  346.         halt;
  347.       end;
  348.     end;
  349.   end; { OutputPixel }
  350.  
  351.  
  352.  
  353. begin { DisplayGIF }
  354.   CurCode := 0; { not initted anywhere else... don't know why }
  355.   OldCode := 0; { not initted anywhere else... don't know why }
  356.   FinChar := 0; { not initted anywhere else... don't know why }
  357.   OutCount := 0;
  358.   DoClear;      { not initted anywhere else... don't know why }
  359.   repeat
  360.     ReadCode;
  361.     if (Code <> EOFCode) then begin
  362.       if (Code = ClearCode) then begin { restart decompressor }
  363.         DoClear;
  364.         ReadCode;
  365.         CurCode := Code;
  366.         OldCode := Code;
  367.         FinChar := Code and BitMask;
  368.         OutputPixel(FinChar);
  369.       end else begin        { must be data: save same as CurCode and InCode }
  370.         CurCode := Code;
  371.         InCode := Code;
  372. { if >= FreeCode, not in hash table yet; repeat the last character decoded }
  373.         if (Code >= FreeCode) then begin
  374.           CurCode := OldCode;
  375.           PixelValue[OutCount] := FinChar;
  376.           inc(OutCount);
  377.         end;
  378. {
  379. Unless this code is raw data, pursue the chain pointed to by CurCode
  380. through the hash table to its end; each code in the chain puts its
  381. associated output code on the output queue.
  382. }
  383.         if (CurCode > BitMask) then repeat
  384.           PixelValue[OutCount] := Suffix[CurCode];
  385.           inc(OutCount);
  386.           CurCode := Prefix[CurCode];
  387.         until (CurCode <= BitMask);
  388. {
  389. The last code in the chain is raw data.
  390. }
  391.         FinChar := CurCode and BitMask;
  392.         PixelValue[OutCount] := FinChar;
  393.         inc(OutCount);
  394. {
  395. Output the pixels. They're stacked Last In First Out.
  396. }
  397.         for I := pred(OutCount) downto 0 do OutputPixel(PixelValue[I]);
  398.         OutCount := 0;
  399. {
  400. Build the hash table on-the-fly.
  401. }
  402.         Prefix[FreeCode] := OldCode;
  403.         Suffix[FreeCode] := FinChar;
  404.         OldCode := InCode;
  405. {
  406. Point to the next slot in the table. If we exceed the current MaxCode
  407. value, increment the code size unless it's already 12. if it is, do
  408. nothing: the next code decompressed better be CLEAR
  409. }
  410.         inc(FreeCode);
  411.         if (FreeCode >= MaxCode) then begin
  412.           if (CodeSize < 12) then begin
  413.             inc(CodeSize);
  414.             MaxCode := MaxCode * 2;
  415.             ReadMask := Masks[CodeSize - 3];
  416.           end;
  417.         end;
  418.       end; {not Clear}
  419.     end; {not EOFCode}
  420.   until (Code = EOFCode);
  421. end; { DisplayGIF }
  422.  
  423. begin
  424.   clrscr;
  425.   write('Typ filename :');
  426.   readln(TempString);
  427.   InputFileName := TempString;
  428.   Init;
  429.   ReadGifHeader;
  430.   PrepDecompressor;
  431.   ReadBuffer;
  432.   FreeMem(RawBytes,BufferSize);
  433.   InitEGA;
  434.   DisplayGIF;
  435.   SetAllPalette(MyPalette);
  436.   close(GifFile);
  437.   Ch := readkey;
  438.   textmode(15);
  439.   freemem(Buffer,BufferSize);
  440. end.
  441.