program format96;
{$R+}
{$U+}
const
    getintrp = $35;     { dos 21 int functions }
    setintrp = $25;

    disktable = $1E;       { disk parameter block has address stored here }
    equipment = $11;

    diskio = $13;       { does the dirty work }
    diskformat = $5;
    diskverify = $4;
    diskwrite  = $3;    { write up to 9 sectors per track }


    MAXsector = 40; { max sector number on a track }
    driveflag = $00c1 ;
type
   result = record
            ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
            end;

   sectorheader = record
               track : byte;
               side : byte;
               sectornum : byte;
               sectorlen : byte;
            end;
var
    diskparm : result;
    i,sectorpertrack,ah,dh,sectorsize: integer;
    headerbuf : array[1..MAXsector] of sectorheader;
    c : char;
    drivenum, numtraks : integer;
    go_ahead : boolean;
    starttrack, finishtrack : integer;
    sectorbuf : array[0..512] of byte;
    FATDIR : array[0..$17ff] of byte;

procedure makeFAT; { fill in the bpb, FATS, DIR }
var i,j : integer;
    manu : string[20];
    jmpstr: string[5];
    bpb: string[30];
    sec0 : string[35];
    banner : string[128];
    code : string[40];
begin
     fillchar(FATDIR,$1800,$F6);
     for i:= 0 to $17ff do
          if (i mod 32) = 0 then fatdir[i]:=0;
          { put in zeros in every 32 bytes }
     fatdir[$200]:=$fd;
     fatdir[$201]:=$ff;
     fatdir[$202]:=$ff;
     fatdir[$600]:=$fd;
     fatdir[$601]:=$ff;
     fatdir[$602]:=$ff;
     for i:=$203 to $41A do fatdir[i]:=0;
     for i:=$603 to $81A do fatdir[i]:=0;
   { fats and directory done, now do BPB }
     jmpstr:=#$eb#$20#$90;
     manu:='WILKER31';
     BPB:=#00#02#04#01#00#02#$70#00#$a0#05#$ED#$02#$00#$09#00#02#00#00#00#06#00;
     sec0:= jmpstr+manu+bpb;
     for i:=0 to (length(sec0)-1) do fatdir[i]:=ord(sec0[i+1]);
end; { make fat }


procedure smoothexit;
begin
end; { smoothexit }

function getdrives : integer;
var x : result;
    y : integer;
begin
  { returns number of floppy drives }
  intr(equipment,x);

   y:=x.ax and ($00c1);

   {0000 0000 1100 0001}
   { stupid ibm scheme, bit 0 = 0 => no drives }
   { bit 0 = 1 => bits 6,7 give number -1 }


 if y = 0 then getdrives:=0 else
  begin
     y:=y shr 6;
     y:=y and 3;
     getdrives:=y+1;
  end;
getdrives:=4;
end; { getdrives }


procedure errormsg( x : byte);
begin
   writeln;
   case x of
      0   : writeln('No error.');
      1   : writeln('Bad command.');
      2   : writeln('Bad address mark.');
      3   : writeln('Write-protected disk.');
      4   : writeln('Record not found.');
      5   : writeln('Controller reset failed.');
      7   : writeln('Controller won''t accept drive parameters.');
      8   : writeln('DMA overrun.');
      9   : writeln('DMA bounds error.');
      $0b : writeln('Bad track flag found.');
      $10 : writeln('Bad CRC on disk read.');
      $11 : writeln('Recoverable ECC error.');
      $20 : writeln('Disk controller chip failure.');
      $40 : writeln('Bad seek.');
      $80 : writeln('Time out error.');
      $BB : writeln('Undefined error.');
      $ff : writeln('Sense Drive Status failure.');
    end;
    writeln;
 end; { error msg }


procedure getformparams;
var valid : boolean;
    ch : char;
    code : integer;
    trackstr : string[20];
    lastdrive : integer;
begin
    repeat
         lastdrive:=getdrives;
         writeln('Last drive is number ',lastdrive);
         write('Drive to use ( C..',chr(ord('A')+getdrives-1),')? ');
         readln(ch); ch:=upcase(ch);
         if ch in ['Z','Q','X',^Z] then smoothexit;
    until ch in ['A'..chr(64+getdrives)];

   drivenum:=ord(ch) -ord('A');
   if drivenum >( getdrives -1) then begin
       writeln('Warning..drive selected is not set on switch SW-1.');
   end;
   if drivenum < 2 then begin
       writeln('Warning..drive selected is probably a 48 TPI drive.');
   end;

   sectorpertrack:=9;
   { al }
   sectorsize:=2;
   { sectorsize }
    starttrack:=0;
    finishtrack:=79;
end; { getformparams }


procedure checkexit;
var ch : char;
begin
   if keypressed then begin
     read(kbd,ch);
     if upcase(ch) in ['Q','X','Z',^Z] then smoothexit;
    end;
end; { check exit }

procedure initsector;
var j : integer;
begin
     { initialize sector header array }
     for j:=1 to MAXsector  do begin
         headerbuf[j].sectornum:=lo(j);
         headerbuf[j].sectorlen:=lo(sectorsize);
      end; { j }
end; { init sector }

procedure initbuf( x : byte);
var i : integer;
begin
  for i:=0 to 511 do sectorbuf[i]:= x;
end; { initbuf }


procedure initside( side : integer);
var j : integer;
begin
   for j:=1 to  MAXsector do
       headerbuf[j].side:=lo(side);
end; { initside }

procedure inittrack( track : integer);
var j : integer;
 begin
  for j:=1 to MAXsector do
      headerbuf[j].track:=track;
 end; { inittrack }

procedure doit; { formatting call }
var tracknum,side : integer;
begin
with diskparm do begin
   initsector; { fill in the header }
   for tracknum:=starttrack to finishtrack do begin
      inittrack(tracknum);
      write('*');
      for side:= 0 to 1 do begin
          initside(side);
          { allow abort }
          if keypressed then begin
              read(c);
              if upcase(c) in ['Q','X','Z',^Z] then smoothexit;
          end;
          dx:=drivenum + (side shl 8);  { dh =0 means side 0 }
          ax:=sectorpertrack + (diskformat shl 8);
          cx:= 1 + (tracknum shl 8);
          es:=seg(headerbuf[1].track);
          bx:=ofs(headerbuf[1].track);
          intr($13,diskparm);
          if hi(ax) <> 0 then errormsg(hi(ax));
       end; { tracknum }
    end; { side }
  end; { with diskparm }
end; { doit }


procedure verify;
var tracknum,side : integer;
begin
 with diskparm do begin
   writeln;
   writeln;
   writeln('This reads each sector to verify the format.');
   writeln;
   writeln;
   initsector; { fill in the header }
   for tracknum:=starttrack  to finishtrack do begin
      inittrack(tracknum);
      write('*');
      for side:= 0 to 1 do begin
          initside(side);
          { allow abort }
          if keypressed then begin
              read(kbd,c);
              if upcase(c) in ['Q','X','Z',^Z] then smoothexit;
          end;
          dx:=drivenum + (side shl 8);  { dh =0 means side 0 }
          ax:=sectorpertrack + (diskverify shl 8);
          cx:= 1 + (tracknum shl 8);
          es:=seg(headerbuf[1].track);
          bx:=ofs(headerbuf[1].track);
          intr($13,diskparm); { not needed }
          if hi(ax) <> 0 then errormsg(hi(ax));
       end; { tracknum }
    end; { side }
   end; { with diskparm }
end; { verify }

procedure insertdisk;
begin
  writeln;
  writeln(' Insert diskette in drive ',chr(65+drivenum),': ');
    write(' Press <CR> when ready.');
  readln;
  writeln;
  writeln;
end; { insertdisk }


procedure writefat;
var tracknum,side : integer;
begin
 writeln;writeln('Writing system information.');writeln;
 with diskparm do begin

    tracknum:=0;
    side:=0;
    dx:=drivenum + (side shl 8);  { dh =0 means side 0 }
    ax:=9 + (diskwrite shl 8);
    cx:=1 + (tracknum shl 8);
    es:=seg(fatdir[0]);
    bx:=ofs(fatdir[0]);
    intr($13,diskparm);
    if hi(ax) <> 0 then errormsg(hi(ax));

    side:=1;
    dx:=drivenum + (side shl 8);  { dh =0 means side 0 }
    ax:=3 + (diskwrite shl 8);
    cx:= 1 + (tracknum shl 8);
    es:=seg(fatdir[9*512]);
    bx:=ofs(fatdir[9*512]);
    intr($13,diskparm);
    if hi(ax) <> 0 then errormsg(hi(ax));
    
 end; { with diskparm }
end;  { writefat }




function menu : char;
var  valid : boolean;
     c : char;
begin
    writeln;writeln;
    writeln('The options are  ');
    writeln('   1) Format floppy diskette ( no FAT).');
    writeln('   2) Verify floppy diskette.');
    writeln('   3) Format, verify, and write FAT.');
    writeln('   4) Write FAT table to disk.');
    writeln('   X) Exit this program.');
  repeat
    writeln;writeln;
    write('>>  Your choice..');
    read(kbd,c);writeln(c);writeln;
  until upcase(c) in ['1'..'4','X','Q','Z',^Z];
  menu:=upcase(c);
end; { menu }

procedure logo;
begin
     writeln;writeln;writeln;
     writeln('This formats 80 trk/side DS QD disketts on IBM ');
     writeln('PC compatible computers using the TANDY 2000 format.');
     writeln('A 96 TPI double sided drive in drive C or D is required.');
     writeln;
     writeln('Copyright 9-15-85 by Clarence Wilkerson. All rights reserved.');
     writeln;
     write('Type Q, Z, or X to exit at any prompt.');
     checkexit;writeln;
     writeln;
end; { logo }

begin  { main }
  logo;
  makefat;
 repeat
    c:=menu;
    case c of

      '1' : begin
            getformparams;
            insertdisk;
            doit;
         end;

      '2' : begin
            getformparams;
            insertdisk;
            verify;
         end;

      '3' : begin
            getformparams;
            insertdisk;
            doit;
            writefat; { fill in the directory and FAT tables }
            verify;
            end;
      '4' : begin
            getformparams;
            insertdisk;
            writefat;
            end;

     end; { case }
     until c in [^Z, 'X','Q','Z'];
    smoothexit; { reset disk parameters }
    end.