program diskload (input, output, disk);
type
     tri       = 0..2;
     c10       = packed array [1..10] of char;
     c2        = packed array [1..2] of char;
     diskptr   = packed record
                    track:    char;
                    sector:   char;
                 end;
     c32       = packed array [1..32] of char;
     c8        = packed array [1..8] of char;
     map       = packed array [0..7, 0..7] of boolean;
     fdb       = packed record
                    name:     c10;
                    nrecs:    c2;
                    fmap:     packed array [0..9] of diskptr;
                 end;
     home      = packed record
                    id:       packed array [1..27] of c8;
                    bit:      map;
                    mfd:      fdb;
                 end;
     chunk     = packed record
                    fdata:      c32;
                    mfd:        fdb;
                 end;
      instrform = packed record
                  delay:      0..1023;
                  intrpt:     0..15;
                  ioadr:      0..511;
                  iopc:       0..511;
              end;
     secimage  = packed record
                    data:    packed array [1..8] of chunk;
                    hblock:  home;
                    ins:     packed array [1..64] of instrform;
                 end;
     c4        = packed array [1..4] of char;

var
     bitmap:        map;
     disk:          file of secimage;
     diskimage:     packed array [0..7, 0..7] of secimage;
     rec:           c32;
     homeblock:     home;
     logonid:       c8;
     fid:           c10;
     command:       c4;
     filename:      c32;
     newfdb:        fdb;
     logons:        packed array [1..27] of c8;
     trk,
     sec,
     t, s,
     mfdsec,
     numfiles,
     numids:        integer;
     oldfile,
     again:         boolean;
     i, j:          integer;

procedure logadd;
var
     i:        integer;
     newid:   c8;
begin
     if numids = 26 then
          writeln ('Sorry, no room to add an id')
     else begin
          write ('New logon-id: ');
          newid := '        ';
          i := 1;
          while (i <= 8) and (not eoln) do
          begin
               read (newid[i]);
               if newid[i] >= 'a' then
                  newid[i] := chr (ord (newid[i]) - 32);
               i := i + 1;
          end;
          readln;
          numids := numids + 1;
          logons[numids] := newid;
          diskimage[0,0].hblock.id := logons;
     end;
end;

procedure logdel;
var
     i, j:     integer;
     oldid:    c8;
begin
     oldid := '        ';
     write ('Logon-id to remove: ');
     i := 1;
     while (i <= 8) and (not eoln) do
     begin
          read (oldid[i]);
          if oldid[i] >= 'a' then
              oldid[i] := chr (ord (oldid[i]) - 32);
          i := i + 1;
     end;
     readln;
     i := 1;
     while (i <= numids) and (oldid <> logons[i]) do
          i := i + 1;
     if i > numids then
          writeln (oldid:8, ' is not a known logon-id')
     else begin
          for j := i to numids do
               logons[j] := logons[j+1];
          numids := numids - 1;
          diskimage[0,0].hblock.id := logons;
     end;
end;

procedure logdir;
var
     i:        integer;
begin
     writeln ('Current logon-ids:');
     writeln;
     for i := 1 to numids do
          writeln ('     ', logons[i]);
end;

procedure endproc;
var
     i, j:     integer;
begin
     if oldfile then open (disk, filename, OLD)
     else open (disk, filename, NEW);
     rewrite (disk);
     for i := 0 to 7 do
          for j := 0 to 7 do
               write (disk, diskimage[i,j]);
     close (disk);
     again := false;
end;

procedure dirproc;
var
     i, j:     integer;
     msec,
     trk,
     sec:      integer;
     descr:    chunk;
begin
     if numfiles = 0 then
          writeln ('Currently, there are no files.')
     else begin
          writeln ('Name      No. Records');
          msec := 0;
          i := 0;
          while i < numfiles do
          begin
               trk := ord(diskimage[0,0].hblock.mfd.fmap[msec].track) - 48;
               sec := ord(diskimage[0,0].hblock.mfd.fmap[msec].sector) - 48;
               j := 1;
               while (j <= 8) and (i < numfiles) do
               begin
                    descr := diskimage[trk,sec].data[j];
                    writeln (descr.mfd.name, '      ', descr.mfd.nrecs);
                    j := j + 1;
                    i := i + 1;
               end;
               msec := msec + 1;
          end;
     end;
end;

procedure bitproc;
var
      i, j:   integer;
begin
      writeln ('            Disk BITMAP');
      writeln ('Trk    |          Sectors');
      writeln ('Num.   |   0   1   2   3   4   5   6   7');
      for i := 0 to 7 do
      begin
          write (i:3, '    |');
          for j := 0 to 7 do
              if bitmap[i,j] then write (1:4)
                             else write (0:4);
          writeln;
      end;
end; 

procedure getblock (var trk, sec: integer);
var
     found,
     done:    boolean;
begin
     trk := 0;
     sec := 1;
     found := false;
     while bitmap[trk,sec] and (not found) do
     if trk < 7 then
     begin
          done := false;
          while bitmap[trk,sec] and (not done) do
               if sec < 7 then sec := sec + 1
               else done := true;
          if done then
          begin
               sec := 0;
               trk := trk + 1;
          end
          else found := true;
     end
     else found := true;
     if bitmap[trk,sec] then writeln ('No disk space left.')
     else bitmap[trk,sec] := true;
end;

procedure incrfiles (incr: integer);
begin
      numfiles := numfiles + incr;
      diskimage[0,0].hblock.mfd.nrecs[1] := chr (numfiles div 10 + 48);
      diskimage[0,0].hblock.mfd.nrecs[2] := chr (numfiles mod 10 + 48);
end;

procedure putit (newfdb: fdb);
var
      rec,
      trk,
      tor,
      sec:        integer;
begin
      sec := numfiles div 8;
      if numfiles mod 8 <> 0 then
      begin
          rec := numfiles mod 8 + 1;
          trk := ord (diskimage[0,0].hblock.mfd.fmap[sec].track) - 48;
          tor := ord (diskimage[0,0].hblock.mfd.fmap[sec].sector) - 48;
          diskimage[trk,tor].data[rec].mfd := newfdb;
      end
      else begin
          getblock(trk, tor);
          diskimage[0,0].hblock.mfd.fmap[sec].track := chr (trk + 48);
          diskimage[0,0].hblock.mfd.fmap[sec].sector := chr (tor + 48);
          diskimage[trk,tor].data[1].mfd := newfdb;
      end;
      incrfiles(1);
end;

procedure random (var seed: integer; var r: real);
begin
      seed := 69069 * seed + 1;
      r := abs(seed);
      while r > 1.0 do
          r := r / 2;
end;

procedure addproc;
var
     i, j:     integer;
     arec:     chunk;
     fidtype:  char;
     left:     char;
     right:    char;
     trk,
     sec,
     rno,
     sno,
     numrec:   integer;
     inreq,
     outreq,
     totreq,
     delay:    integer;
     exterm:   char;
     pgm:      packed array [0..99] of instrform;

procedure dorequests;
var
      i, j:       integer;
      bufcount,
      r,
      left,
      rdelay:     real;
      mindelay,
      psize,
      pit,
      seed,
      pc,
      base:       integer;
      pitype:     array [0..99] of integer;
begin
      for i := 0 to inreq - 1 do
          pitype[i] := 7;
      for i := inreq to totreq - 1 do
          pitype[i] := 8;
      psize := (totreq + 1) * 4 + 32;
      base := psize + 5;
      bufcount := (512 - base) div 32;
      mindelay := delay div 6;
      if mindelay = 0 then mindelay := 1;
      rdelay := delay - mindelay;
      seed := clock;
      pc := 0;
      for i := 0 to totreq - 1 do
      begin
          random (seed, r);
          pgm[i].ioadr := base + trunc(r * bufcount) * 32;
          random (seed, r);
          pgm[i].delay := trunc (r * rdelay) + mindelay;
          random (seed, r);
          left := totreq - i - 1;
          j := trunc (r * left);
          pgm[i].intrpt := pitype[j];
          pit := pitype[j];
          pitype[j] := pitype[trunc(left)];
          pitype[trunc(left)] := pit;
          random (seed, r);
          pc := pc + trunc(r * 30.0) + 1;
          if pc > psize then pc := 20;
          pgm[i].iopc := pc;
      end;
      pgm[totreq].delay := 24;
      if (exterm = 'A') or (exterm = 'a') then pgm[totreq].intrpt := 11
          else pgm[totreq].intrpt := 10;
      pgm[totreq].iopc := 1;
      pgm[totreq].ioadr := 0;
end;

procedure finishit;
var
      rp, bp:     integer;
begin
      if totreq >= 56 then
      begin
          totreq := totreq - 56;
          rp := (totreq + 1) div 8 + 1;
      end
      else  rp := (totreq + 1) div 8 + 2;
      bp := ((totreq + 1) mod 8) * 4;
      diskimage[trk,sec].data[rp].fdata[bp+1] := 'R';
      diskimage[trk,sec].data[rp].fdata[bp+2] := 'U';
      diskimage[trk,sec].data[rp].fdata[bp+3] := 'N';
      diskimage[trk,sec].data[rp].fdata[bp+4] := '*';
end;

begin
     newfdb.name := '          ';
     write ('New file name: ');
     i := 1;
     while (i <= 10) and (not eoln) do
     begin
          read (newfdb.name[i]);
          if newfdb.name[i] >= 'a' then 
              newfdb.name[i] := chr (ord (newfdb.name[i]) - 32);
          i := i + 1;
     end;
     readln;
     for i := 0 to 9 do
     begin
          newfdb.fmap[i].track := '9';
          newfdb.fmap[i].sector := '9';
     end;
     write ('D (data) file or E (executable) file: ');
     readln (fidtype);
     if (fidtype = 'D') or (fidtype = 'd') then
     begin
          write ('Number of data records: ');
          readln (numrec);
          newfdb.nrecs[1] := chr(numrec div 10 + 48);
          newfdb.nrecs[2] := chr(numrec mod 10 + 48);
          arec.fdata := '* DATA *                * DATA *';
          for i := 1 to 10 do
               arec.fdata[i+11] := newfdb.name[i];
          rno := 1;
          sno := 0;
          repeat
               getblock (trk, sec);
               j := 1;
               while (j <= 8) and (rno <= numrec) do
               begin
                    left := chr (rno div 10 + 48);
                    right := chr (rno mod 10 + 48);
                    arec.fdata[10] := left;
                    arec.fdata[11] := right;
                    arec.fdata[22] := left;
                    arec.fdata[23] := right;
                    diskimage[trk,sec].data[j].fdata := arec.fdata;
                    rno := rno + 1;
                    j := j + 1;
               end;
               newfdb.fmap[sno].track := chr (trk + 48);
               newfdb.fmap[sno].sector := chr (sec + 48);
               sno := sno + 1;
          until rno > numrec;
     end
     else begin
          arec.fdata := '* RUN *                  * RUN *';
          write ('Expected termination, A (abort) or E (exit): ');
          readln (exterm);
          write ('No. input requests: ');
          readln (inreq);
          write ('No. output requests: ');
          readln (outreq);
          totreq := inreq + outreq;
          if totreq = 55 then writeln ('WARNING:  total requests are 55');
          write ('Maximum delay between requests (<1000): ');
          readln (delay);
          j := (totreq + 1) div 8 + 1;
          if totreq mod 8 <> 0 then j := j + 1;
          newfdb.nrecs[1] := chr (j div 10 + 48);
          newfdb.nrecs[2] := chr (j mod 10 + 48);
          for i := 1 to 10 do
              arec.fdata[i+11] := newfdb.name[i];
          arec.fdata[10] := chr (outreq div 10 + 48);
          arec.fdata[11] := chr (outreq mod 10 + 48);
          arec.fdata[22] := chr (inreq div 10 + 48);
          arec.fdata[23] := chr (inreq mod 10 + 48);
          dorequests;
          getblock (trk, sec);
          newfdb.fmap[0].track := chr (trk + 48);
          newfdb.fmap[0].sector := chr (sec + 48);
          diskimage[trk,sec].data[1].fdata := arec.fdata;
          if totreq <= 54 then begin
              for i := 0 to totreq do
                  diskimage[trk,sec].ins[i+9] := pgm[i];
              finishit;
          end
          else begin
              for i := 0 to 55 do
                  diskimage[trk,sec].ins[i+9] := pgm[i];
              getblock (trk,sec);
              newfdb.fmap[1].track := chr (trk + 48);
              newfdb.fmap[1].sector := chr (sec + 48);
              for i := 56 to totreq do
                  diskimage[trk,sec].ins[i-55] := pgm[i];
              finishit;
          end;
     end;
     putit (newfdb);
     diskimage[0,0].hblock.bit := bitmap;
end;

procedure findit (var name: c10; var trk, sec, rec: integer);
var
      i:      integer;
      check,
      ment:   integer;
      done:   boolean;
begin
      name := '          ';
      write ('File name: ');
      i := 1;
      while (i <= 10) and (not eoln) do
      begin
          read (name[i]);
          if name[i] >= 'a' then name[i] := chr (ord (name[i]) - 32);
          i := i + 1;
      end;
      readln;
      ment := 0;
      check := 0;
      rec := 1;
      done := false;
      repeat
          trk := ord (diskimage[0,0].hblock.mfd.fmap[ment].track) - 48;
          sec := ord (diskimage[0,0].hblock.mfd.fmap[ment].sector) - 48;
          if name = diskimage[trk,sec].data[rec].mfd.name then done := true
          else begin
              check := check + 1;
              rec := rec + 1;
              if rec > 8 then begin
                  rec := 1;
                  ment := ment + 1;
              end;
          end;
      until (check >= numfiles) or done;
      if not done then trk := -1;
end;

procedure freeblock (trk, sec, rec: integer);
var
      i:      integer;
      t, s:   integer;
begin
      for i := 0 to 9 do
      begin
          t := ord (diskimage[trk,sec].data[rec].mfd.fmap[i].track) - 48;
          if t <> 9 then begin
              s := ord (diskimage[trk,sec].data[rec].
                          mfd.fmap[i].sector) - 48;
              bitmap[t,s] := false;
          end;
      end;
end;

procedure delproc;
var
      i, j:           integer;
      name:           c10;
      it, trk,
      sec, rec,
      ltrk, lsec,
      lrec:           integer;
begin
      findit (name, trk, sec, rec);
      if trk < 0 then writeln ('Cannot find the file.')
      else begin
          it := numfiles div 8;
          if numfiles mod 8 = 0 then it := it - 1;
          ltrk := ord (diskimage[0,0].hblock.mfd.fmap[it].track) - 48;
          lsec := ord (diskimage[0,0].hblock.mfd.fmap[it].sector) - 48;
          lrec := numfiles mod 8;
          if lrec = 0 then lrec := 8;
          freeblock (trk, sec, rec);
          diskimage[trk,sec].data[rec] := diskimage[ltrk,lsec].data[lrec];
          incrfiles (-1);
          if numfiles mod 8 = 0 then 
          begin
              bitmap[ltrk,lsec] := false;
              diskimage[0,0].hblock.mfd.fmap[it].track := '9';
              diskimage[0,0].hblock.mfd.fmap[it].sector := '9';
          end;
          diskimage[0,0].hblock.bit := bitmap;
      end;
end;

procedure dumpproc;
var
      trk, sec, rec:      integer;
      h, i, j:            integer;
      trec:               packed array [1..8] of c32;
begin
      write ('Track: ');
      readln (trk);
      if (trk < 0) or (trk > 7) then writeln ('Invalid track.');
      write ('Sector: ');
      readln (sec);
      if (sec < 0) or (sec > 7) then writeln ('Invalid sector.');
      for i := 1 to 8 do
      begin
          trec[i] := diskimage[trk,sec].data[i].fdata;
          for j := 1 to 32 do
          begin
              h := ord(trec[i][j]);
              write (hex(h,2,2));
              if (h < 32) or (h > 126) then trec[i][j] := '.';
              if j mod 4 = 0 then write (' ');
          end;
          writeln;
      end;
      writeln;
      writeln;
      for i := 1 to 8 do
          writeln (trec[i]);
end;

procedure showpgm;
var
      trk, sec, rec:      integer;
      t, s, i:            integer;
      what:               c10;
      done:               boolean;
begin
      findit (what, trk, sec, rec);
      if trk < 0 then writeln ('Cannot find the file.');
      t := ord (diskimage[trk,sec].data[rec].mfd.fmap[0].track) - 48;
      s := ord (diskimage[trk,sec].data[rec].mfd.fmap[0].sector) - 48;
      writeln ('  PC  Op Code   Adr  Wait');
      i := 9;
      done := false;
      while (i <= 55) and (not done) do
      begin
               writeln (iopc:4, '  Read   ', ioadr:6, delay:6);
               writeln (iopc:4, '  Write  ', ioadr:6, delay:6);
               writeln (iopc:4, '  Exit   ', ioadr:6, delay:6);
               done := true;
               writeln (iopc:4, '  Abort  ', ioadr:6, delay:6);
               done := true;
          i := i + 1;
      end;
      if not done then
      begin
        t := ord (diskimage[trk,sec].data[rec].mfd.fmap[1].track) - 48;
        s := ord (diskimage[trk,sec].data[rec].mfd.fmap[1].sector) - 48;
        i := 1;
        while (i <= 45) and (not done) do
        begin
                 writeln (iopc:4, '  Read   ', ioadr:6, delay:6);
                 writeln (iopc:4, '  Write  ', ioadr:6, delay:6);
                            writeln (iopc:4, '  Exit   ', ioadr:6, delay:6);
                            done := true;
                            writeln (iopc:4, '  Abort  ', ioadr:6, delay:6);
            i := i + 1;
        end;
      end;
end;

procedure help;
begin
      writeln;
      writeln ('        Command Summary');
      writeln;
      writeln ('ADD     Adds a new file to the disk image');
      writeln ('BIT     Shows the disk''s bitmap');
      writeln ('DEL     Deletes a file from the disk image');
      writeln ('DIR     Lists names and sizes of files on disk');
      writeln ('DUMP    Displays one sector in hex and character forms');
      writeln ('EXIT    Write current disk image to disk file and terminate');
      writeln ('HELP    Displays this message');
      writeln ('KILL    Deletes a logon ID from the disk image');
      writeln ('NEW     Adds a new logon ID to the disk image');
      writeln ('PGM     Displays an executable file in instruction form');
      writeln ('QUIT    Terminate without changing the disk file');
      writeln ('USERS   Lists all logon IDs on the disk');
      writeln;
end;

begin
     filename := '                                ';
     i := 1;
     write ('Enter files disk file name: ');
     while not eoln do
     begin
          read (filename[i]);
          i := i + 1;
     end;
     readln;
     open (disk, filename, OLD, ERROR:=CONTINUE);
     if status(disk) = 0 then
     begin
          reset (disk);
          for i := 0 to 7 do
               for j := 0 to 7 do
                    read (disk, diskimage[i,j]);
          close (disk);
          bitmap := diskimage[0,0].hblock.bit;
          oldfile := true;
     end
     else begin
          oldfile := false;
          diskimage[0,0].hblock.mfd.name := '%MFD--FDB%';
          diskimage[0,0].hblock.mfd.nrecs := '00';
               for i := 0 to 9 do
               begin
                    fmap[i].track := '9';
                    fmap[i].sector := '9';
               end;
          for i := 1 to 27 do
               diskimage[0,0].hblock.id[i] := '        ';
          for i := 0 to 7 do
              for j := 0 to 7 do
                  bitmap[i,j] := false;
          bitmap[0,0] := true;
          diskimage[0,0].hblock.bit := bitmap;
     end;

     logons := diskimage[0,0].hblock.id;
     numfiles := (ord (diskimage[0,0].hblock.mfd.nrecs[1]) - 48) * 10 +
                    ord (diskimage[0,0].hblock.mfd.nrecs[2]) - 48;
     i := 1;
     while logons[i] <> '        ' do
          i := i + 1;
     numids := i - 1;

     again := true;
     command := '    ';
     repeat
          write ('Command: ');
          i := 1;
          while (i <= 4) and (not eoln) do
          begin
               read (command[i]);
               if command[i] >= 'a' then 
                    command[i] := chr (ord (command[i]) - 32);
               i := i + 1;
          end;
          readln;
          command := '    ';
     until not again;
end.