Monster Media 1994 #1/monster.zip/monster/BBS_UTIL/BGFAX121.ZIP/SOURCE.ZIP/VIEW.PAS

Pascal/Delphi Source File | 1994-03-25 | 22KB | 800 lines

program
  view;
{.R+}   (* active range checking only while debuging program, decodes about
           three times faster with range checking turned off *)
uses
  dos, crt;

{$i faxtree.pas}
const
  mrcoding = false;
  maxfaxbuf = 8192;
  maxoutbuf = 65534; { keep at this value, so doesn't wrap to 0 when INC'ed }
  maxlinelen = 215; { 0..215, i.e., 216 bytes }
  base2 : array[1..8] of word = (1, 2, 4, 8, 16, 32, 64, 128);
  base2r : array[1..8] of word = (128, 64, 32, 16, 8, 4, 2, 1);
  maxscanlinerec = 2560;
  gfx : array[0..2] of array[0..2] of word = (
    ($11,464{480},$a000){VGA}, ($0f,334{350},$a000){EGA}, ($6,200,$b800){CGA});
  gmode : byte = 0;
  shownpage : boolean = false;
  revbitord : boolean = false;
  displaybad : boolean = false;

type
  scanlinerec = record
    scanline : array[0..maxlinelen] of byte;
  end;
  scanlinearray = array[1..maxscanlinerec] of ^scanlinerec;
  outbuftype = array[1..maxoutbuf] of byte;
  pcxrec = record
    zsoft    : byte;
    version  : byte;
    encoding : byte;
    bitpix   : byte;
    dimens   : array[1..4] of word;
    hres     : word;
    vres     : word;
    palette  : array[1..48] of byte;
    reserved : byte;
    planes   : byte;
    byteline : word;
    paltype  : word;
    xssize   : word;
    yssize   : word;
    filler   : array[1..54] of byte;
  end;
  zfaxhead = record
    header   : array[1..5] of char;
    offset   : byte;
    version  : word;
    reserved : word;
    pgwidth  : word;
    pgcount  : word;
    coding   : word;
  end;
  qfaxhead = record
    header   : array[1..8] of char;
    pgcount  : word;
    lastscan : word;
    totscan  : longint;
    hscale   : word;
    vscale   : word;
    filler   : array[1..12] of char;
    pgpoint  : array[1..376] of longint;
  end;

var
  faxfile, outfile : file;
  pcx : pcxrec; zfax : zfaxhead; qfax : qfaxhead;
  page, maxpages, lines, badlines, bytesread, bufbit, bufbyte,
    outbufp, padlines : word;
  startclock : real;
  faxbuf : array[1..maxfaxbuf] of byte;
  outbuf : ^outbuftype;
  scanlinebuf : array[0..maxlinelen] of byte;
  fillbits, faxsize, faxpos : longint;
  endoffile, mhline, endofpage : boolean;
  regs : registers;
  scanlinep : ^scanlinearray;
  scanline : scanlinerec;
  fopen : string[79];
  ofn : string[8];
  pagepos : array[1..128] of longint;
  sqzary : array[1..80] of byte;

function dosclock : real;
var
  regs : registers;
begin
  regs.ah := $2c;
  msdos(regs);
  dosclock := regs.ch*3600+regs.cl*60.0+regs.dh+regs.dl/100.0;
end;

procedure fatal(s : string);
begin
  if shownpage then
    textmode(3);
  writeln;
  writeln;
  writeln(#7'Fatal Error: '+s);
  halt(1);
end;

function bswap(code : byte) : byte; assembler;
asm
  mov dl,code
  xor ax,ax
  mov cx,8
 @loop: shr dl,1
  rcl al,1
  loop @loop
end;

procedure flipfax;
var
  i : word;
  j, t, p : byte;
begin
  for i := 1 to (lines div 2) do begin
    move(scanlinep^[i]^.scanline, scanlinebuf, sizeof(scanlinebuf));
    move(scanlinep^[lines-i+1]^.scanline, scanlinep^[i]^.scanline,
      sizeof(scanlinebuf));
    move(scanlinebuf, scanlinep^[lines-i+1]^.scanline, sizeof(scanlinebuf));
  end;
  for i := 1 to lines do begin
    if i mod 64 = 0 then
      sound(100);
    for j := 0 to 107 do begin
      p := 215-j;
      t := bswap(scanlinep^[i]^.scanline[j]);
      scanlinep^[i]^.scanline[j] := bswap(scanlinep^[i]^.scanline[p]);
      scanlinep^[i]^.scanline[p] := t;
    end;
    if i mod 64 = 0 then
      nosound;
  end;
end;

procedure invertfax;
var
  i, j : word;
begin
  for i := 1 to lines do begin
    if i mod 128 = 0 then
      sound(100);
    for j := 0 to maxlinelen do
      scanlinep^[i]^.scanline[j] := scanlinep^[i]^.scanline[j] xor 255;
    if i mod 128 = 0 then
      nosound;
  end;
end;

function is(l : longint) : string;
var
  s : string;
begin
  str(l, s);
  is := s;
end;

function rp(s : string; l : byte) : string;
var
  ss : string;
begin
  fillchar(ss[1], l, #32);
  move(s[1], ss[1], length(s));
  ss[0] := chr(l);
  rp := ss;
end;


function viewfax(partial : boolean) : char;
var
  x, y, ymost : word;
  gk, ge : char;

  procedure movefax;
  var
    i, dx, dy, ymax : word;
  begin
    dx := x*8;
    dy := y*32;
    if gmode = 2 then begin { cga, interlaced mode }
      ymax := (gfx[gmode][1] div 2)-1;
      for i := 4 to ymax do begin
        inc(dy, 2);
        move(scanlinep^[dy]^.scanline[dx], mem[gfx[gmode][2]:80*i], 80);
      end;
      dy := y*32+1;
      ymax := (gfx[gmode][1])-1;
      for i := 4+(gfx[gmode][1] div 2) to ymax do begin
       inc(dy, 2);
       move(scanlinep^[dy]^.scanline[dx], mem[gfx[gmode][2]:192+80*i], 80);
      end;
    end else begin { ega/vga }
      ymax := gfx[gmode][1]-1 + 16;
      for i := 16{0} to ymax do begin
        inc(dy);
        move(scanlinep^[dy]^.scanline[dx], mem[gfx[gmode][2]:80*i], 80);
      end;
    end;
  end;

  procedure shrinkfax;
  var
    i, dx, dy, ymax : word;
   procedure makesqz(y : word);
   var a : byte;
   begin
     for a := 1 to 72 do begin
       sqzary[a] :=
         (scanlinep^[dy]^.scanline[a*3-3] and 128){1} +
         (scanlinep^[dy]^.scanline[a*3-2] and 8){16};
       if (scanlinep^[dy]^.scanline[a*3-3] and 16){2} = 16 then
         sqzary[a] := sqzary[a] xor 64;
       if (scanlinep^[dy]^.scanline[a*3-3] and 2){4} = 2 then
         sqzary[a] := sqzary[a] xor 32;
       if (scanlinep^[dy]^.scanline[a*3-2] and 64){8} = 64 then
         sqzary[a] := sqzary[a] xor 16;
       if (scanlinep^[dy]^.scanline[a*3-2] and 1){32} = 1 then
         sqzary[a] := sqzary[a] xor 4;
       if (scanlinep^[dy]^.scanline[a*3-1] and 32){64} = 32 then
         sqzary[a] := sqzary[a] xor 2;
       if (scanlinep^[dy]^.scanline[a*3-1] and 4){128} = 4 then
         sqzary[a] := sqzary[a] xor 1;
       end;
     move(sqzary, mem[gfx[gmode][2]:y], 80)
   end;
  begin
    dx := x*8;
    dy := y*32;
    if gmode = 2 then begin { cga, interlaced mode }
      ymax := (gfx[gmode][1] div 2)-1;
      for i := 4 to ymax do begin
        inc(dy, 2);
        makesqz(80*i);
      end;
      dy := y*32+1;
      ymax := (gfx[gmode][1])-1;
      for i := 4+(gfx[gmode][1] div 2) to ymax do begin
       inc(dy, 2);
       makesqz(192+80*i);
      end;
    end else begin { ega/vga }
      ymax := gfx[gmode][1]-1 + 16;
      for i := 16{0} to ymax do begin
        inc(dy);
        makesqz(80*i);
      end;
    end;
  end;

begin
  if not partial then begin
    if gmode >= 200 then begin
      inc(faxpos, bufbyte);
      blockwrite(outfile, outbuf^, outbufp, x);
      close(outfile);
      reset(outfile, 1);
      writeln;
      writeln('PCX File Size [', filesize(outfile) div 1024, 'K]');
      blockread(outfile, outbuf^, sizeof(pcxrec), x);
      move(outbuf^, pcx, sizeof(pcxrec));
      pcx.dimens[4] := lines-1; { updating number of lines }
      move(pcx, outbuf^, sizeof(pcxrec));
      seek(outfile, 0);
      blockwrite(outfile, outbuf^, sizeof(pcxrec), x);
      close(outfile);
      viewfax := #81;
      exit;
    end;
    if lines = 0 then
      fatal('no valid scan lines detected');
    fillchar(scanlinebuf, sizeof(scanlinebuf), 85);
    if lines < gfx[gmode][1] then begin
      ymost := 0;
      for y := lines+1 to gfx[gmode][1] do begin
        if memavail > sizeof(scanlinerec) then begin
          inc(padlines);
          new(scanlinep^[y]);
          move(scanlinebuf, scanlinep^[y]^, sizeof(scanlinebuf));
        end;
      end;
    end else begin
      y := lines-gfx[gmode][1];
      x := lines;
      repeat { fill boundries }
        inc(y);
        inc(x);
        if memavail > sizeof(scanlinerec) then begin
          inc(padlines);
          new(scanlinep^[x]);
          move(scanlinebuf, scanlinep^[x]^, sizeof(scanlinebuf));
        end;
      until(y mod 32 = 0);
      ymost := y div 32;
    end;
  end;
  x := 0;
  y := 0;
  if (partial) or (not shownpage) then begin
    shownpage := true;
    directvideo := false;
    gotoxy(1,1);
    regs.ax := gfx[gmode][0]; { switch to graphics mode }
    intr($10, regs);
    movefax;
    write('[WAIT]'#13);
    if partial then
      exit;
  end;
  inc(faxpos, bufbyte);
  write(rp('Page '+is(page)+'/'+is(maxpages)+'... '+is(lines)+' scan lines, '+
    is(badlines)+' bad lines', 79)+#13);
  sound(2000);
  delay(100);
  nosound;
  repeat
    repeat
    until(keypressed);
    gk := readkey;
    if gk = #0 then begin
      ge := readkey;
      case ge of
        #23 : begin {alt-i}
          invertfax;
          movefax;
        end;
        #31 : begin {alt-s}
          shrinkfax;
        end;
        #33 : begin {alt-f}
          flipfax;
          movefax;
        end;
        #75 : begin {left}
          if x > 0 then begin
            dec(x);
            movefax;
          end;
        end;
        #77 : begin {right}
          if x < 17 then begin
            inc(x);
            movefax;
          end;
        end;
        #72 : begin {up}
          if y > 0 then begin
            dec(y);
            movefax;
          end;
        end;
        #80 : begin {down}
          if y < ymost then begin
            inc(y);
            movefax;
          end;
        end;
        #73 : begin
          viewfax := #73;
          exit;
        end;
        #81 : begin {pgdn}
          viewfax := #81;
          exit;
        end;
      end;
    end;
  until(gk=#27);
  viewfax := #0;
end;

procedure loadingblock;
begin
  clreol;
  write(rp('Loading... '+is(filepos(faxfile) div 1024)+'K read, '+
    is(lines)+' scan lines, '+is(badlines)+' bad lines, '+
    is(memavail div 1024)+'K mem free', 79)+#13);
  {write('[', filepos(faxfile) div 1024, 'K]  Memory [',
    memavail div 1024, 'K]  Scan Lines [', lines, ']  Bad [',
    badlines, ']  Fill Bytes [', fillbits div 8, ']'#13);}
end;

function readbit : byte;
begin
  if bufbit = 7 then begin
    bufbit := 0;
    inc(bufbyte);
    if bufbyte > bytesread then begin
      inc(faxpos, bufbyte);
      bufbyte := 1;
      if not endoffile then begin
        blockread(faxfile, faxbuf, sizeof(faxbuf), bytesread);
        loadingblock;
        if filepos(faxfile) >= faxsize then
          endoffile := true;
      end else begin
        write(#7+rp('WARNING: fax file terminates without RTC', 79)+#13);
        delay(1000);
        endofpage := true;
        maxpages := page;
        faxbuf[1] := 0;
        faxbuf[2] := 128; { dummy EOL }
        bytesread := 2;
      end;
    end;
    if revbitord then
      faxbuf[bufbyte] := bswap(faxbuf[bufbyte]);
    readbit := faxbuf[bufbyte] and 1;
  end else begin
    inc(bufbit);
    readbit := (faxbuf[bufbyte] shr bufbit) and 1;
  end;
end;

function findrun(color : boolean) : integer;
var
  k, j, value : integer;
  bit : byte;
  ch : char;
begin
  if keypressed then begin
    ch := readkey;
    if ch = #27 then begin
      if shownpage then
        textmode(3);
      close(faxfile);
      writeln;
      writeln('Fax load terminated by user.');
      halt;
    end else begin
      sound(100);
      delay(100);
      nosound;
      write(rp('The facsimile image has not yet finished loading.', 79)+#13);
    end;
  end;
  value := 0;
  repeat
    k := 0;
    if color then begin {white}
      repeat
        bit := readbit;
        k := whiteh[k][bit];
      until(whiteh[k][2] > -9); { read until hit tree root }
      j := whiteh[k][2];
    end else begin
      repeat
        bit := readbit;
        k := blackh[k][bit];
      until(blackh[k][2] > -9);
      j := blackh[k][2];
    end;
    inc(value, j);
  until(j < 64);
  if j = -2 then begin { fill }
    while readbit=0 do
      inc(fillbits);
    value := -1;
  end;
  findrun := value;
end;

procedure putoutbuf(b : byte);
var
  zz : word;
begin
  inc(outbufp);
  if outbufp > maxoutbuf then begin
    blockwrite(outfile, outbuf^, maxoutbuf, zz);
    outbufp := 1;
  end;
  outbuf^[outbufp] := b;
end;

function zp(s : string; l : byte) : string;
begin
  while length(s) < l do
    s := '0'+s;
  zp := s;
end;

procedure decodeblock;
var
  bit, slbit, r, v, ceol : byte;
  k, j, run : integer;
  io, runlen, i, slbyte : word;
  color : boolean;
begin
  if gmode >= 200 then begin
    fopen := ofn+'.P'+zp(is(page), 2);
    writeln('Writing ['+fopen+']');
    assign(outfile, fopen);
    rewrite(outfile, 1);
    fillchar(pcx, sizeof(pcx), #0);
    pcx.zsoft := 10;
    pcx.version := 5;
    pcx.encoding := 1;
    pcx.bitpix := 1;
    pcx.dimens[1] := 0;
    pcx.dimens[2] := 0;
    pcx.dimens[3] := 1727;
    pcx.dimens[4] := 0; { this needs to be updated after conversion }
    pcx.hres := 640;
    pcx.vres := 480;
    pcx.planes := 1;
    pcx.byteline := 216;
    pcx.paltype := 1;
    pcx.xssize := 640;
    pcx.yssize := 480;
    move(pcx, outbuf^, sizeof(pcxrec));
    blockwrite(outfile, outbuf^, sizeof(pcxrec), io);
    outbufp := 0; { keep at zero }
  end;
  endoffile := false;
  endofpage := false;
  bytesread := 0;
  bufbit := 7;
  bufbyte := 1;
  lines := 0;
  padlines := 0;
  badlines := 0;
  fillbits := 0;
  ceol := 0;
  repeat
    run := findrun(true);
  until(run=-1); { faxes always start with an EOL }
  if mrcoding then begin { if two dimensional }
    bit := readbit; { first bit after FIRST EOL should always be 1 }
    if bit = 0 then { MR-coding }
      fatal('file probably not 2D-MR encoding');
  end;
  mhline := true; { first scan line is 1d coding, all fax types }
  repeat
    if mhline then begin { 1d-scan line, modified huffman coding }
      runlen := 0;
      color := true;
      fillchar(scanlinebuf, sizeof(scanlinebuf), #255); { default white }
      repeat
        run := findrun(color);
        if run > 0 then begin
          if not color then begin
            slbyte := (runlen) div 8;
            slbit := ((runlen) mod 8)+1;
            inc(runlen, run);
            if slbyte + (run+slbit-2) div 8 <= maxlinelen then begin {rangechk}
              for i := 1 to run do begin
                scanlinebuf[slbyte] := scanlinebuf[slbyte] xor base2r[slbit];
                if slbit = 8 then begin
                  inc(slbyte);
                  slbit := 1;
                end else
                  inc(slbit);
              end;
            end;
          end else
            inc(runlen, run);
        end;
        color := not color;
      until(run=-1);
      if (runlen = 1728) or ((runlen > 0) and (displaybad)) then begin
        if runlen <> 1728 then
          inc(badlines);
        ceol := 0;
        inc(lines);
        if gmode < 200 then begin
          if ((lines>maxscanlinerec) or (memavail<sizeof(scanlinerec))) then begin
            dec(lines);
            loadingblock;
            if pagepos[page+1] = 0 then begin { don't add already processed pages }
              write(#7+rp('WARNING: not enough memory to view entire fax page', 79)+#13);
              delay(1000);
              inc(maxpages); { add "fake" extra page so can see all }
            end;
            exit;
          end;
          new(scanlinep^[lines]);
          move(scanlinebuf, scanlinep^[lines]^, sizeof(scanlinebuf));
          if lines = gfx[gmode][1] then
            viewfax(true);
        end else begin
          i := 0; { pcx conversion routines }
          while i <= maxlinelen do begin
            if (i < maxlinelen) and (scanlinebuf[i] = scanlinebuf[i+1]) then begin { RLE encoding }
              if i + 63 > maxlinelen then
                v := maxlinelen - i + 1
              else
                v := 63;
              r := 2;
              while (r < v) and (scanlinebuf[i]=scanlinebuf[i+r]) do
                inc(r);
              putoutbuf(r+192); { 1st 2 bits indicate compression }
              putoutbuf(scanlinebuf[i]);
              inc(i, r);
            end else begin
              if (scanlinebuf[i] and 192) = 192 then begin
                putoutbuf(193); { repetion, one count }
                putoutbuf(scanlinebuf[i]);
              end else
                putoutbuf(scanlinebuf[i]);
              inc(i);
            end;
          end;
        end;
      end else if runlen > 0 then begin
        inc(badlines);
        if (gmode < 200) and (memavail > sizeof(scanlinerec)) then begin
          fillchar(scanlinebuf, sizeof(scanlinebuf), 238);
          inc(lines);
          new(scanlinep^[lines]);
          move(scanlinebuf, scanlinep^[lines]^, sizeof(scanlinebuf));
        end;
      end else begin
        inc(ceol);
        if ceol = 5 then
          endofpage := true; { encountered RTC }
      end;
    end else begin { 2d-line, modified read coding NOT FUNCTIONAL!!! }
      writeln;
      writeln('2d line follows');
      repeat
        k := 0;
        repeat
          bit := readbit;
          k := twodr[k][bit];
        until(twodr[k][2] > -9); { read until hit tree root }
        j := twodr[k][2];
        writeln(j);
        if j = 8999 then
          writeln(#7, 'need MH coding');
      until(j > 9000);
      if j = 9002 then begin { fill }
        while readbit=0 do
          inc(fillbits);
      end;
      writeln('END OF 2D LINE');
      halt;
    end;
    if mrcoding then begin
      if readbit = 1 then { check bit following EOL }
        mhline := true { 1d }
      else
        mhline := false; { 2d }
    end;
  until(endofpage);
  loadingblock;
  exit;
end;

function ucase(s : string) : string;
var
  i : byte;
begin
  for i := 1 to length(s) do
    s[i] := upcase(s[i]);
  ucase := s;
end;

procedure mainloop;
var
  fn : string[79];
  s : string;
  io : word;
  ge : char;
begin
  writeln('VIEW 1.21, BGFAX fax viewer/PCX converter utility.');
  writeln('Copyright (C) 1994 B.J. Guillot.  All Rights Reserved.');
  writeln;
  if paramcount = 0 then begin
    writeln('VIEW filename [/VGA|/EGA|/CGA|/PCX]');
    halt;
  end;
  fn := ucase(paramstr(1));
  if paramcount > 1 then begin
    for io := 2 to paramcount do begin
      s := ucase(paramstr(io));
      if s[1] = '/' then begin
        delete(s, 1, 1);
        if s = 'VGA' then
          gmode := 0
        else if s = 'EGA' then
          gmode := 1
        else if s = 'CGA' then
          gmode := 2
        else if s = 'PCX' then
          gmode := 200
        else if s = 'DB' then
          displaybad := true
        else if s = 'BO' then
          revbitord := true;
      end;
    end;
  end;
  fillchar(sqzary, sizeof(sqzary), #0);
  startclock := dosclock;
  if pos('.', fn) = 0 then
    fn := fn+'.FAX';
  write('Memory [', memavail div 1024, 'K]  File ['+fn+']  ');
  assign(faxfile, fn);
  {$i-}
    reset(faxfile, 1);
    io := ioresult;
    if io > 0 then begin
      writeln('I/O error [', io, ']');
      fatal('cannot open input file');
    end;
  {$i+}
  faxsize := filesize(faxfile);
  writeln('Size [', faxsize div 1024, 'K]');
  writeln;
  if displaybad then
    writeln('Display bad scan line mode.');
  if gmode < 200 then begin
    if memavail < sizeof(scanlinearray) then
      fatal('not enough memory to initialize scanline table');
    new(scanlinep);
  end else begin
    fopen := fn;
    io := pos(':', fopen);
    delete(fopen, 1, io);
    repeat
      io := pos('\', fopen);
      if io > 0 then
        delete(fopen, 1, io);
    until(io=0);
    io := pos('.', fopen);
    if io > 0 then
      delete(fopen, io, length(fopen)-io+1);
    ofn := fopen;
    writeln('FAX -> PCX conversion mode.');
    writeln;
    if memavail < sizeof(outbuf) then
      fatal('not enough memory to initialize output buffer');
    new(outbuf);
  end;
  page := 1;
  blockread(faxfile, faxbuf, sizeof(zfax), bytesread);
  move(faxbuf, zfax, sizeof(zfax));
  if zfax.header <> 'ZyXEL' then begin
    reset(faxfile, 1);
    blockread(faxfile, faxbuf, sizeof(qfax), bytesread);
    move(faxbuf, qfax, sizeof(qfax));
    if qfax.header <> 'QLIIFAX ' then begin
      writeln('Cannot identify fax format, assuming Binkley raw fax page...');
      maxpages := 1;
      faxpos := -1;
      reset(faxfile, 1);
    end else begin
      maxpages := qfax.pgcount;
      faxpos := sizeof(qfax);
    end;
  end else begin
    maxpages := zfax.pgcount;
    faxpos := sizeof(zfax);
  end;
  fillchar(pagepos, sizeof(pagepos), #0);
  pagepos[page] := faxpos+1;
  repeat
    shownpage := false;
    decodeblock;
    ge := viewfax(false);
    if pagepos[page+1] = 0 then
      pagepos[page+1] := faxpos;
    if gmode < 200 then begin
      for io := 1 to lines+padlines do
        dispose(scanlinep^[io]);
    end;
    if ge = #81 then begin {pgdn}
      if page = maxpages then begin
        if shownpage then
          textmode(3);
        close(faxfile);
        writeln('No more pages.');
        halt;
      end;
      inc(page);
    end else if ge = #73 then begin {pgup}
      if page = 1 then begin
        if shownpage then
          textmode(3);
        close(faxfile);
        writeln('That was the first page.');
        halt;
      end;
      dec(page);
    end;
    seek(faxfile, pagepos[page]);
    faxpos := pagepos[page];
  until(ge=#0);
  textmode(3);
  close(faxfile);
end;

begin
  clrscr;
  mainloop;
end.