program prel;

{ written by Clarence Wilkerson, 1985. all rights reserved}
{ a variation of the Heath PREL utility for CP/M-80 }
{ from files name.hx0 and name.hx1 }
{ produces   name.bin and name.bit}
{ where name.bin is name.hx0 converted to binary}
{ and name.bit is a bitmap computed from }
{ name.hx0 and name.hx1}

const
  power2 : array[0..7] of byte = (1,2,4,8,16,32,64,128);
  biter = '.BIT';
  biner = '.BIN';
  hexdigit : array[0..15] of char = ( '0','1','2','3','4','5','6','7','8','9',
    'A','B','C','D','E','F');
  PREHEADER = 255; { length of headerfile-1 for .PRE format }
  MAXBINARY = $3400; { for cp/m 80, handle 12k binary, so 13.5 k in all
     max size to handle. Make smaller for CP/M-80 }
  MAXBIT    = $600;  { 1/9 th size of MAXBINARY, to store bitmap }
  sysheader : array[0..127] of byte =
     (* header from Heath BIOS SYS file at org + $80  *)
     ( $F3,$31,$00,$02,$2A,$01,$00,$22,$DA,$02,$7C,$32,$C4,$02,$EB,$2A,
     $01,$02,$44,$4D,$E5,$21,$00,$03,$3E,$81,$C6,$80,$E2,$A4,$02,$ED,
     $B0,$C3,$AE,$02,$7E,$12,$13,$23,$0B,$78,$B1,$C2,$A4,$02,$C1,$21,
     $00,$03,$09,$EB,$2A,$DA,$02,$EB,$E5,$66,$2E,$08,$7C,$17,$67,$D2,
     $C6,$02,$1A,$C6,$00,$12,$13,$0B,$78,$B1,$CA,$D6,$02,$2D,$C2,$BC,
     $02,$E1,$23,$C3,$B8,$02,$2A,$DA,$02,$E9,$23,$E5,$00,$00,$00,$00,
     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 );

type
  nstring = string[128];
  anystring = string[255];
  hxbuffer = array[0..MAXBINARY] of byte;
  hxptr = ^hxbuffer;
  hextext = text;
  bitbuf  = array[0..MAXBIT] of byte;

var
  hx0,hx1 : hxptr;
  hex0file,hex1file : text;
  binout, bitout : file;
  root : nstring;
  initabort : boolean;
  bitmap : bitbuf;
  count1,count0, count : integer;
  kk : integer;
  makepre: boolean;
  makesys: boolean;
  startorg,startorg0 : real;
  headerbuf : array[0..PREHEADER] of byte;

procedure putnibble( x : integer);
var c : char;
begin
  x:=x and $f;
  c:=hexdigit[x];
  write(c);
end; { putnibble }

procedure putbyte( x : integer);
begin
  x:=x and $ff;
  putnibble( (x and $f0) shr 4);
  putnibble( x and  $0f);
end; { putbyte }

procedure putword( x : integer );
begin
   putbyte(hi(x));
   putbyte(lo(x));
end; { putword }

procedure putrealhex( x: real);
begin
  repeat
    if x >= 65536.0 then x:=x-65536.0;
  until x < 65536.0;
  if x >= 32768.0 then x:=(x- 65536.0);
  putword( trunc(x));
end; {putrealhex}


function max(x,y : integer) : integer;
begin
 if x >= y then max:=x else max:=y;
end;  { max }


procedure manual;
begin
  writeln;
  writeln;
  writeln('Usage: ');
  writeln;
  writeln('     A>prel name  [-p] ');
  writeln;
  writeln('processes NAME.HX0, NAME.HX1 to produce');
  writeln('bitmap file NAME.BIT and binary file NAME.BIN');
  writeln('-p option produces a .PRE file with header.');
  writeln('-s option produces a .BIO file with BIOS-type header.');

end; { manual }

function file_exists( s : nstring) : boolean;
var myioresult : integer;
    f : FILE;
begin
   file_exists:=false;
   assign(f,s);
   {$I-}
   reset(f);myioresult:=ioresult;
   close(f);
   {$I+}
   file_exists:=(myioresult=0);
end; { file exists }

procedure initialize;
var chop : integer;
    option : nstring;
begin
 initabort:=false;
 makesys:=false;
 makepre:=false;
 if paramcount=0 then begin
    manual;
    initabort:=true;
    exit;
 end;
 root:=paramstr(1);
 if paramcount> 1 then option:=paramstr(2);
 option:=copy(option,1,2);
 if option[1]='-' then begin
    makepre:=false;
    makesys:=false;
 end else
   case upcase(option[2]) of
     'P' : begin
             makesys:=false;
             makepre:=true;
             fillchar(sysheader,$80,0);
           end;
     'S' : begin
             makesys:=true;
             makepre:=true;
           end;
   end; { case}
 if root= '?' then  begin
    manual;
    initabort:=true;
    exit;
 end;
 chop:=pos('.',root);
 if chop <> 0 then root:=copy(root,1,chop-1);
 if not file_exists(root+'.HX0') then begin
    writeln;
    writeln('Can''t find file ',root+'.HX0');
    initabort:=true;
    exit;
 end else writeln('HX0 file exists');
 if not file_exists(root+'.HX1') then begin
    writeln;
    writeln('Can''t find file ',root+'.HX1');
    initabort:=true;
    exit;
 end else writeln('HX1 file exists.');
 new(hx0); { get buffer for hex file 0 }
 new(hx1);
 fillchar(hx0^,MAXBINARY,0);
 fillchar(hx1^,MAXBINARY,0);
 fillchar(bitmap,MAXBIT+1,$00);

 assign(hex0file,root+'.hx0'); reset(hex0file);
 assign(hex1file,root+'.hx1'); reset(hex1file);
end; { initialize }

function hex ( c : char ) : byte;
begin
  c:=upcase(c);
  if c in ['A'.. 'F'] then hex:= ord(c) - 55
  else if c in ['0'..'9'] then hex:= ord(c) -48
  else hex:=0;
end; { hex }

FUNCTION getbyte( s : anystring ; wh : integer) : byte;
begin
  getbyte:= ( hex(s[wh]) shl 4) or hex(s[wh+1]);
end;

function getword ( var s : anystring; wh : integer) : integer;
begin
  getword:=(getbyte(s,wh) shl 8) or getbyte(s,wh+2);
end;

procedure gethex( var f : hextext; p : hxptr; var count : integer);
label 999;
var len,ii,jj,origin : integer;
    s : anystring;
    bbuf : array[0..127] of byte;
    firstline: boolean;
    rorigin,oldorigin: real;
begin

    firstline:=true;
    count:=0;
    while not eof(f) do begin
     readln(f,s);
     jj:=pos(':',s);
     if jj > 0 then begin
       len:= getbyte(s,2);
       if len = 0 then goto 999; { end of hex records is :0000000 }
       origin:= getword(s,4);
       rorigin:= hi(origin)*256.0 + lo(origin);
       if firstline then begin
          firstline:=false;
          startorg:=rorigin;
          oldorigin:=rorigin;
       end;
       if rorigin < oldorigin then begin
           write(#7,'Warning. Hex file not monotonic at ');
           putword(count);writeln('H.');
       end;
       oldorigin:=rorigin;
       rorigin:=rorigin - startorg;
       if rorigin > 32737.0 then begin
          writeln;
          writeln('Error. Size Overflow.');
       end;
       if rorigin < 0.0 then begin
         writeln;
         writeln('Error. Hex file not monotonic.');
         writeln('Reading aborted.');
         exit;
       end;
       origin:= trunc(rorigin);
       count:=max(count,origin + len);
       fillchar(bbuf,128,0);
       for ii:= 0 to (len-1)  do begin
           jj:=(ii shl 1) + 10;
           bbuf[ii]:= getbyte(s,jj);
       end;
       move(bbuf[0], p^[origin],len);
       if count < 0 then begin count:=MAXBINARY; exit;end;
     end; { if : }
   end; { while }
   999:
end; { gethex }

procedure makebit( hx0,hx1 : hxptr; count : integer);
var i,j : integer;
    flag,sum :  integer;
    x,y : byte;
begin
 sum:=0;
 if (count mod 8) <> 0 then count:= ((count + 8) shr 3) shl 3 ;
 for i:=0 to (count -1)  do begin
     x:=hx0^[i];
     y:=hx1^[i];
     if x=y then flag:=0 else begin
          flag:=1;
        (*   write('.');  *)
     end;
     sum:=( sum shl 1) or flag;
     if (i mod 8) = 7 then begin
        j:= i shr 3;
        bitmap[j]:=sum;
        sum:=0;
     end;
 end; { for }
 writeln;
end; { makebit }

procedure dofile0;
begin
   write('Reading ',root+'.HX0 file...');
   gethex(hex0file,hx0, count0); { read them in }
   close(hex0file);
   writeln(count0:6,' binary bytes.');
end;

procedure dofile1;
begin
   write('Reading ',root+'.HX1 file...');
   gethex(hex1file,hx1, count1);
   close(hex1file);
   writeln(count1:6,' binary bytes.');
end;

procedure dobinary;
var kk,hxcount : integer;
begin
 if not makepre then begin
   assign(binout,root+biner);
   rewrite(binout);
   writeln('Writing ',root+'.BIN file.');
   hxcount:=count shr 7;
   blockwrite(binout,hx0^[0],hxcount+1);
   close(binout);
 end;
end; { do binary }

procedure dobitmap;
var kk : integer;
begin
   writeln('Computing bitmap for ',count:6,' bytes.');
   makebit(hx0,hx1,count);
 if not makepre then begin
   writeln('Writing ',root+'.BIT file.');
   assign(bitout,root+biter);
   rewrite(bitout);
   blockwrite(bitout,bitmap[0], (((count shr 3) +1) shr 7) +1);
   close(bitout);
 end;
end; { dobitmap }

procedure domakepre;
var hxcount,kk,poffset : integer;
    x,y,xbyte,ybyte : byte;
    zorg : real;
begin
  if makesys then assign(binout,root+'.BIO')
            else assign(binout,root+'.PRE');
  rewrite(binout);
  fillchar(headerbuf[0],PREHEADER + 1, 0);
  move(sysheader[0],headerbuf[$80],$80);
  if  ((not makesys) and makepre) then
      write('Writing ',root+'.PRE file. Old origin was ')
  else if makepre then
      write('Writing ',root+'.BIO file. Old origin was ');
  putrealhex(startorg0); writeln('H');
  write('What is offset in 256 byte pages?  ');
  readln(poffset);
  xbyte:=lo(count);
  zorg:=startorg0 +(lo(poffset)*256.0);
  write('New origin is '); putrealhex(zorg); writeln('H');
  ybyte:=hi(count);
  headerbuf[1]:=lo(count);  { 8080 order }
  headerbuf[2]:=hi(count);
  blockwrite(binout,headerbuf[0],(preheader+1) shr 7);
  for kk:=0 to count-1 do begin
       x:=hx0^[kk];
       y:=hx1^[kk];
        if x <> y then hx0^[kk]:=(x +lo(poffset)) and $ff;
  end;
  for kk:=0 to (count shr 3) do hx0^[count+kk]:=bitmap[kk];
  blockwrite(binout,hx0^[0],(( count +(count shr 3)) shr 7) +1);
  close(binout);
end; { makeprel }

procedure summary;
begin
if not makepre then begin
   writeln('Finished.'
   writeln('Wrote ',count:0,' bytes to ',root+'.BIN');
   writeln('And ',((count shr 3)+1):0,' bytes to ',root + '.BIT');
end;
end; { summary }

begin { main}
   makepre:=false;
   makesys:=false;
   initialize;
if not initabort then begin
   dofile0;
   startorg0:=startorg;
   dofile1;
   count:=max(count0,count1);
   dobinary;
   dobitmap;
   if makepre then
        domakepre;
   summary;
 end;
end. { PREL }