Between Heaven & Hell 2/BetweenHeavenHell.cdr/300/295/indexer.pas

Pascal/Delphi Source File | 1985-06-22 | 25KB | 836 lines

program indexer(input,output);

{         INDEX  CREATION  FROM  THE  KEYBOARD          }
{                                  }
{    David E. Cortesi, 2340 Tasso St., Palo Alto CA 94301.    }
{           (compuserve 72155,450)              }
{                                  }
{ Accepts index entries for a book from the keyboard, sorts   }
{ the entries and sub-entries, collates page references,      }
{ and creates an ASCII file that can be printed or edited.    }
{                                  }
{ Term Recall is an unusual feature of the user interaction.  }
{ If, when entering an index term, the user hits the ESC key, }
{ the program will find the least term that matches the input }
{ to that point and fill in its characters on the input line. }
{ Hitting ESC again retracts those letters and displays the   }
{ letters of the next-higher matching term.  This can save    }
{ considerable typing -- a long term can be entered as only   }
{ a couple of letters plus ESC -- and it allows the user to   }
{ review the terms entered to that point in alpha order.      }
{                                  }
{ Creates files INDEXER.OUT, the index-document file, and     }
{ INDEXER.TRE, an internal record of the tree which will be   }
{ reloaded on the next run if it then exists.              }
{-------------------------------------------------------------}

const
    nullch = 0;         { the null, end-of-string      }
    strmax = 65;        { max size of a string (64,00h)}
    sbufsize = 2046;        { page size of a string buffer }
    sbufnum = 16;        { allow up to 32K of buffers   }
    maxdepth = 20;        { stack size for tree-walks    }
    asciibel = 7;        { names for ascii characters   }
    asciibs = 8;
    asciilf = 10;
    asciicr = 13;
    asciiesc = 27;
    asciiblank = 32;
    asciidel = 127;

type
    strindex = 1..strmax;    { indices over strings           }
    strlength= 0..strmax;    { lengths of strings           }
    relation = (less,equal,more); { result of comparisons      }
    nchar = 0..255;        { numeric characters are bytes }
    str = record        { an independent string is     }
        len : strlength;    { ..a length and some bytes,   }
        val : array[strindex] of nchar  { ending in 00h    }
        end;
    pstrb   = ^strbuff;
    strbuff = record        { a string buffer is a compact }
        free : 0..sbufsize; { collection of strings.       }
        data : array[1..sbufsize] of nchar
        end;
    stref = record        { an indirect string is the    }
        nb : 1..sbufnum;    { index of an strbuff's address}
        bo : 1..sbufsize    { and an index into it.        }
        end;
    pprec = ^prec;
    prec = record        { a page on which a term is    }
        next : pprec;    { ..referenced, and ^next one  }
        num  : integer
        end;
    pnode = ^node;
    node = record        { one node of a binary tree    }
        lson, rson,     { descendant trees           }
        subt : pnode;    { subtree of sub-terms           }
        iref, uref : stref; { original and uppercase terms }
        phead : pprec;    { head of chain of page-refs   }
        skip : boolean;    { phony node "M" starts a tree }
        end;
    treewalk = record        { current state of an inorder  }
        current : pnode;    { ..walk of a tree: this node, }
        top : 0..maxdepth;    { stack-top pointer, stacked   }
        stack : array[1..maxdepth] of pnode;{ nodes, mark  }
        goneleft : boolean    { true when backing out of leaf}
        end;

var
    sbufptrs : array[1..sbufnum] of pstrb; { blocks of bytes}
    sbufcnt  : 0..sbufnum;    { how many blocks are active   }
    maintree : pnode;        { root of the term-tree        }
    initerm  : str;        { "M" term for starting trees  }
    indlevel : 0..9;        { subterm nesting (indent) lev.}
    outfile  : text;        { the output document           }

{-------------------------------------------------------------}
{     routines operating on independent strings          }
{ Pascal/Z string type was avoided to maximize portability.   }
{-------------------------------------------------------------}

function upcase(c:nchar) : nchar;
    { force character to uppercase }
    begin
    if (c>=ord('a')) and (c<=ord('z')) then
        upcase := c-32
    else
        upcase := c
    end;

procedure stucase(var a,b:str);
    { duplicate a string, forcing uppercase }
    var j : strlength;
    c : nchar;
    begin
    j := 0;
    repeat
        j := j+1;
        c := a.val[j];
        b.val[j] := upcase(c);
    until c=nullch;
    b.len := j-1
    end;

{-------------------------------------------------------------}
{        routines operating on stored strings          }
{ To keep all stored terms in string form (P/Z or our version)}
{ would use far too much storage. Here we pack strings into   }
{ large blocks.  The blocks are allocated as needed, to a max }
{ of 32K -- limit enforced by compiler range checking.          }
{-------------------------------------------------------------}

procedure stput(var a:str; var b:stref);
    { stow string a in latest buffer, return indirect reference}
    var bp : pstrb;
    j : strindex;
    k : 1..sbufsize;
    begin
    bp := sbufptrs[sbufcnt]; { ^latest string buffer       }
    if bp^.free<(a.len+1) then begin { not enough room!    }
        new(bp);        { make, count new buffer page  }
        sbufcnt := sbufcnt+1; { range error here when full }
        sbufptrs[sbufcnt] := bp;
        bp^.free := sbufsize
    end;

    b.nb := sbufcnt;    { save buffer-page number      }
    j := 1;
    k := 1+sbufsize-bp^.free;
    b.bo := k;        { save buffer-page offset      }

    while j <= a.len do begin
        bp^.data[k] := a.val[j];
        j := j+1;
        k := k+1
    end;
    bp^.data[k] := nullch;    { mark end of stored string    }
    bp^.free := sbufsize-k    { adjust bytes left in block   }
    end;

procedure stget(var b:stref; var a:str);
    { retrieve stored string from buffer into string-record }
    var bp : pstrb;
    j : strindex;
    k : 1..sbufsize;
    c : nchar;
    begin
    bp := sbufptrs[b.nb];    { point to the buffer page     }
    k := b.bo;        { ..and offset into it           }
    j := 1;
    repeat            { copy the stored string out   }
        c := bp^.data[k];
        a.val[j] := c;
        j := j+1;
        k := k+1;
    until (c=nullch);
    a.len := j-2
    end;

function sbcomp(var a:str; var b:stref) : relation;
    { EXACT comparison of a string to a stored string value --
      if "a" is initially equal but shorter, it is "less." }
    var bp : pstrb;
    j  : strindex;
    k  : 1..sbufsize;
    x,y : nchar;
    r  : relation;
    begin
    bp := sbufptrs[b.nb];
    k := b.bo;
    j := 1;
    repeat
        x := a.val[j];
        y := bp^.data[k];
        j := j+1;
        k := k+1
    until (x<>y) or (x=nullch);
    if x=y then r := equal
    else if x<y then r := less
         else     r := more;
    sbcomp := r
    end;

function sxcomp(var a:str; var b:stref) : relation;
    { APPROXIMATE comparison of a string to a stored string --
     if "a" is initially equal but shorter, it is "equal." }
  var bp : pstrb;
    j  : strindex;
    k  : 1..sbufsize;
    x,y : nchar;
    r  : relation;
    begin
    bp := sbufptrs[b.nb];
    k := b.bo;
    j := 1;
    repeat
        x := a.val[j];
        y := bp^.data[k];
        j := j+1;
        k := k+1
    until (x<>y) or (x=nullch);
    if (x=y) or (x=nullch) then r := equal
    else if x<y then r := less
         else     r := more;
    sxcomp := r
    end;

{-------------------------------------------------------------}
{        routines operating on the binary trees          }
{ Each tree node represents one index term.  The term itself  }
{ is stored two ways, as typed and all-caps.  The latter is   }
{ used for comparison of terms, so that "Apple" = "apple".    }
{ A node anchors a sorted chain of page-numbers, and may hold }
{ the root of an independent sub-tree of sub-terms.  The tree }
{ is ordered so that all terms off the .lson are less than,   }
{ and all terms off the .rson are greater, than this term.    }
{-------------------------------------------------------------}

function makenode(var a, ua : str) : pnode;
    { make a new tree node given term-strings }
    var tn : pnode;
    begin
    new(tn);
    tn^.lson := nil;
    tn^.rson := nil;
    tn^.subt := nil;
    stput(a,tn^.iref);
    stput(ua,tn^.uref);
    tn^.phead := nil;
    tn^.skip := false;
    makenode := tn
    end;

procedure startree(var t:pnode);
    { begin a tree with an artificial node whose term
       is "M" to encourage early balance }
    begin
       t := makenode(initerm,initerm);
       t^.skip := true
    end;

function insert(tree:pnode; var a:str) : pnode;
    { put a new term into a tree, or find it if it is there.
       either way, return the term's node's address.         }
    var o,p,q : pnode;
    ua    : str;
    r     : relation;
    begin
    stucase(a,ua);
    p := tree;

    repeat
        r := sbcomp(ua,p^.uref);
        if r<>equal then
        if r=less then q := p^.lson
        else           q := p^.rson
        else q := p;
        o := p;
        p := q
    until (r=equal) or (p=nil);

    if r=equal then insert := p
    else begin { term doesn't exist in the tree }
        q := makenode(a,ua);
        if r=less then o^.lson := q
        else       o^.rson := q;
        insert := q
    end;
end;

{-------------------------------------------------------------}
{ routines for tree-walking.  These routines abstract the     }
{ idea of an in-order tour of the tree into a single record.  }
{ The usual algorithm for a walk is recursive (see J&W 11.5), }
{ which is not convenient for this program.              }
{-------------------------------------------------------------}

procedure initwalk(t:pnode; var w:treewalk);
    { initialize for a walk over the given tree }
    begin
    w.current := t;     { start at the top node,       }
    w.goneleft := false;    { ..but descend left first off }
    w.top := 0        { stack is empty           }
    end;

procedure push(pn: pnode; var w: treewalk);
    { push a given node onto the walk-stack }
    begin
    if w.top<maxdepth then begin
        w.top := w.top+1;
        w.stack[w.top] := pn
    end
    end;

function pop(var w:treewalk) : pnode;
    { pop the top node from the walk-stack }
    begin
    if w.top>0 then begin
        pop := w.stack[w.top];
        w.top := w.top-1
    end
    else pop := nil
    end;

function treestep(var w:treewalk) : pnode;
    { step to the next node in lexical order in a tree.
    return that node as result, and save it in the walk
    record as "current."  Return nil if end of tree.       }
    var t : pnode;
    begin
    t := w.current;
    repeat
        if not w.goneleft then begin { descend to the left }
        if t<> nil then
            while t^.lson<>nil do begin
            push(t,w);
            t := t^.lson
            end;
        w.goneleft := true { t^ a left-leaf of tree }
        end
        else { been down; have handled current; go up/right}
        if t<> nil then
            if t^.rson <> nil then begin
            t := t^.rson;         { jog right, then }
            w.goneleft := false  { drop down again }
            end
            else { nowhere to go but up }
            t := pop(w)
    until w.goneleft; { repeats when we jog right }
    w.current := t;
    treestep := t
    end;

function setscan(tree: pnode; var w: treewalk; var a: str)
                         : pnode;
    { given a partial term "a," a tree "tree," and a tree-
    walk record "w," set up w so that a series of calls on
    function treestep will return all the nodes that are
    initially equal to a in ascending order.  If there are
    none such, return nil.  This function sets up for Term
    Recall when the escape key is pressed during input.

    The algorithm is to find the matching term that is
    highest in the tree, then use treestep to find the
    lexically-least node under that term (which may not be
    a match) and then to treestep to the first match.}

    var ua : str;
    p,t : pnode;
    r : relation;
    quit : boolean;
    begin
    stucase(a,ua);
    initwalk(tree,w);
    t := tree;
    if t=nil then setscan := nil  { no matches possible    }
    else begin
        { step 1 is to find any part-equal node at all     }
        quit := false;
        repeat
        r := sxcomp(ua,t^.uref);
        case r of
            less : if t^.lson<>nil then t := t^.lson
                       else quit := true;
            more : if t^.rson<>nil then t := t^.rson
                       else quit := true;
            equal : quit := true
        end
        until quit;
        { If we have a match, it may not be the least one.
          If this node has a left-son, there can be lesser
          matches (and nonmatches) down that branch. }
        if r<>equal then setscan := nil { no match a-tall  }
        else begin
        w.current := t;
        if t^.lson=nil then w.goneleft := true
        else begin { zoom down in tree }
            w.goneleft := false;
            repeat
            t := treestep(w);
            r := sxcomp(ua,t^.uref)
            until r=equal
        end;
        setscan := t
        end
    end
    end;

{-------------------------------------------------------------}
{        routines for phase 1 -- input              }
{-------------------------------------------------------------}

procedure indent;
    { indent the cursor for the current nesting level }
    var i : 0..9;
    begin
    for i := 1 to indlevel do write('. . ')
    end;

function DOSXQQ(cmd,prm:word) : byte; EXTERN;

function readnc : nchar;
    { get one byte from the keyboard, bypassing the
      usual pascal procedures and going straight to DOS }

 { #8 is dos: wait for key, no echo, do check break }

    begin
    readnc := RETYPE(nchar,DOSXQQ(8,0));
    end;

procedure getterm(tree: pnode; var a:str; var cont: boolean);
    { get a term from the user, with control keys used thus:
    cr : end the term.
    lf : end the term, begin a subterm of it.
    esc: try to complete the term with the next (first)
         matching term from the present tree-context.
    del: cancel esc-completion, return to original entry.  }
    var
    c    : nchar;
    j, oj    : strindex;
    k    : strlength;
    x,ua    : str;
    quit    : boolean;
    tw    : treewalk;
    p    : pnode;

    procedure backup;
    { backup the screen and the "a" string to the original
        term that was entered. }
    var qj    : strindex;
    begin
        for qj := j downto (oj+1) do
          write(chr(asciibs),chr(asciiblank),chr(asciibs));
        j := oj;
        a.val[j] := nullch
    end;

    procedure startscan;
    { set up for an alphabetical scan over all terms that
      are an initial match to user entry thus far.    Setscan
      does most of the work. }
    begin
        stucase(a,ua); { for stepscan's benefit }
        p := setscan(tree,tw,a);
        if p<>nil then { phony node only if a.len=0 }
        if p^.skip then p := treestep(tw);
        if p<>nil then begin { this node has to be equal }
        stget(p^.iref,x);
        k := x.len+1
        end
        else k := 0
    end;

    procedure stepscan;
    { find the next match to the original string, leaving
      its value in x, or k=0 if there is none.  }
    begin
        k := 0;
        p := treestep(tw);
        if p<>nil then
        if p^.skip then p := treestep(tw);
        if p<>nil then
        if equal=sxcomp(ua,p^.uref) then begin
            stget(p^.iref,x);
            k := x.len+1
        end
    end;

    begin { the main Get Term procedure }
    indent; write('term: ');
    j := 1; oj := j;    { no data in the a-string      }
    k := 0;         { no esc-scan working           }
    quit := false;        { not finished yet (hardly!)   }
    repeat
        a.val[j] := nullch; { keep "a" a finished string   }
        a.len := j-1;    { ..at all times           }
        c := readnc;
        case c of

        asciibs :        { destructive backspace        }
        if j>1 then begin
            write(chr(asciibs),chr(asciiblank),chr(asciibs));
            j := j-1;
            oj := j;    { the current scan is accepted }
            k := 0;    { ..and no scan is underway    }
        end;

        asciicr :        { normal completion           }
        begin
            write(chr(asciicr),chr(asciilf));
            quit := true
        end;

        asciilf :        { complete, move on to subterm }
        begin
            write(chr(asciicr),chr(asciilf));
            quit := true
        end;

        asciiesc :        { automatic scan for match     }
        begin
            backup;    { wipe rejected match if any   }
            if k=0 then startscan else stepscan;
            if k=0 then { no (further) match found     }
            write(chr(asciibel))
            else    { next (first?) match found    }
            while j<k do begin
                a.val[j] := x.val[j];
                write(chr(a.val[j]));
                j := j+1
            end
        end;

        asciidel :        { cancel search for match      }
        begin
            backup;
            k := 0    { no active scan           }
        end;

        otherwise        { ordinary (?) character       }
        if (c<asciiblank) or (j=strmax) then
            write(chr(asciibel))
        else begin
            write(chr(c));
            a.val[j] := c;
            j := j+1;
            oj := j;     { the current scan has been   }
            k := 0     { ..accepted and is over      }
        end
        end {case}
    until quit;
    cont := c=asciilf
    end;

procedure getpage(var i: integer);
    { read a page number into an integer.  If page numbers
      are not simple integers, eg "3-17" and the like, this
      routine would have to build a string. }
    begin
    indent;
    write('page: ');
    readln(i)
    end;

procedure makepage(var p:pprec; i:integer);
    { make a page record and install its address }
    begin
    new(p);
    p^.next := nil;
    p^.num    := i
    end;

procedure addpage(np: pnode; pg: integer);
    { add a page number to the chain off a node.  This is
      a classic case of an algorithm that requires a 2-exit
      loop; the scan of the chain has to stop when a higher
      page number is found OR when the end of the chain is
      reached.    It could be done with Repeat or While, but
      it actually looks cleaner with Goto. }
    label 99,101,102,103;
    var p1, p2, p3: pprec;
    begin
    p1 := np^.phead;
    if p1=nil then makepage(np^.phead,pg)
    else  { some pages already noted, search chain }
        if pg<p1^.num then begin
        makepage(p2,pg); { this page less than all }
        p2^.next := p1;
        np^.phead := p2
        end
        else begin { this page goes somewhere in chain }
        99: p2 := p1^.next;
        if p2=nil then goto 101;
        if pg<p2^.num then goto 102;
        p1 := p2;
        goto 99;
        101: { p1^ last number in chain, pg is => it }
        begin
            if pg>p1^.num then
            makepage(p1^.next,pg);
            goto 103
        end;
        102: {p1^.num <= pg <p2^.num; pg goes between }
        begin
            if pg>p1^.num then begin
            makepage(p3,pg);
            p3^.next := p2;
            p1^.next := p3
            end
        end;
        103: ;
        end
    end;

procedure load(var atree:pnode);
    { input control: load terms into a tree from the keyboard.
      the code is recursive; if the user wants to do a subterm
      this routine calls itself to load the sub-tree of the
      superior term's node.  A page number of zero is a disaster
      when we reload the saved tree, so one is converted to -1.}
    var aterm : str;
    anode : pnode;
    apage : integer;
    cont  : boolean;
    begin
    repeat
        getterm(atree,aterm,cont);
        if aterm.len>0 then begin
        anode := insert(atree,aterm);
        if not cont then begin
            getpage(apage);
            if apage=0 then apage := 32767;
            addpage(anode,apage)
        end
        else begin { user hit lf, wants to recurse }
            if anode^.subt=nil then
            startree(anode^.subt);
            indlevel := indlevel+1;
            load(anode^.subt);
            indlevel := indlevel-1
        end
        end;
    until (aterm.len=0) or (indlevel>0)
    end;

{-------------------------------------------------------------}
{           routines for phase 2 -- output              }
{-------------------------------------------------------------}

procedure filenode(np: pnode; var oc: nchar);
    { write one node's contents, term + pages, to the output.
      It is at this level that we insert a blank line on a break
      in the sequence of main-term initial letters.  Once more,
      a loop over an ordered chain is cleaner with Goto. }
    label 99;
    var a : str;
    p : pprec;
    i : 0..9;
    j : strindex;
    k1, k2 : integer;
    ic : nchar;
    begin
    if not np^.skip then begin { ignore phony nodes }
        stget(np^.iref,a);
        ic := upcase(a.val[1]);
        if (indlevel=0) and  { main-term initial change? }
         (oc<>ic) then writeln(outfile);
        oc := ic;
        for i := 1 to indlevel do write(outfile,'    ');
        for j := 1 to a.len do write(outfile,chr(a.val[j]));
        p := np^.phead;
        while p<>nil do begin
        write(outfile,' ');
        k1 := p^.num;
        k2 := k1+1;
         99:p := p^.next;    { elide sequential numbers     }
        if p<>nil then
            if p^.num=k2 then begin
            k2 := k2+1;
            goto 99
            end;
        write(outfile,k1:1); { write "17" or "17-19"   }
        if (k1+1)<k2 then write(outfile,'-',k2-1:1);
        if p<>nil then write(outfile,',');
        end;
    writeln(outfile);
    end
    end;

procedure filetree(intree: pnode);
    { walk through a (sub-) tree and write each node }
    var tree    : pnode;
    tw    : treewalk;
    oc    : nchar;
    begin
    oc := nullch;
    initwalk(intree,tw);
    tree := treestep(tw);
    while tree<>nil do begin
        filenode(tree,oc);
        if tree^.subt<>nil then begin
        indlevel := indlevel+1;
        filetree(tree^.subt);
        indlevel := indlevel-1
        end;
        tree := treestep(tw)
    end
    end;

procedure dump;
    begin
    assign(outfile,'INDEXER.OUT');
    rewrite(outfile);
    filetree(maintree)
    end;

{-------------------------------------------------------------}
{       routines for phase 0 -- initialization          }
{-------------------------------------------------------------}

procedure init;
    { initialize the various mechanisms }
    begin
    indlevel := 0;
    new (sbufptrs[1]);
    sbufcnt := 1;
    sbufptrs[1]^.free := sbufsize;
    initerm.val[1] := ord('M');
    initerm.val[2] := nullch;
    initerm.len := 1;
    startree(maintree);
    end;

procedure loadall;
    { if a saved-tree file INDEXER.TRE exists, load its values
    into the tree.        }
    var loadtree : file of nchar;

    procedure reload(t:pnode);
    { reload one (sub-)tree from the saved-tree file }
    { the recorded form of one node of a tree is:
        termlength (1..strmax-1),
        that many term bytes in reverse order,
        page numbers as high byte, low byte,
        page number of (zero,zero).
    the file is a sequence of terms as above. a tree ends
    with a byte of zero.  a sub-tree is introduced with a
    byte of strmax.                        }

    var
    x   : str;
    j,fj: strindex;
    p   : pnode;
    k   : integer;
    k1,k2 : 0..255;

    begin
        read(loadtree,j);
        while j<>nullch do begin
        x.len := j;
        for fj := j downto 1 do read(loadtree,x.val[fj]);
        x.val[j+1] := nullch;
        p := insert(t,x);
        repeat
            read(loadtree,k1,k2);
            k := (k1*256)+k2;
            if k<>0 then addpage(p,k)
        until k=0;
        read(loadtree,j);
        if j=strmax then begin { a sub-tree }
            startree(p^.subt);
            reload(p^.subt);
            read(loadtree,j)
        end
        end
    end;

    begin
    assign(loadtree,'INDEXER.TRE');
    loadtree.TRAP := TRUE; { DO NOT ABORT ON MISSING FILE }
    reset(loadtree);
    if loadtree.ERRS = 0 then reload(maintree);
    end;

{-------------------------------------------------------------}
{          routines for phase 3 -- termination          }
{-------------------------------------------------------------}

procedure saveall;
    { save the term-tree in the file INDEXER.TRE so it can
    be reloaded for additions later, if need be. }
    var savetree    : file of nchar;
    x   : str;

    procedure unload(t:pnode);
    { dump the contents of a (sub-) tree to disk in
        "preorder," a sequence such that the exact layout
        of the tree will be reconstructed if the tree is
        reloaded from the file. }
    label 99;
    var j    : strindex;
        p    : pprec;
        k    : integer;
        k1, k2 : nchar;
    begin
        if t^.skip then goto 99; { dump not the phony node }
        stget(t^.iref,x);
        write(savetree,x.len);
        for j:=x.len downto 1 do write(savetree,x.val[j]);
        p := t^.phead;
        while p<>nil do begin
        k := p^.num;
        k1 := k div 256; k2 := k mod 256;
        write(savetree,k1,k2);
        p := p^.next
        end;
        write(savetree,nullch,nullch); { flag end of pages }
        if t^.subt<>nil then begin
        write(savetree,strmax);{ flag start of subtree }
        unload(t^.subt);
        write(savetree,nullch) { flag end of subtree }
        end;
    99: if t^.lson<>nil then unload(t^.lson);
        if t^.rson<>nil then unload(t^.rson);
    end;

    begin
    assign(savetree,'INDEXER.TRE');
    rewrite(savetree);
    unload(maintree);
    write(savetree,nullch)    { flag end of main tree }
    end;

{-------------------------------------------------------------}
{ The main program, at last.....                  }
{-------------------------------------------------------------}

begin
    init;
    loadall;
    load(maintree);
    saveall;
    dump
end.