PROGRAM altdrive(cookbook, input, output);  (* prelim. 85/02/15 *)
(* alter parameters in DSKDRIVE to change drive characteristics *)

  CONST
    header       = 'ALTDRIVE (cookbook, input, output) Ver. 0.x';
    maxsector    = 79;         (* this system cannot handle more *)
    rsxnum       = 115;        (* 73 hex, for the DSKDRIVE system *)
    drvmsgsize   = 27;

  TYPE
    byte         = char;       (* PACKED 0..255 *)
    address      = integer;

    paramblk     = RECORD
      cpmspt       : integer;  (* CPM sectors/physical track *)
      bsh          : byte;     (* log2(sector/cpmallocationblock *)
      blm          : byte;     (* block mask, calculated from bsh *)
      exm          : byte;     (* extent mask,  " *)
      dsm          : integer;  (* total allocation blocks on drive *)
      drm          : integer;  (* max directory index, 0 based *)
      al0          : byte;     (* pre-allocated blocks, usually *)
      al1          : byte;     (*   for directory entries. *)
      cks          : integer;  (* checked entries = (drm+1)/4 or 0 *)
      off          : integer;  (* reserved tracks *)
      hstblk       : byte;     (* 1,2,4 or 8 only. sector/phys rcd *)

      sxltbl       : PACKED ARRAY[0..maxsector] OF byte;
  
      spare        : byte;
      sec1st       : byte;     (* physical id of 1st sector on track *)
      config       : byte;     (* 0 thru 4 for now. Add 128 for SD *)

      ntrks        : byte;     (* number of physical tracks *)
      nsecs        : byte;     (* correction to side 1 sector adr *)

      drvmsg       : PACKED ARRAY[1..drvmsgsize] OF char; (* $ filled *)
      END; (* paramblk *)

    pblkptr      = ^paramblk;

  VAR
    cookbook     : FILE OF paramblk;
    pblock       : paramblk;
    pptr         : pblkptr;

  (* 1-----------------1 *)

  FUNCTION rsxexists(rsx : integer) : boolean;
  (* non-standard.  Isolate in procedure *)

    BEGIN (* rsxexists *)
    rsxexists := syscall(rsx, 0) <> 0;
    END; (* rsxexists *)

  (* 1-----------------1 *)

  FUNCTION findata(rsx : integer) : pblkptr;
  (* highly non-standard.  Isolate in procedure *)

    VAR
      p    : pblkptr;

    BEGIN (* findata *)
(*$x+,s-,d- non-standard, and pointer is not in the heap *)
    p := pblkptr(syscall(rsx, 1));
    IF lsr(ord(pointerto(p)), 1) < lsr(ord(p), 1) THEN findata := p
    ELSE BEGIN
      writeln('Patch to RUNPCD not installed');
      terminate; END;
(*$x-*)
    END; (* findata *)

  (* 1-----------------1 *)

  FUNCTION validate : boolean; (* The current cookbook record *)
  (* avoids problems with CPMs lack of exact EOF marker *)

    BEGIN (* validate *)
    IF eof(cookbook) THEN validate := false
    ELSE IF cookbook^.cpmspt = 0 THEN validate := false
    ELSE IF cookbook^.cpmspt > 1000 (* 1A1Ah = 6682 *) THEN
      validate := false
    ELSE IF cookbook^.cpmspt < 1 THEN validate := false
    ELSE validate := true;
    END; (* validate *)

  (* 1-----------------1 *)

  PROCEDURE modify(VAR pb : paramblk);

    TYPE
      menuptr      = ^menuitem;
      menuitem     = RECORD
        left, right  : menuptr;         (* for sorting *)
        index        : integer;
        datum        : paramblk;
        END; (* menuitem *)

    VAR
      menuroot     : menuptr;
      desired,                   (* menu item selected *)
      itemindex,                 (* used in forming indices *)
      itemshown    : integer;    (* pagination of menu *)
      ok           : boolean;
      indexeditem  : menuptr;

    (* 2-----------------2 *)

    PROCEDURE showname(VAR item : paramblk); (* in drvmsgsize field *)

      VAR
        i    : integer;

      BEGIN (* showname *)
      WITH item DO BEGIN
        i := drvmsgsize;
        WHILE drvmsg[i] = '$' DO i := pred(i);
        write(drvmsg : i, (* remove $s *) ' ' : drvmsgsize - i); END;
      END; (* showname *)

    (* 2-----------------2 *)

    PROCEDURE displaymenu;

      (* 3-----------------3 *)

      PROCEDURE showmenu(root : menuptr);
      (* also creates the "index" entry in the table items *)
  
        CONST
          pagesize   = 20; (* lines of menu per display page *)
  
        VAR
          i     : integer;
  
        BEGIN (* showmenu *)
        IF root <> NIL THEN BEGIN
          showmenu(root^.left);
          IF odd(itemshown) THEN write(' ' : 4)
          ELSE BEGIN
            writeln;
            IF (itemshown DIV 2) > pagesize THEN BEGIN
              overprint('[More..]'); readln;
              itemshown := 0; END;
            END;
          itemindex := succ(itemindex); root^.index := itemindex;
          itemshown := succ(itemshown);
          write(itemindex : 3, ' '); showname(root^.datum); 
          showmenu(root^.right); END;
        END; (* showmenu *)

      (* 3-----------------3 *)

      BEGIN (* displaymenu *)
      itemindex := 0; itemshown := 0;
      showmenu(menuroot); writeln;
      END; (* display menu *)

    (* 2-----------------2 *)

    PROCEDURE loadtable(root : menuptr);
    (* of precooked variations from cookbook *)

      (* 3-----------------3 *)

      PROCEDURE insert(VAR item : paramblk; VAR root : menuptr);

        BEGIN (* insert *)
        IF root = NIL THEN BEGIN
          new(root);
          WITH root^ DO BEGIN
            index := 0; left := NIL; right := NIL;
            datum := item; END;
          END
        ELSE IF item.drvmsg < root^.datum.drvmsg THEN
          insert(item, root^.left)
        ELSE IF item.drvmsg = root^.datum.drvmsg THEN
          root^.datum := item       (* use latest entry only *) 
        ELSE insert(item, root^.right);
        END; (* insert *)

      (* 3-----------------3 *)

      BEGIN (* loadtable *)
      WHILE validate DO BEGIN
        insert(cookbook^, root); get(cookbook); END;
      writeln('Precooked versions for:');
      displaymenu;
      END; (* loadtable *)

    (* 2-----------------2 *)

    FUNCTION findindex(i : integer; root : menuptr) : menuptr;

      BEGIN (* findindex *)
      IF root = NIL THEN findindex := NIL
      ELSE IF i = root^.index THEN findindex := root
      ELSE IF i < root^.index THEN
        findindex := findindex(i, root^.left)
      ELSE findindex := findindex(i, root^.right);
      END; (* findindex *)

    (* 2-----------------2 *)

    FUNCTION confirmed : boolean;

      BEGIN (* confirmed *)
      prompt(' Satisfactory (y/n)?');
      confirmed := input^ IN ['y', 'Y'];
      readln;
      END; (* confirmed *)

    (* 2-----------------2 *)

    PROCEDURE displaydetails;

      VAR
        thisitem    : paramblk;
        singledensity,
        doublesided : boolean;
        style,
        rcdpercpmblk,
        rcdpertrack,
        cpmallocsz,
        allocblocks,
        i, j        : integer;

      (* 3-----------------3 *)

      PROCEDURE showallocated; (* based on alo, al1 *)

        VAR
          i, b    : integer;

        BEGIN (* showallocated *)
        b := 0; i := ord(thisitem.al0); allocblocks := 0;
        WHILE i > 0 DO BEGIN
          IF i >= 128 THEN BEGIN
            allocblocks := succ(allocblocks);
            IF b > 0 THEN write(',');
            write(' ', ord(b) : 1); i := i - 128; END;
          b := succ(b); i := i + i; END;
        i := ord(thisitem.al1);
        WHILE i > 0 DO BEGIN
          IF i >= 128 THEN BEGIN
            allocblocks := succ(allocblocks);
            write(',');
            write(' ', ord(b) : 1); i := i - 128; END;
          b := succ(b); i := i + i; END;
        END; (* showallocated *)

      (* 3-----------------3 *)

      PROCEDURE showskew;

        VAR
          noskew    : boolean;
          i         : integer;

        BEGIN (* showskew *)
        noskew := true; i := 0;
        WITH thisitem DO BEGIN
          WHILE noskew AND (i < cpmspt) DO
            IF ord(sxltbl[i]) <> i THEN noskew := false
            ELSE i := succ(i);
          IF noskew THEN write('No skew used')
          ELSE BEGIN
            write('Skew table:');
            FOR i := 0 TO pred(cpmspt) DO BEGIN
              IF i MOD 10 = 0 THEN writeln
              ELSE write(' ');
              write(ord(sxltbl[i]) : 2); END;
            END;
          writeln; END;
        END; (* showskew *)

      (* 3-----------------3 *)

      BEGIN (* displaydetails *)
      IF indexeditem = NIL THEN thisitem := pb
      ELSE thisitem := indexeditem^.datum;
      writeln;
      WITH thisitem DO BEGIN
        style := ord(config) MOD 128;
        rcdpercpmblk := 1; j := ord(bsh);
        WHILE j > 0 DO BEGIN
          rcdpercpmblk := rcdpercpmblk + rcdpercpmblk;
          j := pred(j); END;
        cpmallocsz := rcdpercpmblk DIV 8;
        rcdpertrack := cpmspt DIV ord(hstblk);
        write('PHYSICAL CHARACTERISTICS for ' : 30);
        showname(thisitem); writeln;
        doublesided := style <> 0;
        singledensity := ord(config) >= 128;
        IF doublesided THEN write('D')
        ELSE write('S');
	write('S');
        IF singledensity THEN write('S')
        ELSE write('D');
        write('D, ', ord(hstblk) * 128 : 1, ' bytes/sector, ');
        write(rcdpertrack : 1, ' sectors/track, ');
        write(ord(ntrks) : 1, ' tracks');
        IF doublesided THEN write('/side');
        writeln;
        write('Sectors nos. from ', ord(sec1st) : 1);
        write(' thru ', rcdpertrack + ord(sec1st) - 1 : 1);
        IF style <> 0 THEN BEGIN
          write('. Side 1 sector numbers from ');
          CASE style OF
1,
2:          write(ord(nsecs) + ord(sec1st) : 1);
3,
4:          write(ord(sec1st) : 1);
            END; (* Case *)
          END;
        writeln;
        writeln; write('CPM CHARACTERISTICS for ' : 30);
        showname(thisitem); writeln;
        write('Allocation size = ', cpmallocsz : 1, ' Kbytes');
        writeln(' with ', off : 1, ' reserved tracks');
        write(succ(drm) : 1, ' directory entries with block #');
        showallocated; writeln(' preallocated');
        write('Storage ', (succ(dsm) - allocblocks) * cpmallocsz : 1,
              ' Kbytes, on ');
        writeln(succ(dsm) * rcdpercpmblk DIV cpmspt + off : 1,
              ' tracks');
        writeln;
        write('hstblk = ' : 16, ord(hstblk) : 5);
        write('cpmspt = ' : 16, cpmspt : 5);
        writeln('dsm = ' : 16, dsm : 5);
        write('bsh = ' : 16, ord(bsh) : 5);
        write('blm = ' : 16, ord(blm) : 5);
        writeln('exm = ' : 16, ord(exm) : 5);
        write('drm = ' : 16, drm : 5);
        write('al0 = ' : 16, ord(al0) : 5);
        writeln('al1 = ' : 16, ord(al1) : 5);
        write('cks = ' : 16, cks : 5);
        write('off = ' : 16, off : 5);
        writeln('sec1st = ' : 16, ord(sec1st) : 5);
        write('ntrks = ' : 16, ord(ntrks) : 5);
        write('nsecs = ' : 16, ord(nsecs) : 5);
        writeln('config = ' : 16, ord(config) : 5);
        showskew; END;
      END; (* displaydetails *)

    (* 2-----------------2 *)

    PROCEDURE help;

      BEGIN (* help *)
      writeln('Here we explain the various options');
      END; (* help *)

    (* 2-----------------2 *)

    PROCEDURE makespecial;

      BEGIN (* makespecial *)
      writeln('Here we create new configurations');
      END; (* makespecial *)

    (* 2-----------------2 *)

    PROCEDURE additem;

      BEGIN (* additem *)
      writeln('Here we add the current (special) item to the file');
      END; (* additem *)

    (* 2-----------------2 *)

    BEGIN (* modify *)
    writeln;
    write('Currently set to: '); showname(pb); writeln;
    new(menuroot);
    WITH menuroot^ DO BEGIN  (* cookbook exists, menuroot <> NIL *)
      index := 0; left := NIL; right := NIL;
      datum := cookbook^; END;
    get(cookbook); loadtable(menuroot);
    indexeditem := NIL;
    REPEAT    (* get user specifications *)
      REPEAT
        ok := false;
        prompt('Enter index desired, ? for help, or M,S,A,D,U : ');
        IF input^ IN ['0'..'9'] THEN BEGIN
          read(desired); indexeditem := findindex(desired, menuroot);
          ok := indexeditem <> NIL; END
        ELSE IF input^ IN ['d', 'D'] THEN displaydetails
        ELSE IF input^ IN ['m', 'M'] THEN displaymenu
        ELSE IF input^ IN ['s', 'S'] THEN makespecial
        ELSE IF input^ IN ['a', 'A'] THEN additem
        ELSE IF input^ IN ['u', 'U'] THEN ok := true
        ELSE IF input^ = '?' THEN help;
        readln;
      UNTIL ok;
      showname(indexeditem^.datum);
    UNTIL confirmed;
    pb := indexeditem^.datum;
    END; (* modify *)

  (* 1-----------------1 *)

  BEGIN (* altdrive *)
  writeln(header);
  IF NOT rsxexists(rsxnum) THEN writeln('DSKDRIVE not installed')
  ELSE BEGIN
(*$x+,d- because pointer is not in heap, avoid range checks *)
    pptr := findata(rsxnum);
(*$x-*)
    pblock := pptr^;  (* save a copy, avoid foulups *)
    IF exists(cookbook) THEN BEGIN
      IF validate (* cookboot *) THEN BEGIN
        modify(pblock); pptr^ := pblock;
        writeln('Drive settings altered'); END
      ELSE writeln('Invalid COOKBOOK file'); END
    ELSE BEGIN  (* save the item for cookbook inclusion *)
      rewrite(cookbook); cookbook^ := pblock; put(cookbook);
      writeln('COOKBOOK contains present settings'); END;
    END;
  END. (* altdrive *)