(*  REGROUP  version 1.0          5/84 by David B. Ring

    This program is placed in the public domain and may
    be freely reproduced for noncommercial purposes.  It
    is intended to be compiled with Turbo Pascal from
    Borland International, and compatibility with other
    versions of Pascal has not been checked.              *)

const
    MAXGROUP          = 184;  (* last allocation group on DD *)
    FIRST_TRACK       = 3;    (* first nonsystem track *)
    GROUPS_PER_TRACK  = 5;
    SECTORS_PER_GROUP = 8;
    SELDRV            = 14;   (* BDOS and BIOS functions *)
    SETTRK            = 9;
    SETSEC            = 10;
    SETDMA            = 11;
    READSEC           = 12;
    A                 = 0;    (* disk drives *)
    B                 = 1;
    SHADED_SQUARE     = 127;  (* special symbols for display *)
    DOT               = 46;
    END_OF_FILE       = 26;   (* CP/M end of file character *)

type
    blockbuf  = array[1..1024] of byte;
    filename  = string[12];
    maparray  = array[0..MAXGROUP] of filename;
    direction = (AHEAD, BACK);
    errorcode = (NOT_ON_MENU, OUT_OF_RANGE);

var
    group       : integer;
    sourcedrive : integer;
    buffer      : blockbuf;
    map         : maparray;

(**  LOW LEVEL PROCEDURES  *******************************************)

function filter(c : byte) : byte;
begin
    case c of
        END_OF_FILE : filter := SHADED_SQUARE;
        32..126     : filter := c;
        160..254    : filter := c - 128;
        else          filter := DOT;
    end;
end;

procedure prompt(line : integer);
begin
    gotoxy(1, line);
    clreol;
end;

procedure error(code : errorcode);
    var
        s : string[80];
begin
    case code of
        NOT_ON_MENU  :   s := 'Not on menu.  ';
        OUT_OF_RANGE :   s := 'Allocation group out of range.  ';
    end;
    prompt(4);
    write(s, 'Hit any key to continue.');
    repeat until keypressed;
end;

procedure readgroup(var group, drive : integer; var buffer : blockbuf);
    var
        track, sector, address, i : integer;
begin
    bdos(SELDRV, drive);
    track := FIRST_TRACK + group div GROUPS_PER_TRACK;
    bios(SETTRK, track);
    sector := SECTORS_PER_GROUP * (group mod GROUPS_PER_TRACK);
    address := addr(buffer);
    for i := 1 to SECTORS_PER_GROUP do
    begin
        bios(SETSEC, sector);
        bios(SETDMA, address);
        bios(READSEC);
        sector := sector + 1;
        address := address + 128;
    end;
end;

procedure showgroup(var group : integer; var buffer : blockbuf);
    var
        i : integer;
        c : char;
begin
    prompt(6);
    writeln('ALLOCATION GROUP ', group);
    writeln;
    for i := 1 to 1024 do
    begin
        c := char(filter(buffer[i]));
        write(c);
        if (i mod 64 = 0) then writeln;
    end;
end;

(**  PROCEDURES CALLED BY MENU  ************************************)

procedure gotogroup(newgroup : integer; var group, drive : integer;
                    var buffer : blockbuf);
begin
    if (newgroup in [0..MAXGROUP]) then
    begin
        group := newgroup;
        readgroup(group, drive, buffer);
        showgroup(group, buffer);
    end
    else error(OUT_OF_RANGE);
end;

procedure help;
begin
    clrscr;
    writeln('A  Move ahead one allocation group and display contents.');
    writeln('B  Move back one allocation group and display contents.');
    writeln('F  Construct a new file out of allocation groups that have');
    writeln('   been labeled with the corresponding filename using the');
    writeln('   label function.');
    writeln('G  Move to the specified allocation group and display contents.');
    writeln('   This is the only command allowing an argument.  Syntax is');
    writeln('   Gxxx or G xxx, where xxx is an allocation group number in');
    writeln('   decimal.  Note that end of file will appear as a shaded');
    writeln('   square graphic symbol or series of such.');
    writeln('L  Label the currently displayed allocation group with a 12');
    writeln('   character maximum filename.  This name should consist of an');
    writeln('   8 char max filename, period, and 3 char max filetype.  It');
    writeln('   must not include a drive specification, since this will be');
    writeln('   supplied automatically.');
    writeln('M  Display a map of all allocation groups and their filenames');
    writeln('   as supplied using the label function.');
    writeln('X  Exit program.');
    writeln('?  Display this help screen.');
    writeln;
    writeln;
    writeln('   Press any key to return to menu.');
    repeat until keypressed;
    clrscr;
end;

procedure maplabel(var group : integer; var map : maparray);
    var
        s, t : filename;
begin
    prompt(4);
    write('Enter filename for group:  ');
    read(s);
    t := '            ';
    insert(s, t, 1);
    map[group] := t;
end;

procedure makefile(var source : integer;
                   var buffer : blockbuf; var map : maparray);
    var
        name, mapname : filename;
        chan          : file;
        group, target : integer;
        c             : char;
begin
    prompt(4);
    write('Target drive for output file:  ');
    read(c);
    target := ord(upcase(c)) - ord('A');

    prompt(4);
    write('Filename:  ');
    read(name);
    mapname := '            ';
    insert(name, mapname, 1);
    if (target = A) then assign(chan, 'A:' + name)
    else assign(chan, 'B:' + name);
    rewrite(chan);

    prompt(4);
    write('Show each group before writing to file (Y or N)?  ');
    read(c);

    for group := 0 to MAXGROUP do
    begin
        if (map[group] = mapname) then
        begin
            readgroup(group, source, buffer);
            if (upcase(c) = 'Y') then
            begin
                showgroup(group, buffer);
                prompt(4);
                write('Write group to file (Y) or skip (N)?  ');
                read(c);
                if (upcase(c) = 'Y') then blockwrite(chan, buffer, 8);
            end
            else blockwrite(chan, buffer, 8);
        end;
    end;
    close(chan);
end;

procedure showmap(var map : maparray);
    label
        abort;
    var
        i, row, col : integer;
        c           : char;
begin
    gotoxy(1, 6);
    clreol;
    for i := 0 to MAXGROUP do
    begin
        if (i mod 64 = 0) then
        begin
            if (i > 0) then
            begin
                prompt(4);
                write('Press C to continue map, X to abort:  ');
                read(c);
                if (upcase(c) = 'X') then goto abort;
            end;
            for row := 8 to 24 do prompt(row);
        end;
        row := 8 + i mod 16;
        col := 1 + ((i mod 64) div 16) * 17;
        gotoxy(col, row);
        write(i : 3, ' ', map[i]);
    end;
    abort:
end;

procedure step(dir : direction; var group, drive : integer;
               var buffer : blockbuf);
    var
        newgroup : integer;
begin
    if (dir = AHEAD) then newgroup := group + 1 else newgroup := group - 1;
    gotogroup(newgroup, group, drive, buffer);
end;

(**  PROCEDURES CALLED BY MAIN PROGRAM  ******************************)

procedure init(var sourcedrive, group : integer; var map : maparray);
    var
        c : char;
        i : integer;
begin
    clrscr;
    writeln('REGROUP   version  1.0            5/83 by David B. Ring');
    writeln;
    writeln('REGROUP facilitates recovery of files from disks that have a');
    writeln('bad directory, but that are otherwise readable.  (If you have');
    writeln('an unreadable disk and suspect a bad directory, try copying it');
    writeln('to a new diskette using the COPYF command of MVP FORTH.  It');
    writeln('may then be completely okay, or at least recoverable by this');
    writeln('program.)  REGROUP can also be used to partially recover erased');
    writeln('files that can no longer be salvaged with UNERA, or to write');
    writeln('FORTH screens into CP/M files.');
    writeln;
    writeln('REGROUP is placed in the public domain, and may be reproduced');
    writeln('freely for noncommercial purposes.  REGROUP is written in Turbo');
    writeln('Pascal, and thanks are due to Borland International for allowing');
    writeln('free distribution of the compiled code.');
    writeln;
    writeln;

    write('Source drive for allocation groups:  ');
    read(c);
    sourcedrive := ord(upcase(c)) - ord('A');
    group := 0;
    for i := 0 to MAXGROUP do map[i] := '            ';
    clrscr;
end;

procedure menu;
    var
        c : char;
        n : integer;
begin
    gotoxy(1, 1);
    writeln('A  Ahead      B  Back       F  File       G  Group');
    writeln('L  Label      M  Map        X  Exit       ?  Help');
    prompt(4);
    write('Your choice:  ');

    read(c, n);
    case upcase(c) of
        'A'     : step(AHEAD, group, sourcedrive, buffer);
        'B'     : step(BACK, group, sourcedrive, buffer);
        'F'     : makefile(sourcedrive, buffer, map);
        'G'     : gotogroup(n, group, sourcedrive, buffer);
        'L'     : maplabel(group, map);
        'M'     : showmap(map);
        'X'     : begin clrscr; halt; end;
        '?'     : help;
        else      error(NOT_ON_MENU);
    end;
end;

(**  MAIN PROGRAM  ***************************************************)

begin
    init(sourcedrive, group, map);
    while (true) do menu;
end.