Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OOBPLS10.ZIP/OFLGIF.PAS

Pascal/Delphi Source File | 1992-11-06 | 8.4 KB | 368 lines

{$F+,O+,T-,X+}
unit OfLGIF;   {simple offline GIF decoder}

{.$DEFINE Debug}

interface

uses
  DOS,
  OpInline,
  OpRoot,
  OpCrt,
  OpMouse,
  OpDrag,
  OpString,
  DeGIF,
  GIFVideo;


const
  UnitVers = '1.0d';
  UnitDate = '05-Jun-91';

function DisplayGIFOffLine(FN : String) : Boolean;

implementation

const
  BuffSize = 8192;
  YInc : Array[1..6] of Byte = (8,8,4,2,1,0);
  YLin : Array[1..6] of Byte = (0,4,2,1,0,0);
  YInt : Array[1..6] of Byte = (7,3,1,0,0,0);

type
  BuffType = Array[1..$FFF1] of Byte;
  BuffPtr  = ^BuffType;

  PCmt = ^CmtLine;
  CmtLine =
    object(DoubleListNode)
      Line : String[80];
    end;

var
  GIFBuff  : BuffPtr;
  GRec     : JumpRecord;
  Pass     : Byte;
  Intrlace : Boolean;
  Image    : Word;
  Done     : Boolean;
  GIFCap   : Boolean;
  BufIdx   : Word;
  Count    : Word;
  EOFin    : Boolean;
  SigOK    : Boolean;
  CmtList  : DoubleList;

{-------------------------------}
{ High-level online GIF decoder }
{-------------------------------}

procedure RingBell;
  {-make a noise}
begin
  Sound(440);
  Delay(100);
  NoSound;
end;

function CheckKey : Boolean;
  {-return True if abort is requested via pressing <ESC>}
begin
  if (KeyPressed) and (ReadKey = #27) then
    CheckKey := True
  else
    CheckKey := False;
end;

procedure EndIt(B : Boolean);
  {-abort the decode process}
begin
  if GraphOn then
    SetTextMode;
  if B then begin
    RingBell;
    RingBell;
  end;
  LongJump(GRec,1);
end;

function FileGetByte : Byte;
  {-our decoder's GetByte function}
var
  B : Byte;
begin
  if BufIdx > Count then begin
    BlockRead(GifFile, GifBuff^, BuffSize, Count);
    BufIdx := 1;
  end;
  FileGetByte := GifBuff^[BufIdx];
  Inc(BufIdx);
end;

procedure MyPutLine;
  {-our decoder's PutLine proc.  This method accomodates interlaced GIFs}
var I : Integer;
begin
  if CheckKey then
    EndIt(False);
  if YCord <= Raster then        {don't wrap back to top of screen!}
    PlotLine(YCord);
  Inc(YCord,YInc[Pass]);
  if YCord >= BotEdge then begin
    if Pass < 5 then Inc(Pass);
    YCord := YLin[Pass] + TopEdge;
  end;
end;

procedure MyPutLineDbl;
  {-our decoder's PutLine proc.  This method accomodates interlaced GIFs}
var I : Integer;
begin
  if CheckKey then
    EndIt(False);
  if YCord <= Raster then        {don't wrap back to top of screen!}
    PlotLine(YCord);
  Inc(YCord,YInc[Pass] shl 1);
  if YCord >= BotEdge then begin
    if Pass < 5 then Inc(Pass);
    YCord := (YLin[Pass] shl 1) + TopEdge;
  end;
end;

procedure AdjustVars;
  {-match decode/display vars to image sizes}
var I : Byte;
begin
  Inc(Image);
  Pass := 5;
  IntrLace := FALSE;
  LeftEdge  := ImageLeft;
  TopEdge   := ImageTop;
  if (ScrWidth = 300) and (ScrHeight = 200) then begin
    Inc(LeftEdge, 10);
    RightEdge := ImageWidth + LeftEdge;
    BotEdge   := ImageHeight + TopEdge;
  end
  else if (ScrWidth = 378) and (ScrHeight = 240) then begin
    if (DoDbl) then begin
      RightEdge := 700;
      BotEdge := 480;
    end
    else begin
      Inc(LeftEdge, 131);
      Inc(TopEdge, (Raster shr 1) - 120);
      RightEdge := ImageWidth + LeftEdge;
      BotEdge   := ImageHeight + TopEdge;
    end;
  end
  else begin
    if ImageWidth < Pixels then
      Inc(LeftEdge, (Pixels shr 1) - (ImageWidth shr 1));
    if ImageHeight < Raster then
      Inc(TopEdge, (Raster shr 1) - (ImageHeight shr 1));
    RightEdge := ImageWidth + LeftEdge;
    BotEdge   := ImageHeight + TopEdge;
  end;
  YCord := TopEdge;
  if Maps[Local].Interlaced then
    Pass := 1;
end;

procedure LoadComments;
var
  Blk : GifBlockType;
  P : PCmt;
  S : String;
  I : Integer;
begin
  S := '';
  while GetExtendBlock(Blk) do begin
    for I := 1 to Blk[0] do
      case Chr(Blk[i]) of
        #13:
          begin
            New(P, Init);
            if P <> nil then begin
              P^.Line := S;
              CmtList.Append(P);
            end;
            S := '';
          end;
        #0..#31:
          ;
        else
          S := S + Chr(Blk[i]);
      end;
  end;
end;

procedure ShowComments;
var
  P : PCmt;
  W : Word;
  C : Char absolute W;
begin
  ClrScr;
  P := PCmt(CmtList.Head);
  while P <> nil do begin
    WriteLn(P^.Line);
    P := PCmt(P^.dlNext);
  end;
  repeat
    W := ReadKeyOrButton;
  until (C = #13) or (C = #27) or (Hi(W) in [$ED,$EE,$EF]);
end;

function DecodeGIFFile : Integer;
  {-lowlevel GIF decode routine}
var I         : Integer;
    BlockType : Char;
    Blk       : GifBlockType;
    ExtFunc   : Byte;
begin
    {init vars}
  Done := False;
  Image := 0;
  CurMap := Global;
  DecodeGIFFile := -9;

    {verify signature.  To accomodate future versions, we accept anything}
    {with the first 3 chars "GIF" and the next 3 as 2 digits and a lower }
    {case char.                                                          }
  GetGIFSig;
  if (Pos('GIF',GIFSig) <> 1) or
     (NOT(GIFSig[4] in ['0'..'9'])) or
     (NOT(GIFSig[5] in ['0'..'9'])) or
     (NOT(GIFSig[6] in ['a'..'z'])) then begin
{$IFDEF Debug}
    WriteLn('Failed decoding signature '+GIFSig);
{$ENDIF}
    Sound(440);
    Delay(100);
    NoSound;
    delay(2000);
    EndIt(False);
  end;

    {get the hardware specifics, match a video mode as close as we can}
  GetScrDes(Maps[CurMap]);

  SelMode := SelectMode(ScrWidth,ScrHeight);
  if SelMode = 0 then EndIt(True);

    {if we have a global map, process it}
  if Maps[Global].MapExists then
    DoMapping
  else
    SetDefMap;

    {kick into graphics mode then juggle the palette to match our map}
  if (CurrentDisplay in [EGA,VGA]) and
     (ScrWidth = 378) and
     (ScrHeight = 240) then
    if DoDbl then
      PutLine := MyPutLineDbl;
  SetGraphicsMode(SelMode);
  AdjustPalette(SelMode);

    {loop reading blocks and processing...}
  while NOT Done do begin
    BlockType := Chr(GetByte);
    case BlockType of
      ',': begin                             {"Local descriptor", process...}
             GetImageDescription(Maps[Local]);
             AdjustVars;
             CurMap := Global;
             if Maps[Local].MapExists then begin
                 {juggle palette again}
               CurMap := Local;
               DoMapping;
               AdjustPalette(SelMode);
             end;
               {decode the image data and display}
             I := ExpandGIF;
             if I <> 0 then begin
               DecodeGIFFile := I;
               EndIt(True);
             end;
           end;
      '!': begin                                  {"Extension" block...}
             ExtFunc := GetExtendFunc;            {get the function type}
             case ExtFunc of
               $FE:
                 LoadComments;                    {load comments for later}
               else
                 while GetExtendBlock(Blk) do ;   {discard the block}
             end;
           end;
      ';': begin                {Terminator seen, clean up and go home}
             Done := True;
             DecodeGIFFile := 0;
             exit;
           end;
    end;
  end;
end;

function DisplayGIFOffLine(FN : String) : Boolean;
  {-display a GIF file onscreen}
var L : LongInt;
    W : Word;
    C : Char Absolute W;
    N : Integer;
begin
  DisplayGIFOffLine := False;

    {point to our routines}
  GetByte := FileGetByte;
  PutLine := MyPutLine;
  if NOT GetMemCheck(GIFBuff,BuffSize) then exit;
  CmtList.Init;

    {init error handler}
  N := SetJump(GRec);
  if N <> 0 then begin
    Close(GifFile);
    if IOResult = 0 then ;
    CmtList.Done;
    FreeMemCheck(GIFBuff, BuffSize);
    exit;
  end;

    {init capture file}
  Count := 0;
  BufIdx := 999;
  Assign(GifFile, FN);
  Reset(GifFile, 1);
  if IOResult <> 0 then begin
    CmtList.Done;
    FreeMemCheck(GIFBuff, BuffSize);
    exit;
  end;

    {process...}
  N := DecodeGIFFile;

  if N = 0 then begin
    RingBell;
    DisplayGIFOffline := True;
      {wait for <CR> or <ESC> before clearing}
    repeat
      W := ReadKeyOrButton;
    until (C = #13) or (C = #27) or (Hi(W) in [$ED,$EE,$EF]);
    ClearMouseEvents;
    SetTextMode;
    Close(GifFile);  if IOResult = 0 then ;

    if CmtList.Size <> 0 then
      ShowComments;
  end;

  CmtList.Done;
  FreeMemCheck(GIFBuff, BuffSize);
end;

end.