Program showpcx;
{ Free Software by TapirSoft Gisbert W.Selke, Dec 1991                       }
{$A+,B-,D+,E+,F-,I-,L+,N-,O-,V- }
{$M 65520,0,128000 }

{$UNDEF DEBUG }     { DEFINE while debugging }

{$IFDEF DEBUG }
{$R+,S+ }
{$ELSE }
{$R-,S- }
{$ENDIF }

  Uses Graph, CRT, Dos;

  Const progname = 'ShowPCX';
        version  = '1.0';
        copyright= 'Free Software by TapirSoft Gisbert W.Selke, Dec 1991';

        bufsize  = 60000;
        maxlinlen= 2048; { maximum length of screen line }
        Tab      = #9;
        finishset: Set Of char = [#3,#27,'q','Q'];

  Type headrec = Record
                   id           : byte;  { must be $0A }
                   version      : byte;  { 0, 2, 3, or 5 }
                   compr        : byte;  { 1 if RLE-coded }
                   bitsperpixel : byte;
                   xmin         : word;
                   ymin         : word;
                   xmax         : word;
                   ymax         : word;
                   horidpi      : word; { horizontal resolution, dots per inch }
                   vertdpi      : word; { vertical   resolution, dots per inch }
                   colormap     : Array [0..15,0..2] Of byte;
                   reserved     : byte;
                   ncolplanes   : byte; { number of colour planes; max 4 }
                   bytesperline : word; { must be even }
                   greyscale    : word; { 1 if colour or b/w; 2 if greyscale }
                   filler       : Array [1..58] Of byte;
                 End;
       buffer   = Array [1..bufsize ] Of byte;
       linbuffer= Array [0..maxlinlen] Of byte;

  Var listf : text;
      inbufptr : ^buffer;
      sr : SearchRec;
      saveexit : Pointer;
      dir, picname : string;
      grdriver, grmode : integer;
      maxx, maxy, maxcolour, deltime : word;
      parampt, xscale, yscale, videomode : byte;
      zverbose, zxcentre, zycentre, zprop, zmono, zconj, zebra : boolean;
      zquiet, zgraph, zlist, zfirst, zfinish, zfound, zrepeat : boolean;

  { Link in graphics drivers for EGA, VGA and Hercules: }
  Procedure egavga_driver; External;
  {$L EGAVGA.OBJ }
  Procedure svga256_driver; External;
  {$L SVGA256.OBJ }
  Procedure herc_driver; External;
  {$L HERC.OBJ }

{$F+} function DetectVGA256 : integer; {$F-}
var
  DetectedDriver : integer;
  SuggestedMode  : integer;
begin
  DetectGraph(DetectedDriver, SuggestedMode);
  DetectVGA256 := SuggestedMode;
  if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
    DetectVGA256 := 0        { Default video mode = 0 }
  else
    DetectVGA256 := grError; { Couldn't detect hardware }
end; { DetectVGA256 }

  {$F+ } Procedure myexit; {$F- }
  { exit procedure to clean things up                                        }
    Var c : char;
  Begin                                                             { myexit }
    ExitProc := saveexit;
    NoSound;
    If zgraph Then
    Begin
      SetGraphMode(GetGraphMode);
      CloseGraph;
      zgraph := False;
    End;
    If Not zfound Then writeln('No matching PCX files found.');
    While KeyPressed Do c := ReadKey;
  End;                                                              { myexit }

  Procedure beep;
  { emit a short beep                                                        }
  Begin                                                               { beep }
    If Not zquiet Then
    Begin
      Sound(440);
      Delay(50);
      NoSound;
    End;
  End;                                                                { beep }

  Procedure abort(msg : string; ierr : byte);
  { show error message and die                                               }
  Begin                                                              { abort }
    If zgraph Then CloseGraph;
    zgraph := False;
    If msg <> '' Then writeln(progname,': ',msg);
    Halt(ierr);
  End;                                                               { abort }

  Procedure usage;
  { show usage hints and die                                                 }
  Begin                                                              { usage }
    writeln;
    writeln(progname,' ',version,': display PCX files on screen');
    writeln(copyright);
    writeln;
    writeln('Usage: ',progname,'  [<options>] <filespec> [<filespec>...]');
    writeln('       where <filespec> is the name of a PCX file, possibly ',
            'containing');
    writeln('             wildcard characters (default extension .PCX),');
    writeln('       or "@", followed immediately by the name of a file ');
    writeln('             containing names of PCX files.');
    writeln('       Options: /c  : centre image');
    writeln('                /cx : centre image horizontally');
    writeln('                /cy : centre image vertically');
    writeln('                /d<num>  : delay in milliseconds after each ',
            'image');
    writeln('                /e<num>  : extended VGA mode (use at your own ',
            'risk!)');
    writeln('                /h  : display help');
    writeln('                /m  : force monochrome mode');
    writeln('                /p  : use alternate packing strategy for scaling');
    writeln('                /q  : quiet behaviour (don''t beep)');
    writeln('                /r  : repeat indefinitely');
    writeln('                /s<num>  : scale image by factor ',
            '1/<num> (0 = autoscale)');
    writeln('                /sx<num> : scale horizontally only');
    writeln('                /sy<num> : scale vertically only');
    writeln('                /v  : verbose image info');
    writeln('                /z  : zebra monochrome mode');
    zfound := True;
    abort('',1);
  End;                                                               { usage }

  Procedure strip(Var s : string);
  { remove leading and trailing white space                                  }
  Begin                                                              { strip }
    While (s <> '') And (s[1] In [' ',Tab]) Do Delete(s,1,1);
    While (s <> '') And (s[Length(s)] In [' ',Tab]) Do Delete(s,Length(s),1);
  End;                                                               { strip }

  Function getnextname : string;
  { get name of next file to display                                         }
    Var temp, nam, ext : string;
        doserr : integer;
  Begin                                                        { getnextname }
    sr.name := '';
    doserr := 0;
    If zfirst Then
    Begin
      temp := '';
      While zlist And (temp = '') Do
      Begin
        If EoLn(listf) And (Not EoF(listf)) Then readln(listf);
        If IOResult <> 0 Then;
        If zlist And EoF(listf) Then
        Begin
          Close(listf);
          Dispose(inbufptr);
          zlist := False;
        End;
        If zlist Then read(listf,temp);
        If IOResult <> 0 Then;
        strip(temp);
      End;
      If temp = '' Then
      Begin
        While (temp = '') And (parampt <= ParamCount) Do
        Begin
          If (parampt = ParamCount) And zrepeat And zfound Then parampt := 0;
          Inc(parampt);
          If parampt <= ParamCount Then temp := ParamStr(parampt);
          If temp[1] In ['-','/'] Then temp := '';
        End;
        If temp[1] = '@' Then
        Begin
          Assign(listf,Copy(temp,2,255));
          Reset(listf);
          If IOResult <> 0 Then;
          New(inbufptr);
          SetTextBuf(listf,inbufptr^);
          zlist := True;
          temp := getnextname;
        End;
      End;
      If temp <> '' Then
      Begin
        FSplit(temp,dir,nam,ext);
        If ext = '' Then ext := '.PCX';
        temp := dir + nam + ext;
        FindFirst(temp,ReadOnly+Hidden+SysFile+Archive,sr);
        doserr := DosError;
        If doserr = 0 Then zfound := True;
        zfirst := False;
      End
      Else
      Begin
        dir := '';
        sr.name := '';
      End;
    End
    Else
    Begin
      FindNext(sr);
      doserr := DosError;
    End;
    If doserr = 18 Then
    Begin
      zfirst := True;
      getnextname := getnextname;
    End
      Else getnextname := dir + sr.name;
  End;                                                         { getnextname }

  Procedure init;
  { do all necessary initializations                                         }
    Var temp : string;
        l : integer;
        i : byte;

    Function getnumber(str : string; min, max, default : word) : word;
    { convert a string to a number, checling bounds                          }
      Var num : longint;
          ires : integer;
    Begin                                                        { getnumber }
      ires := 0;
      {$R- }
      If str = '' Then num := default
                  Else Val(str,num,ires);
{$IFDEF DEBUG }
      {$R+ }
{$ENDIF }
      If ires <> 0 Then num := default;
      If num < min Then num := min;
      If num > max Then num := max;
      getnumber := num;
    End;                                                         { getnumber }

  Begin                                                               { init }
    If RegisterBGIDriver(@egavga_driver) < 0 Then
                   abort('Illegal EGA/VGA graphics driver information',2);
    If RegisterBGIDriver(@herc_driver) < 0 Then
                   abort('Illegal Hercules graphics driver information',2);
    zgraph   := False;
    saveexit := ExitProc;
    ExitProc := @myexit;
    zfirst   := True;
    zfinish  := False;
    zlist    := False;
    zquiet   := False;
    zverbose := False;
    zrepeat  := False;
    zmono    := False;
    zconj    := False;
    zebra    := False;
    zxcentre := False;
    zycentre := False;
    zprop    := False;
    deltime  := 65535;
    xscale   := 255;
    yscale   := 255;
    zfound   := False;
    parampt  := 0;
    FileMode := 0;
    If ParamCount = 0 Then usage;
    grdriver := Detect;
    grmode   := 0;
    videomode:= 255;
    InitGraph(grdriver,grmode,'');
    If GraphResult <> 0 Then abort('Cannot find graphics driver',2);
    zgraph   := True;
    For i := 1 To ParamCount Do
    Begin
      temp := ParamStr(i);
      If (temp[1] In ['-','/']) And (Length(temp) >= 2) Then
      Begin
        Case UpCase(temp[2]) Of
          'C' : Begin { centering }
                  If (Length(temp) >= 3) Then
                  Begin
                    Case UpCase(temp[3]) Of
                      'X' : zxcentre := True;
                      'Y' : zycentre := True;
                    End;
                  End
                  Else
                  Begin
                    zxcentre := True;
                    zycentre := True;
                  End;
                End;
          'E' : Begin { extended video mode }
                  If (Length(temp) >= 3) Then videomode :=
                                         getnumber(Copy(temp,3,255),0,255,0)
                                         Else videomode := 10;
                End;
          'D' : Begin { delay }
                  If (Length(temp) >= 3) Then deltime :=
                                         getnumber(Copy(temp,3,255),0,65534,10)
                                         Else deltime := 10;
                End;
          'H','?' : usage;
          'M' : zmono := True;
          { monochrome }
          'P' : Begin { packing strategy (for scaling) }
                  If (Length(temp) <= 2) Or (UpCase(temp[3]) = 'C') Then
                                                                zconj := True;
                End;
          'Q' : zquiet  := True;
          'R' : zrepeat := True;
          'S' : Begin { scaling }
                  If (Length(temp) >= 3) Then
                  Begin
                    Case UpCase(temp[3]) Of
                      'X' : xscale := getnumber(Copy(temp,4,255),0,255,0);
                      'Y' : yscale := getnumber(Copy(temp,4,255),0,255,0);
                      Else Begin
                             xscale := getnumber(Copy(temp,3,255),0,255,0);
                             yscale := xscale;
                             zprop  := True;
                           End;
                    End;
                  End
                  Else
                  Begin
                    xscale := 0;
                    yscale := 0;
                    zprop  := True;
                  End;
                End;
          'V' : zverbose := True;
          'Z' : Begin { zebra monochrome }
                  zmono := True;
                  zebra := True;
                End;
          Else usage;
        End;
      End;
    End;
    If (videomode <> 255) And (grdriver = VGA) Then
    Begin
      l := InstallUserDriver('SVGA256', @DetectVGA256);
      If l > 0 Then
      Begin
        grdriver := l;
        grmode := videomode;
        CloseGraph;
        If RegisterBGIDriver(@svga256_driver) < 0 Then
                   abort('Illegal SuperVGA graphics driver information',2);
        InitGraph(grdriver,grmode,'');
      End;
    End;
    maxx     := GetMaxX;
    maxy     := GetMaxY;
    maxcolour:= GetMaxColor;
    If maxx > maxlinlen Then abort('Screen too wide for internal buffer',2);
  End;                                                                { init }

  Procedure showfile(nam : string);
  { display the given PCX file                                               }

    Var picf : File;
        header : headrec;
        linbuf : linbuffer;
        picbuf : buffer;
        ltemp  : longint;
        iread, x, y, x2, y2, j, thisbyte : word;
        answer : char;
        repeatct, b, b2, c, i, horisub, vertsub, horict, vertct : byte;
        bitsperplane : byte;
        zdecomp, zcompr : boolean;

    Procedure showheader;
    { if in verbose mode, display info on PCX file                           }
    Begin                                                       { showheader }
      RestoreCRTMode;
      ClrScr;
      write('File: ',nam);
      writeln(' (Size: ',FileSize(picf),')');
      With header Do
      Begin
        write  ('Version: ',version:4,'; ');
        Case compr Of
          0 : writeln('Uncompressed');
          1 : writeln('RLE-compressed');
          Else writeln('Unknown compression method');
        End;
        write  ('Upper left corner: (',xmin:4,',',ymin:4,'); ');
        writeln('lower right corner: (',xmax:4,',',ymax:4,')');
        write  ('Resolution: horizontal: ',horidpi:4,' dpi; ');
        writeln('vertical: ',vertdpi:4,' dpi');
        write  ('Bits per pixel: ',bitsperpixel:4,'; ');
        writeln('number of colour planes: ',ncolplanes:4);
        write  ('Bytes per line: ',bytesperline:4,'; ');
        If greyscale = 2 Then writeln('display as grey scales')
                         Else writeln('display as colour rsp. b/w');
      End;
      write('Hit space bar to continue... ');
      answer  := ReadKey;
      zfinish := answer In FinishSet;
      If Not zfinish Then answer := #0;
      SetGraphMode(grmode);
    End;                                                        { showheader }

    Function getnextbyte : byte;
    { reads next byte from input file, handling compression                  }

      Procedure getnextchunk;
      { get next chunk from input file                                       }
      Begin                                                   { getnextchunk }
        If EoF(picf) Then iread := 0
        Else
        Begin
          BlockRead(picf,picbuf,SizeOf(picbuf),iread);
          If IOResult <> 0 Then iread := 0;
        End;
        thisbyte := 0;
      End;                                                    { getnextchunk }

    Begin                                                      { getnextbyte }
      If Not zdecomp Then
      Begin
        If thisbyte >= iread Then getnextchunk;
        If thisbyte < iread Then
        Begin
          Inc(thisbyte);
          If zcompr And (picbuf[thisbyte] >= 192) Then
          Begin
            repeatct := picbuf[thisbyte] And $3F;
            zdecomp := repeatct > 0;
            If thisbyte >= iread Then getnextchunk;
            Inc(thisbyte);
          End;
        End;
      End;
      If zdecomp Then
      Begin
        getnextbyte := picbuf[thisbyte];
        Dec(repeatct);
        zdecomp := repeatct > 0;
      End
      Else
      Begin
        If iread > 0 Then
        Begin
          getnextbyte := picbuf[thisbyte];
        End
          Else getnextbyte := 0;
      End;
    End;                                                       { getnextbyte }

    Procedure VGASetAllPalette(var P);
    { set all colour registers of the VGA quickly; values are RGB, 0..63     }
      Var regs : Registers;
    Begin                                                 { VGASetAllPalette }
      With regs Do
      Begin
        ax := $1012;
        bx := 0;
        cx := 256;
        es := Seg(P);
        dx := Ofs(P);
      End;
      Intr($10, regs);
    End;                                                  { VGASetAllPalette }

  Begin                                                           { showfile }
    ClearDevice;
    Assign(picf,nam);
    Reset(picf,1);
    answer := #0;
    If IOResult = 0 Then
    Begin
      BlockRead(picf,header,SizeOf(header),iread);
      If iread <> SizeOf(header) Then abort('PCX file too short',3);
    End;
    If IOResult = 0 Then
    Begin
      If zverbose Then showheader;
      With header Do
      Begin
        If id <> $0A Then abort('Illegal PCX header',3);
        If Not (version In [0,2,3,5]) Then abort('Illegal PCX header',3);
        If Not (compr In [0,1]) Then abort('Illegal PCX header',3);
        If Not (ncolplanes In [0..4]) Then abort('Illegal PCX header',3);
        If Odd(bytesperline) Then abort('Illegal PCX header',3);
        If Not (greyscale In [1..2]) Then greyscale := 1;
      End;
    End;
    With header Do
    Begin
      If ncolplanes = 0 Then ncolplanes := 1;
      bitsperplane := bitsperpixel*ncolplanes;
      i := grmode;
      x := xmax - xmin + 1;
      y := ymax - ymin + 1;
      Case grdriver Of
        CGA  : Begin
                 If x <= 320 Then i := CGAC0
                             Else i := CGAHi;
               End;
        MCGA, ATT400 : Begin
                 If (x <= 320) And (y <= 200) Then i := MCGAC0
                 Else
                 Begin
                   If y <= 200 Then i := MCGAMed
                               Else i := MCGAHi;
                 End;
               End;
        EGA, EGA64, EGAMono : Begin
                 If y <= 200 Then i := EGALo
                 Else
                 Begin
                   If grdriver = EGAMono Then i := EGAMonoHi
                                         Else i := EGAHi;
                 End;
               End;
        VGA  : Begin
                 If y <= 200 Then i := VGALo
                 Else
                 Begin
                   If y <= 350 Then i := VGAMed
                               Else i := VGAHi;
                 End;
               End;
      End;
      If i <> grmode Then
      Begin
        SetGraphMode(i);
        grmode    := GetGraphMode;
        maxx      := GetMaxX;
        maxy      := GetMaxY;
        maxcolour := GetMaxColor;
      End;
      If (Not zmono) And (version In [2,5]) And
         ((grdriver In [EGA,EGA64,VGA]) Or (videomode <> 255)) Then
      Begin
        Case bitsperplane Of
          4 : Begin
                For i := 0 To 15 Do
                  SetRGBPalette(i,colormap[i,0],colormap[i,1],colormap[i,2]);
              End;
          8 : Begin
                ltemp := FilePos(picf);
                Seek(picf,FileSize(picf)-768);
                BlockRead(picf,picbuf,768,x);
                Seek(picf,ltemp);
                If x = 768 Then
                Begin
                  For y := 1 To 768 Do picbuf[y] := picbuf[y] ShR 2;
                  VGASetAllPalette(picbuf);
                End;
              End;
        End;
      End;
      horisub := xscale;
      If xscale = 255 Then horisub := 1;
      If xscale = 0 Then
      Begin
        horisub := 1;
        While ((xmax-xmin+horisub-1) Div horisub) > maxx+5 Do Inc(horisub);
      End;
      vertsub := yscale;
      If yscale = 255 Then vertsub := 1;
      If yscale = 0 Then
      Begin
        vertsub := 1;
        While ((ymax-ymin+vertsub-1) Div vertsub) > maxy+5 Do Inc(vertsub);
      End;
      If zprop Then
      Begin
        If (horisub < vertsub) And (xscale = 0) Then horisub := vertsub;
        If (vertsub < horisub) And (yscale = 0) Then vertsub := horisub;
      End;
      If zxcentre Then
      Begin
        x := (xmax-xmin+horisub-1) Div horisub;
        If x < maxx Then
        Begin
          xmax := xmax - xmin + (maxx - x) Div 2;
          xmin := (maxx - x) Div 2;
        End;
      End;
      If zycentre Then
      Begin
        y := (ymax-ymin+vertsub-1) Div vertsub;
        If y < maxy Then
        Begin
          ymax := ymax - ymin + (maxy - y) Div 2;
          ymin := (maxy - y) Div 2;
        End;
      End;
      zcompr := compr = 1;
      thisbyte := Succ(iread);
      zdecomp := False;
      y  := ymin;
      y2 := ymin;
      vertct := 0;
      While (y <= ymax) And (y2 <= maxy) And (Not KeyPressed) And
                                             (Not zfinish) Do
      Begin
        If y2 < maxy Then
        Begin
          If y2-ymin <= maxx Then PutPixel(y2-ymin,maxy,maxcolour);
        End
        Else
        Begin
          SetColor(Black);
          Line(0,maxy,maxx,maxy);
        End;
        Case bitsperplane Of
          1 : Begin
            x  := xmin;
            x2 := xmin;
            horict := 0;
            If zconj Then b2 := $FF
                     Else b2 := 0;
            For j := 1 To bytesperline Do
            Begin
              b := getnextbyte;
              If vertct = 0 Then
              Begin
                For i := 1 To 8 Do
                Begin
                  If (x <= xmax) And (x2 <= maxx) Then
                  Begin
                    If zconj Then b2 := b2 And b
                             Else b2 := b2 Or  b;
                    Inc(horict);
                    If horict = horisub Then
                    Begin
                      If (b2 And $80) <> 0 Then PutPixel(x2,y2,maxcolour);
                      If zconj Then b2 := $FF
                               Else b2 := 0;
                      Inc(x2);
                      horict := 0;
                    End;
                    {$R- }
                    b := b ShL 1;
{$IFDEF DEBUG }
                    {$R+ }
{$ENDIF }
                    Inc(x);
                  End;
                End;
              End;
            End;
          End;
          2..7 : Begin
            FillChar(linbuf,Succ(maxx),#0);
            For c := 1 To ncolplanes Do
            Begin
              x  := xmin;
              x2 := 0;
              horict := 0;
              If zconj Then b2 := $FF
                       Else b2 := 0;
              For j := 1 To bytesperline Do
              Begin
                b := getnextbyte;
                If vertct = 0 Then
                Begin
                  For i := 1 To 8 Do
                  Begin
                    If (x <= xmax) And (x2 <= maxx) Then
                    Begin
                      If zconj Then b2 := b2 And b
                               Else b2 := b2 Or  b;
                      Inc(horict);
                      If horict = horisub Then
                      Begin
                        linbuf[x2] := linbuf[x2] ShL 1;
                        If (b2 And $80) <> 0 Then Inc(linbuf[x2]);
                        If zconj Then b2 := $FF
                                 Else b2 := 0;
                        Inc(x2);
                        horict := 0;
                      End;
                      {$R- }
                      b := b ShL 1;
{$IFDEF DEBUG }
                      {$R+ }
{$ENDIF }
                      Inc(x);
                    End;
                  End;
                End;
              End;
            End;
            If vertct = 0 Then
            Begin
              x  := xmin;
              x2 := 0;
              While x <= xmax Do
              Begin
                If linbuf[x2] <> 0 Then
                Begin
                  If zmono Then
                  Begin
                    If zebra Then
                    Begin
                      If Odd(linbuf[x2]) Then PutPixel(x,y2,maxcolour);
                    End
                    Else PutPixel(x,y2,maxcolour);
                  End
                    Else PutPixel(x,y2,linbuf[x2] Mod Succ(maxcolour));
                End;
                Inc(x2);
                Inc(x,horisub);
              End;
            End;
          End;
          8 : Begin
             If vertct = 0 Then
             Begin
               x := xmin;
               j := 1;
               While (j <= bytesperline) Do
               Begin
                 If zconj Then b2 := $FF
                          Else b2 := 0;
                 For i := 1 To horisub Do
                 Begin
                   If j <= bytesperline Then
                   Begin
                     b := getnextbyte;
                     If zconj Then
                     Begin
                       If b < b2 Then b2 := b;
                     End
                     Else
                     Begin
                       If b > b2 Then b2 := b;
                     End;
                     Inc(j);
                   End;
                 End;
                 If (b2 <> 0) And (x <= xmax) Then
                 Begin
                   If zmono Then
                   Begin
                     If zebra Then
                     Begin
                       If Odd(b2) Then PutPixel(x,y2,maxcolour);
                     End
                       Else PutPixel(x,y2,maxcolour);
                   End
                     Else PutPixel(x,y2,b2 Mod Succ(maxcolour));
                   If (x > 20) And (y2 > 20) And (x < 750) And (y < 300) And
                      (b2 = 0) Then
                   Begin
                     b2 := b2;
                   End;
                 End;
                 Inc(x);
               End;
             End
             Else
             Begin
               For j := 1 To bytesperline Do b := getnextbyte;
             End;
          End;
        End;
        Inc(y);
        If vertct = 0 Then Inc(y2);
        vertct := Succ(vertct) Mod vertsub;
      End;
      If y2 <= maxy Then
      Begin
        SetColor(Black);
        Line(0,maxy,maxx,maxy);
      End;
    End;
    Close(picf);
    If IOResult <> 0 Then;
    beep;
    x := 0;
    If KeyPressed Then answer := ReadKey;
    While (x < deltime) And (answer = #0) Do
    Begin
      Delay(100);
      If deltime < 65535 Then x := x + 100;
      If KeyPressed Then answer := ReadKey;
    End;
    zfinish := answer in FinishSet;
    SetGraphMode(grmode);
  End;                                                            { showfile }

Begin                                                                 { main }
  init;
  Repeat
    picname := getnextname;
    If picname <> '' Then showfile(picname);
  Until (picname = '') Or zfinish;
End.