{$R-,I-}
Program panGIF;
uses CRT,Dos,GRAPH,DEGIF;

  type
    row = array [0..1023] of byte;
    rowPtr = ^row;

var  InFileName:string;   BlockType:char;
     I,NewBottom,NewLeft,NewRight,NewTop,
     OffLeft,OffTop,Pass,XCord,YCord:integer;
     InFile:File;
     Buffer:array[0..32767] of byte;
     BufIndx,Count:word;
     Done,EOFin,SkipIt,Smash,Squeeze:Boolean;
     image: array [0..1023] of rowPtr;
     scale: longint;
     xadj,yadj: array [0..1023] of integer;
     white: byte;
     scaleHeight,scaleWidth: integer;

procedure quit;
 begin
   textmode(lastmode);
   halt;
 end;

procedure Abort;
 begin
  close(InFile);Quit
 end;

{$F+}
function GetByte: byte;
begin
 if not Done
  then begin
        if BufIndx >= Count
         then begin
               Done:=EOFIn;BlockRead(InFile,Buffer,SizeOf(Buffer),Count);
               EOFIn:=Count < sizeof(Buffer); BufIndx:=0
              end;
        GetByte:=Buffer[BufIndx]; Inc(BufIndx)
       end
  else GetByte:=0
end;
{$F-}

{$F+}
procedure PutByte(Pix: integer);
const YInc:array [1..5] of integer=(8,8,4,2,1);
      YLin:array [1..5] of integer=(0,4,2,1,0);
var x,y:integer;
begin
 x:=xadj[xCord];
 y:=yadj[yCord];
 if (x<320) and (y<200) then
   mem[$A000:word(320*y+x)]:=Pix;
 image[y]^[x]:=Pix;
 Inc(XCord);
 if XCord = NewRight
  then begin XCord:=NewLeft;
             if KeyPressed then Abort;
             Inc(YCord,YInc[Pass]);
             SkipIt:=Smash and ((YCord and 1)=1);
             if YCord >= NewBottom then
               begin
                 if Interlaced then Inc(Pass);
                 YCord:=YLin[Pass]+NewTop
               end;
       end
end;
{$F-}

procedure DoMapping;
    var
      i: integer;
      regs: registers;
      r,g,b: byte;
      temp,max: longint;
 begin
    max:=0;
    for i:=0 to NumberOfColors[CurMap]-1 do
      begin
        temp:=Sqr(Longint(redvalue[i]))+Sqr(Longint(greenvalue[i]))+Sqr(Longint(bluevalue[i]));
        if temp>max then
          begin max:=temp; white:=i; end;
        r:=redvalue[i] div 4;
        g:=greenvalue[i] div 4;
        b:=bluevalue[i] div 4;
        Inline($B8/$10/$10/$8B/$9E/>I/$8A/$B6/>R/$8A/$AE/>G/$8A/$8E/>B/$CD/$10);
      end;
 end;

procedure AdjustImage;
  var i: integer;
 begin
  NewLeft  := ImageLeft + OffLeft;
  NewTop   := ImageTop + OffTop;
  NewRight := ImageWidth + NewLeft;
  NewBottom:= ImageHeight + NewTop;
  XCord:=NewLeft;   YCord:=NewTop;
  if Interlaced then Pass:=1 else Pass:=5;
  scale:=1024;
  while MemAvail*15 div 16<(scale*imageWidth div 1024)*(scale*imageHeight div 1024) do
    Dec(scale);
  for i:=0 to ImageWidth-1 do
    xadj[i]:=scale*i div 1024;
  for i:=0 to ImageHeight-1 do
    yadj[i]:=scale*i div 1024;
  scaleHeight:=scale*ImageHeight div 1024;
  scaleWidth:=scale*ImageWidth div 1024;
  for i:=0 to scaleHeight-1 do
    GetMem(image[i],scaleWidth);
 end;

procedure DisplayScrDes;
var I:integer;
    AnsCh:char;
begin
 Writeln(ScreenWidth,'x',ScreenHeight,'  ',NumberOfColors[Global],' colors');
 OffLeft:=0; OffTop:=0;
 Smash:=false; Squeeze:=false;
 end;

  procedure GraphColorMode;
  begin { procedure GraphColorMode }
    inline($B8/$13/$00/$CD/$10);
    DoMapping;
  end; { procedure GraphColorMode }

  procedure pan;
    var
      done: boolean;
      ch: char;
      x,y: integer;

    procedure slideRight;
      var h,v,b: word; x0: integer;
    begin { procedure slideRight }
      if x=0 then exit;
      x0:=x;
      Dec(x,10); if x<0 then x:=0;
      for v:=0 to 199 do
        begin
          b:=word(320*v);
          Move(mem[$A000:b],mem[$A000:b+x0-x],320+x-x0);
          Move(image[y+v]^[x],mem[$A000:b],x0-x);
        end;
    end; { procedure slideRight }

    procedure slideLeft;
      var h,v,b: word; x0: integer;
    begin { procedure slideLeft }
      if x=scaleWidth-320 then exit;
      x0:=x;
      Inc(x,10); if x+320>scaleWidth then x:=scaleWidth-320;
      for v:=0 to 199 do
        begin
          b:=word(320*v);
          Move(mem[$A000:b+x-x0],mem[$A000:b],320+x0-x);
          Move(image[y+v]^[320+x0],mem[$A000:b+320+x0-x],x-x0);
        end;
    end; { procedure slideLeft }

    procedure slideDown;
      var h,v,b: word; y0: integer;
    begin { procedure slideDown }
      if y=0 then exit;
      y0:=y;
      Dec(y,10); if y<0 then y:=0;
      Move(mem[$a000:0],mem[$a000:320*(y0-y)],word(320*(200+y-y0)));
      for v:=0 to y0-y-1 do
        begin
          b:=word(320*v);
          Move(image[y+v]^[x],mem[$A000:b],320);
        end;
    end; { procedure slideDown }

    procedure slideUp;
      var h,v,b: word; y0: integer;
    begin { procedure slideUp }
      if y=scaleHeight-200 then exit;
      y0:=y;
      Inc(y,10); if y+200>scaleHeight then y:=scaleHeight-200;
      Move(mem[$A000:320*(y-y0)],mem[$A000:0],word(320*(200+y0-y)));
      for v:=200+y0-y to 199 do
        begin
          b:=word(320*v);
          Move(image[y+v]^[x],mem[$A000:b],320);
        end;
    end; { procedure slideUp }

  begin { procedure pan }
    x:=0; y:=0; done:=false;
    repeat
      ch:=readkey;
      if ch=#0 then
        case readkey of
          #75: if scaleWidth>320 then slideRight;
          #77: if scaleWidth>320 then slideLeft;
          #72: if scaleHeight>200 then slideDown;
          #80: if scaleHeight>200 then slideUp;
        end
      else
        case ch of
          #27: done:=True;
        end;
    until done;
  end; { procedure pan }

begin
 AddrGetByte:=@GetByte;
 AddrPutByte:=@PutByte;
 AssignCrt(output);Rewrite(OUTPUT);
 if paramcount=0
  then begin
        write('Enter GIF file name:  '); readln(infilename);
       end
  else InFileName:=paramstr(1);
 if length(InFileName)>0 then
  begin
   if pos('.',infilename)=0 then infilename:=infilename+'.gif';
   assign(InFile,InFileName);
   {$I-}
   reset(InFile,1);
   if ioresult<>0
    then begin writeln('GIF datafile could not be found.'); halt; end;
   SkipIt:=false;
   EOFin:=false;
   Done:=false;
   BufIndx:=999;Count:=0;
   CurMap:=Global;
   GetGIFSig;
   if GIFSig<>'GIF87a' then
     begin
       BufIndx:=128;
       GetGIFSig;
       if GIFSig<>'GIF87a' then
         begin
           writeln('Invalid GIF signature');
           Halt;
         end;
     end;
   GetScrDes;
   DisplayScrDes;
   if MapExists[Global] then GetColorMap;
   writeln('Press <Enter> to display and wait for beep');
   writeln('before scrolling image with arrow keys');
   readln;
   GraphColorMode;
   while not Done Do
    begin
     BlockType:=chr(GetByte);
     case BlockType of
      ',':begin
           GetImageDescription;
           AdjustImage;
           if MapExists[Local]
            then begin CurMap:=Local; GetColorMap; DoMapping end
            else CurMap:=Global;
           if ExpandGIF <>0 then Halt
          end;
      '!':SkipExtendBlock;
     end;
    end;
  end;
 Sound(1000);Delay(100);NoSound;
 pan;
 textmode(lastmode);
end.