{ list and tree operations - requires the external declarations for
data structures
ARGUMENT - the item of the list
COMPARISONS - possible results of comparisons
SETOFCOMPARISONS - set of above ordinal type
the package is to be copied to the area of the source code and
recompiled. It expects to find the environment file for the above
data structures and at least the following routines :
function compareargs( leftarg, rightarg : argument ) : comparisons;
function argtexindex( arg : argument ) : integer;
}
CONST
nulllist = NIL;
nulltree = NIL;
TYPE
arglist = ^listnode;
argtree = ^treenode;
treenode = record
parentnode : argtree;
contents : arglist
end;
listnode = record
field : argument;
next : arglist;
subtree : argtree
end;
[GLOBAL] FUNCTION nextinlist( list : arglist ) : arglist;
begin
if list = nulllist then
errorexit('nextinlist','empty list')
else
nextinlist := list^.next
end;
[GLOBAL] FUNCTION firstarg( list : arglist ) : argument;
begin
if list = nulllist then
errorexit('firstlistpointer','empty list')
else
firstarg := list^.field
end;
[GLOBAL] FUNCTION arglistlength( list : arglist ) : integer;
begin
if list = nulllist then
arglistlength := 0
else
arglistlength := arglistlength(nextinlist(list)) + 1
end;
[GLOBAL] FUNCTION leadingnodesubtree( list : arglist ) : argtree;
begin
if list = nulllist then
errorexit('listsubtree','empty list')
else
leadingnodesubtree := list^.subtree
end;
[GLOBAL] FUNCTION listofargsattree( tree : argtree ) : arglist;
begin
if tree = nulltree then
errorexit('listofargsattree','empty tree')
else
listofargsattree := tree^.contents
end;
[GLOBAL] FUNCTION treeisroot( tree : argtree ) : boolean;
begin
if tree = nulltree then
treeisroot := TRUE
else
treeisroot := tree^.parentnode = nulltree
end;
[GLOBAL] FUNCTION parenttree( tree : argtree ) : argtree;
begin
if treeisroot( tree ) then
errorexit('parenttree','tree is root')
else
parenttree := tree^.parentnode
end;
[GLOBAL] PROCEDURE insertarginsortedlist( var list : arglist;
arg : argument; var pointertoarg : arglist );
type
scanstates = (searching, atfrontoflist, positionfound, endoflist);
var
state : scanstates;
p, prevp, newp : arglist;
comp : comparisons;
begin
if list = nulllist then
begin
allocatenewp;
list := newp
end
else
begin
p := list;
comp := compareargs(arg, firstarg(list));
if (comp = lessthan) or (comp = equal) then
state := atfrontoflist
else
begin
state := searching;
repeat
prevp := p;
p := nextinlist(p);
if p = nulllist then
state := endoflist
else
begin
comp := compareargs(arg, firstarg(p));
if (comp = lessthan) or (comp = equal) then
state := positionfound
end
until state <> searching
end;
if comp = equal then
warningmessage('insertarginsortedlist','already in list')
else
case state of
atfrontoflist : begin
allocatenewp;
newp^.next := list;
list := newp
end;
positionfound : begin
allocatenewp;
newp^.next := p;
prevp^.next := newp
end;
endoflist : begin
allocatenewp;
prevp^.next := newp
end
end {case}
end {else}
end;
[GLOBAL] PROCEDURE appendargonlist( var list : arglist; arg : argument );
var
p, prevp, newp : arglist;
begin
if list = nulllist then
begin
new( newp );
newp^.subtree := nulltree;
newp^.field := arg;
newp^.next := nulllist;
list := newp
end
else
begin
p := list;
repeat
prevp := p;
p := nextinlist(p)
until p = nulllist;
new( newp );
newp^.subtree := nulltree;
newp^.field := arg;
newp^.next := nulllist;
prevp^.next := newp
end
end;
[GLOBAL] PROCEDURE preceedargonlist( var list : arglist; arg : argument );
var
newl : arglist;
begin
new(newl);
newl^.subtree := nulltree;
newl^.field := arg;
newl^.next := list;
list := newl
end;
[GLOBAL] FUNCTION listcopy( list: arglist ) : arglist;
var
l : arglist;
procedure prec( list : arglist );
begin
if list = nulllist then
l := nulllist
else
begin
prec( nextinlist(l) );
preceedargonlist( l, firstarg(l))
end
end;
begin
if list = nulllist then
listcopy := nulllist
else
begin
prec( list );
listcopy := l
end
end;
[GLOBAL] FUNCTION reverseoflist( list: arglist ) : arglist;
var
l : arglist;
procedure app( list : arglist );
begin
if list = nulllist then
l := nulllist
else
begin
app( nextinlist(l) );
appendargonlist( l, firstarg(l))
end
end;
begin
if list = nulllist then
reverseoflist := nulllist
else
begin
app( list );
reverseoflist := l
end
end;
[GLOBAL] FUNCTION leadingnodehassubtree( list : arglist ) : boolean;
begin
if list = nulllist then
leadingnodehassubtree := false
else
leadingnodehassubtree := list^.subtree <> nulltree
end;
[GLOBAL] PROCEDURE findarginsortedlist( list : arglist; arg : argument;
var found : boolean;
var pointertoarg : arglist );
type
searchstates = (searching, positionfound, foundlessthanlocation, endoflist);
var
p : arglist;
state : searchstates;
currentarg : argument;
comp : comparisons;
begin
found := false;
if list <> nulllist then
begin
p := list;
state:= searching;
repeat
currentarg := firstarg(p);
comp := compareargs(arg, currentarg);
case comp of
notvalid : errorexit('findarginsortedlist','invalid-comparison');
lessthan : state := foundlessthanlocation;
equal : begin
state := positionfound;
pointertoarg := p;
found := true
end;
greaterthan : nullstatement
end; {case}
if not found then
begin
p := nextinlist(p);
if p = nulllist then
state := endoflist
end
until state <> searching
end
end;
[GLOBAL] PROCEDURE findarginlist( list : arglist; arg : argument;
var found : boolean;
var pointertoarg : arglist );
var
p : arglist;
compare : comparisons;
begin
found := false;
if list <> nulllist then
begin
p := list;
repeat
compare := compareargs( arg, firstarg(p) );
if compare = equal then
begin
found := true;
pointertoarg := p
end
else
p := nextinlist(p)
until (p = nulllist) or (found)
end
end;
[GLOBAL] FUNCTION nargsattreenode( tree : argtree ) : integer;
begin
if tree = nulltree then
nargsattreenode := 0
else
nargsattreenode := arglistlength( tree^.contents )
end;
[GLOBAL] PROCEDURE insertlistintotree( list : arglist; var tree : argtree);
procedure subinsert( list : arglist; var tree : argtree;
parentpointer : arglist );
label
routineexit;
var
newtree : argtree;
found : boolean;
arg : argument;
pointertoarg : arglist;
begin
if list = nulllist then
goto routineexit;
arg := firstarg(list);
if tree = nulltree then
begin
new( newtree );
newtree^.contents := nulllist;
appendargonlist(newtree^.contents, arg);
if parentpointer = nulllist then
newtree^.parentnode := nulltree
else
newtree^.parentnode := parentpointer^.subtree;
subinsert(nextinlist(list), newtree^.contents^.subtree, newtree^.contents);
if parentpointer = nulllist then
tree := newtree
else
parentpointer^.subtree := newtree;
goto routineexit
end;
findarginsortedlist( tree^.contents, arg, found, pointertoarg);
if not found then
insertarginsortedlist(tree^.contents, arg, pointertoarg);
subinsert( nextinlist(list), pointertoarg^.subtree, pointertoarg);
routineexit : nullstatement
end;
begin
subinsert( list, tree, nulllist)
end;
[GLOBAL] PROCEDURE searchtreeforlist( tree : argtree; list : arglist;
var found : boolean; var indexfound, depthfoundat : integer);
procedure subsearch( tree : argtree; list : arglist );
label
routineexit;
var
findsuccessful : boolean;
arg: argument;
pointertoarg : arglist;
begin
if tree = nulltree then
goto routineexit;
if list = nulllist then
goto routineexit;
arg := firstarg(list);
depthfoundat := depthfoundat + 1;
findarginsortedlist(listofargsattree(tree), arg, findsuccessful, pointertoarg);
if findsuccessful then
begin
found := true;
indexfound := argtexindex(firstarg(pointertoarg));
if leadingnodehassubtree(pointertoarg) then
subsearch(leadingnodesubtree(pointertoarg), nextinlist(list))
end;
routineexit : nullstatement
end;
begin {searchtree}
found := false;
indexfound := indexofunknowntexcommand;
if list = nulllist then
warningmessage('searchtree','given empty list')
else
subsearch(tree, list)
end;
[GLOBAL] PROCEDURE padwithnullarguments( var list : arglist; index : integer;
requiredlength : integer );
var
arg : argument;
i, ntoappend : integer;
begin
initarg(arg, [nulltype], blank, index, TRUE);
ntoappend := requiredlength - arglistlength(list);
for i := 1 to ntoappend do
appendargonlist(list, arg)
end;
[GLOBAL] PROCEDURE listtoarray(var list : arglist; index : integer;
var arr : argarray; requiredlength :integer );
var
l : arglist;
i : integer;
begin
if requiredlength > maxargsinarray then
errorexit('listtoarray','array size exceeded');
padwithnullarguments( list, index, requiredlength);
l := list;
for i := 1 to requiredlength do
begin
arr[i] := firstarg(l);
l := nextinlist(l)
end
end;
[GLOBAL] PROCEDURE dlist( var f : text; l : arglist );
const
linelength = 75;
var
nchars : integer;
procedure dl( l : arglist );
var
s : pckstr;
begin
if l = nulllist then
writeln(f)
else
begin
s := argliteral(firstarg(l), true);
if (length(s) + nchars + 1) > linelength then
begin
writeln(f);
nchars := 0
end;
nchars := nchars + length(s) + 1;
write(f, s, blank);
dl( nextinlist(l))
end
end;
begin
nchars := 0;
dl( l )
end;
[GLOBAL] PROCEDURE dtree( var f : text; tree : argtree);
procedure dt( name : pckstr; tree : argtree );
var
l : arglist;
s : pckstr;
begin
if tree <> nulltree then
begin
writeln(f);
writeln(f,'**** "',name,'" NODE HAS ****');
l := listofargsattree(tree);
dlist(f,l);
writeln(f,'**** ',name,' *************');
while l <> nulllist do
begin
if leadingnodehassubtree(l) then
begin
s := argliteral(firstarg(l), true);
dt(s, leadingnodesubtree(l))
end;
l := nextinlist(l)
end
end
end;
begin
dt('<ROOT>', tree)
end;
[HIDDEN] PROCEDURE texwritearg( var f : text; arg : argument);
EXTERN;
[GLOBAL] PROCEDURE writeargarray( var f : text; arr : argarray );
var
i : integer;
begin
for i := 1 to maxargsinarray do
if argclass(arr[i]) <> [nulltype] then
texwritearg(f, arr[i])
end;
[GLOBAL] PROCEDURE makenullarray( var arr : argarray );
var
templist : arglist;
begin
templist := nulllist;
padwithnullarguments(templist, indexofunknowntexcommand, maxargsinarray);
listtoarray( templist, indexofunknowntexcommand, arr, maxargsinarray)
end;
