{ Copy disks for production }

{ (C) Copyright 1983-84 Peter Norton }

{ 06/06/84 - revised in a minor way for free distribution }

{ 10/28/83 - changed to report i/o errors }

{ 10/25/83 - changed 1) remove verify
                     2) use chrget     }

{$debug-,$ocode-,$line-}

program fcopy (output,input);

var [static]
  try_count: word;
  ret_word : word;
  err_code : byte;
  inline   : lstring (100);
  base     : ads of array [wrd(0)..4095] of byte;
  store    : ads of array [wrd(0)..4095] of byte;
  drive    : word;
  track    : word;
  inchr    : word;
  done     : boolean;
  
value
  done     := false;

procedure endxqq;
  external;

procedure chrget (var x: word);
  external;
  
procedure ifchr  (var x: word);
  external;
  
{  These four routines return true if errors  }
            
function readt (drive,track,seg,off : word) : word;
  external;

function writt (drive,track,seg,off : word) : word;
  external;

function formt (drive,track,seg,off : word) : word;
  external;

function verit (drive,track,seg,off : word) : word;
  external;
  
  {---}

function readx (drive,track,seg,off : word) : boolean;
  begin
    for try_count := 1 to 3 do
      begin
        ret_word := readt (drive,track,seg,off);
        err_code := ret_word div 256;
        if ret_word = 0 then
          begin
            readx := false;
            return;
          end
        else
          readx := true;
      end;
  end;

function writx (drive,track,seg,off : word) : boolean;
  begin
    for try_count := 1 to 3 do
      begin
        ret_word := writt (drive,track,seg,off);
        err_code := ret_word div 256;
        if ret_word = 0 then
          begin
            writx := false;
            return;
          end
        else
          writx := true;
      end;
  end;

function formx (drive,track,seg,off : word) : boolean;
  begin
    for try_count := 1 to 3 do
      begin
        ret_word := formt (drive,track,seg,off);
        err_code := ret_word div 256;
        if ret_word = 0 then
          begin
            formx := false;
            return;
          end
        else
          formx := true;
      end;
  end;

function verix (drive,track,seg,off : word) : boolean;
  begin
    for try_count := 1 to 3 do
      begin
        ret_word := verit (drive,track,seg,off);
        err_code := ret_word div 256;
        if ret_word = 0 then
          begin
            verix := false;
            return;
          end
        else
          verix := true;
      end;
  end;
  
procedure initialize;
  var [static]
    i,j : word;
  begin
    
    { set up the format control information }
    
    store.s := 6141;
    store.r := 0;
    
    store ^ [ 0 + 0] := 0; { track number }
    store ^ [ 0 + 1] := 0; { head number  }
    store ^ [ 0 + 2] := 1; { record number }
    store ^ [ 0 + 3] := 2; { size code for 512 }
    
    store ^ [ 4 + 0] := 0; { track number }
    store ^ [ 4 + 1] := 0; { head number  }
    store ^ [ 4 + 2] := 2; { record number }
    store ^ [ 4 + 3] := 2; { size code for 512 }
    
    store ^ [ 8 + 0] := 0; { track number }
    store ^ [ 8 + 1] := 0; { head number  }
    store ^ [ 8 + 2] := 3; { record number }
    store ^ [ 8 + 3] := 2; { size code for 512 }
    
    store ^ [12 + 0] := 0; { track number }
    store ^ [12 + 1] := 0; { head number  }
    store ^ [12 + 2] := 4; { record number }
    store ^ [12 + 3] := 2; { size code for 512 }
    
    store ^ [16 + 0] := 0; { track number }
    store ^ [16 + 1] := 0; { head number  }
    store ^ [16 + 2] := 5; { record number }
    store ^ [16 + 3] := 2; { size code for 512 }
    
    store ^ [20 + 0] := 0; { track number }
    store ^ [20 + 1] := 0; { head number  }
    store ^ [20 + 2] := 6; { record number }
    store ^ [20 + 3] := 2; { size code for 512 }
    
    store ^ [24 + 0] := 0; { track number }
    store ^ [24 + 1] := 0; { head number  }
    store ^ [24 + 2] := 7; { record number }
    store ^ [24 + 3] := 2; { size code for 512 }
    
    store ^ [28 + 0] := 0; { track number }
    store ^ [28 + 1] := 0; { head number  }
    store ^ [28 + 2] := 8; { record number }
    store ^ [28 + 3] := 2; { size code for 512 }
    
    for i := 1 to 25 do
      writeln;

    base.s := 6144;  { puts storage at the end of 256 K }
    base.r := 0;
    store  := base;
    
  end;

procedure read_disk;
  var [static]
    ii : word;
    sowhat : boolean;
  begin
    drive := 0;
    writeln;
    writeln;
    writeln ('Insert the disk to be copied in drive A, and press ANY KEY...');
    chrget (inchr);
    store := base;
    
    { start up drive }
    for ii := 1 to 5 do
      if not readx (drive,0,wrd (store.s),wrd (store.r)) then
        break;
          
    for track := 0 to 39 do
      begin
        store.s := base.s + 256 * track;
        write ('Reading track ',track:2);
        ii := 0;
        while readx (drive,track,wrd (store.s),wrd (store.r)) do
          begin
            ii := ii + 1;
            if ii > 5 then
              begin
                writeln;
                writeln ('Error reading track ',track:3);
                writeln;
                write (chr (7));
                endxqq;
              end;
          end;
        write (chr (13));
      end;
    writeln;
    writeln;
    writeln ('Press the ESC key to pause after any disk.');
    writeln;
    writeln;
  end;
    
procedure copy_disk;
  var
    i : word;
  label
    re_format;
    
  begin
    writeln;
    write ('Insert diskette in drive ');
    if drive = 0 then
      begin
        drive := 1;
        write ('B');
      end
    else
      begin
        drive := 0;
        write ('A');
      end;
    writeln;
    for track := 0 to 39 do
      begin
    
        store.s := 6141;
    
        for i := 0 to 7 do
          store ^ [i*4] := track;
    
        write (chr (13),track:2,' formatting');
re_format:
        if formx (drive,track,wrd (store.s),wrd (store.r)) then
          begin
            if track = 0 then
              goto re_format;
            writeln ('     E R R O R !  ',err_code);
            writeln;
            write (chr (7));
            write (chr (7));
            return;
          end;
      
        store.s := base.s + 256 * track;
    
        write (chr (13),track:2,' writing   ');
        if writx (drive,track,wrd (store.s),wrd (store.r)) then
          begin
            writeln ('     E R R O R !  ',err_code);
            writeln;
            write (chr (7));
            write (chr (7));
            return;
          end;
  
      end; 

    write (chr(7));
    writeln;
  end;
    
procedure check_pause;
  begin
    ifchr (inchr);
    inchr := inchr mod 256;
    if inchr = 0 then
      return;
    if inchr <> 27 then
      begin
        writeln;
        writeln ('Use the ESC key to pause after the end of a disk');
        writeln;
        return;
      end;
    write (chr(7));
    writeln;
    write   ('Press E to end, or any other key to continue...');
    chrget (inchr);
    inchr := inchr mod 256;
    writeln;
    if (inchr = 69) or (inchr = 101) then
      done := true;
    return;
  end;
    
begin
  initialize;
  read_disk;
  repeat
    copy_disk;
    check_pause;
  until done;
end.