# Mythryl-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
# Compiled by:
# src/app/yacc/src/mythryl-yacc.lib# Implementation of ordered sets using ordered lists and red-black trees. The
# code for red-black trees was originally written by Norris Boyd, which was
# modified for use here.
# ordered sets implemented using ordered lists.
#
# Upper bound running times for functions implemented here:
#
# apply = O (n)
# card = O (n)
# closure = O (n^2)
# difference = O (n+m), where n, m = the size of the two sets used here.
# empty = O (1)
# exists = O (n)
# find = O (n)
# fold = O (n)
# set = O (n)
# is_empty = O (1)
# make_list = O (1)
# make_set = O (n^2)
# partition = O (n)
# remove = O (n)
# revfold = O (n)
# select_arb = O (1)
# set_eq = O (n), where n = the cardinality of the smaller set
# set_gt = O (n), ditto
# singleton = O (1)
# union = O (n+m)
### "I hear and I forget.
### I see and I remember.
### I do and I understand."
###
### -- Confucius
generic package list_ord_set_g (b: api { Element;
gt: (Element, Element) -> Bool;
eq: (Element, Element) -> Bool;
}
)
: (weak) Set # Set is from src/app/yacc/src/utils.api{
Element = b::Element;
elem_gt = b::gt;
elem_eq = b::eq;
Set = List( Element );
exception SELECT_ARB;
empty = NIL;
fun set (key, s)
=
f s
where
fun f (l as (h ! t))
=>
if (elem_gt (key, h)) h ! (f t);
elif (elem_eq (key, h)) key ! t;
else key ! l;
fi;
f NIL => [key];
end;
end;
fun select_arb NIL => raise exception SELECT_ARB;
select_arb (a ! b) => a;
end;
fun exists (key, s)
=
f s
where
fun f (h ! t) => if (elem_gt (key, h)) f t;
else elem_eq (h, key);
fi;
f NIL => FALSE;
end;
end;
fun find (key, s)
=
f s
where
fun f (h ! t) => if (elem_gt (key, h)) f t;
elif (elem_eq (h, key)) THE h;
else NULL;
fi;
f NIL => NULL;
end;
end;
fun revfold f lst init = list::fold_forward f init lst;
fun fold f lst init = list::fold_backward f init lst;
apply = list::apply;
fun set_eq (h ! t, h' ! t')
=>
case (elem_eq (h, h'))
TRUE => set_eq (t, t');
a => a;
esac;
set_eq (NIL, NIL) => TRUE;
set_eq _ => FALSE;
end;
fun set_gt (h ! t, h' ! t')
=>
case (elem_gt (h, h'))
FALSE => case (elem_eq (h, h'))
TRUE => set_gt (t, t');
a => a;
esac;
a => a;
esac;
set_gt(_ ! _, NIL) => TRUE;
set_gt _ => FALSE;
end;
fun union (a as (h ! t), b as (h' ! t'))
=>
if (elem_gt (h', h)) h ! union (t, b);
elif (elem_eq (h, h')) h ! union (t, t');
else h' ! union (a, t');
fi;
union (NIL, s) => s;
union (s, NIL) => s;
end;
fun make_list s
=
s;
fun is_empty NIL => TRUE;
is_empty _ => FALSE;
end;
fun make_set l
=
list::fold_backward set [] l;
fun partition f s
=
fold
(\\ (e, (yes, no))
=
if (f e) (e ! yes, no);
else (e ! no, yes);
fi
)
s
(NIL, NIL);
fun remove (e, s)
=
f s
where
fun f (l as (h ! t)) => if (elem_gt (h, e) ) l;
elif (elem_eq (h, e) ) t;
else h ! (f t);
fi;
f NIL => NIL;
end;
end;
# Difference: X-Y
fun difference (NIL, _) => NIL;
difference (r, NIL) => r;
difference (a as (h ! t), b as (h' ! t'))
=>
if (elem_gt (h', h) ) h ! difference (t, b);
elif (elem_eq (h', h) ) difference (t, t');
else difference (a, t');
fi;
end;
fun singleton x
=
[x];
fun card (s)
=
fold (\\ (a, count) = count+1) s 0;
stipulate
fun closure'(from, f, result)
=
if (is_empty from)
result;
else
my (more, result)
=
fold
(\\ (a, (more', result'))
=
{ more = f a;
new = difference (more, result);
(union (more', new), union (result', new));
}
)
from
(empty, result);
closure' (more, f, result);
fi;
herein
fun closure (start, f)
=
closure' (start, f, start);
end;
};
# ordered set implemented using red-black trees:
#
# Upper bound running time of the functions below:
#
# apply: O (n)
# card: O (n)
# closure: O (n^2 ln n)
# difference: O (n ln n)
# empty: O (1)
# exists: O (ln n)
# find: O (ln n)
# fold: O (n)
# set: O (ln n)
# is_empty: O (1)
# make_list: O (n)
# make_set: O (n ln n)
# partition: O (n ln n)
# remove: O (n ln n)
# revfold: O (n)
# select_arb: O (1)
# set_eq: O (n)
# set_gt: O (n)
# singleton: O (1)
# union: O (n ln n)
generic package redblack_ord_set_g (b: api { Element;
eq: ((Element, Element)) -> Bool;
gt: ((Element, Element)) -> Bool;
}
)
: (weak) Set # Set is from src/app/yacc/src/utils.api=
package {
Element = b::Element;
elem_gt = b::gt;
elem_eq = b::eq;
Color = RED | BLACK;
stipulate
Set = EMPTY | TREE ((b::Element, Color, Set, Set)); # Start of abstype-replacement recipe -- see http://successor-ml.org/index.php?title=Degrade_abstype_to_derived_form
herein #
Set = Set; # End of abstype-replacement recipe.
exception SELECT_ARB;
empty = EMPTY;
fun set (key, t)
=
{ fun f EMPTY
=>
TREE (key, RED, EMPTY, EMPTY);
f (TREE (k, BLACK, l, r))
=>
if (elem_gt (key, k))
case (f r)
r as TREE (rk, RED, rl as TREE (rlk, RED, rll, rlr), rr)
=>
case l
TREE (lk, RED, ll, lr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (rlk, BLACK, TREE (k, RED, l, rll),
TREE (rk, RED, rlr, rr));
esac;
r as TREE (rk, RED, rl, rr as TREE (rrk, RED, rrl, rrr))
=>
case l
TREE (lk, RED, ll, lr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (rk, BLACK, TREE (k, RED, l, rl), rr);
esac;
r => TREE (k, BLACK, l, r);
esac;
elif (elem_gt (k, key))
case (f l)
l as TREE (lk, RED, ll, lr as TREE (lrk, RED, lrl, lrr))
=>
case r
TREE (rk, RED, rl, rr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (lrk, BLACK, TREE (lk, RED, ll, lrl),
TREE (k, RED, lrr, r));
esac;
l as TREE (lk, RED, ll as TREE (llk, RED, lll, llr), lr)
=>
case r
TREE (rk, RED, rl, rr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (lk, BLACK, ll, TREE (k, RED, lr, r));
esac;
l =>
TREE (k, BLACK, l, r);
esac;
else
TREE (key, BLACK, l, r);
fi;
f (TREE (k, RED, l, r))
=>
if (elem_gt (key, k)) TREE (k, RED, l, f r);
elif (elem_gt (k, key)) TREE (k, RED, f l, r);
else TREE (key, RED, l, r);
fi;
end;
case (f t)
TREE (k, RED, l as TREE(_, RED, _, _), r) => TREE (k, BLACK, l, r);
TREE (k, RED, l, r as TREE(_, RED, _, _)) => TREE (k, BLACK, l, r);
t => t;
esac;
};
fun select_arb (TREE (k, _, l, r)) => k;
select_arb EMPTY => raise exception SELECT_ARB;
end;
fun exists (key, t)
=
get t
where
fun get EMPTY
=>
FALSE;
get (TREE (k, _, l, r))
=>
if (elem_gt (k, key)) get l;
elif (elem_gt (key, k)) get r;
else TRUE;
fi;
end;
end;
fun find (key, t)
=
get t
where
fun get EMPTY
=>
NULL;
get (TREE (k, _, l, r))
=>
if (elem_gt (k, key)) get l;
elif (elem_gt (key, k)) get r;
else THE k;
fi;
end;
end;
fun revfold f t start
=
scan (t, start)
where
fun scan (EMPTY, value) => value;
scan (TREE (k, _, l, r), value) => scan (r, f (k, scan (l, value)));
end;
end;
fun fold f t start
=
scan (t, start)
where
fun scan (EMPTY, value) => value;
scan (TREE (k, _, l, r), value) => scan (l, f (k, scan (r, value)));
end;
end;
fun apply f t
=
scan t
where
fun scan EMPTY => ();
scan (TREE (k, _, l, r)) => { scan l; f k; scan r;};
end;
end;
# equal_tree: test if two trees are equal.
#
# Two trees are equal if
# the set of leaves are equal:
#
fun set_eq (tree1 as (TREE _), tree2 as (TREE _))
=>
{ Pos = LLL | RRR | MMM;
exception DONE;
fun getvalue (stack as ((a, position) ! b))
=>
case a
(TREE (k, _, l, r))
=>
case position
LLL => getvalue ((l, LLL) ! (a, MMM) ! b);
MMM => (k, case r EMPTY => b; _ => (a, RRR) ! b; esac);
RRR => getvalue ((r, LLL) ! b);
esac;
EMPTY => getvalue b;
esac;
getvalue NIL
=>
raise exception DONE;
end;
fun f (NIL, NIL)
=>
TRUE;
f (s1 as (_ ! _), s2 as (_ ! _ ))
=>
{ my (v1, news1) = getvalue s1;
my (v2, news2) = getvalue s2;
elem_eq (v1, v2)
and
f (news1, news2);
};
f _ => FALSE;
end;
f ((tree1, LLL) ! NIL, (tree2, LLL) ! NIL)
except
DONE = FALSE;
};
set_eq (EMPTY, EMPTY) => TRUE;
set_eq _ => FALSE;
end;
# gt_tree: Test if tree1 is greater than tree 2
#
fun set_gt (tree1, tree2)
=
{ Pos = LLL | RRR | MMM;
exception DONE;
fun getvalue (stack as ((a, position) ! b))
=>
case a
(TREE (k, _, l, r))
=>
case position
LLL => getvalue ((l, LLL) ! (a, MMM) ! b);
MMM => (k, case r EMPTY => b; _ => (a, RRR) ! b; esac);
RRR => getvalue ((r, LLL) ! b);
esac;
EMPTY => getvalue b;
esac;
getvalue NIL
=>
raise exception DONE;
end;
fun f (NIL, NIL)
=>
FALSE;
f (s1 as (_ ! _), s2 as (_ ! _ ))
=>
{ my (v1, news1) = getvalue s1;
my (v2, news2) = getvalue s2;
elem_gt (v1, v2)
or
( elem_eq (v1, v2)
and
f (news1, news2)
);
};
f (_, NIL) => TRUE;
f (NIL, _) => FALSE;
end;
f ((tree1, LLL) ! NIL, (tree2, LLL) ! NIL)
except
DONE = FALSE;
};
fun is_empty sss
=
{ select_arb sss;
FALSE;
}
except
SELECT_ARB = TRUE;
fun make_list s
=
fold (!) s NIL;
fun make_set l
=
list::fold_backward set empty l;
fun partition f s
=
fold
(\\ (a, (yes, no))
=
if (f a) (set (a, yes), no);
else (yes, set (a, no));
fi
)
s
(empty, empty);
fun remove (x, xset)
=
{ my (yset, _)
=
partition (\\ a = not (elem_eq (x, a))) xset;
yset;
};
fun difference (xs, ys)
=
fold
(\\ (p as (a, xs'))
=
if (exists (a, ys)) xs';
else set p;
fi
)
xs
empty;
fun singleton x
=
set (x, empty);
fun card s
=
fold
(\\ (_, count) = count+1)
s
0;
fun union (xs, ys)
=
fold set xs ys;
stipulate
fun closure'(from, f, result)
=
if (is_empty from)
result;
else
my (more, result)
=
fold
(\\ (a, (more', result'))
=
{ more = f a;
new = difference (more, result);
(union (more', new), union (result', new));
}
)
from
(empty, result);
closure'
(more, f, result);
fi;
herein
fun closure (start, f)
=
closure'(start, f, start);
end;
end;
};
# In utils.api
# api Table =
# api
# type Table(X)
# type Key
# my size: Table(X) -> Int
# my empty: Table(X)
# my exists: (Key * Table(X)) -> Bool
# my find: (Key * Table(X)) -> Null_Or(X)
# my set: ((Key * X) * Table(X)) -> Table(X)
# my make_table: List (Key * X ) -> Table(X)
# my make_list: Table(X) -> List (Key * X)
# my fold: ((Key * X) * Y -> Y) -> Table(X) -> Y -> Y
# end
generic package table_g (b: api { Key;
gt: ((Key, Key)) -> Bool;
}
)
: (weak) Table # Table is from src/app/yacc/src/utils.api=
package {
Color = RED | BLACK;
Key = b::Key;
stipulate
Table(X) = EMPTY # Start of abstype-replacement recipe -- see http://successor-ml.org/index.php?title=Degrade_abstype_to_derived_form
| TREE ((((b::Key, X) ), Color, Table(X), Table(X)) ) #
; #
herein #
Table(X) = Table(X); # End of abstype-replacement recipe.
empty = EMPTY;
fun set (element as (key, data), t)
=
{ key_gt = \\ (a, _) => b::gt (key, a); end ;
key_lt = \\ (a, _) => b::gt (a, key); end ;
fun f EMPTY
=> TREE (element, RED, EMPTY, EMPTY);
f (TREE (k, BLACK, l, r))
=>
if (key_gt k)
case (f r)
r as TREE (rk, RED, rl as TREE (rlk, RED, rll, rlr), rr)
=>
case l
TREE (lk, RED, ll, lr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (rlk, BLACK, TREE (k, RED, l, rll),
TREE (rk, RED, rlr, rr));
esac;
r as TREE (rk, RED, rl, rr as TREE (rrk, RED, rrl, rrr))
=>
case l
TREE (lk, RED, ll, lr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (rk, BLACK, TREE (k, RED, l, rl), rr);
esac;
r => TREE (k, BLACK, l, r);
esac;
elif (key_lt k)
case (f l)
l as TREE (lk, RED, ll, lr as TREE (lrk, RED, lrl, lrr))
=>
case r
TREE (rk, RED, rl, rr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (lrk, BLACK, TREE (lk, RED, ll, lrl),
TREE (k, RED, lrr, r));
esac;
l as TREE (lk, RED, ll as TREE (llk, RED, lll, llr), lr)
=>
case r
TREE (rk, RED, rl, rr)
=>
TREE (k, RED, TREE (lk, BLACK, ll, lr),
TREE (rk, BLACK, rl, rr));
_ =>
TREE (lk, BLACK, ll, TREE (k, RED, lr, r));
esac;
l =>
TREE (k, BLACK, l, r);
esac;
else
TREE (element, BLACK, l, r);
fi;
f (TREE (k, RED, l, r))
=>
if (key_gt k ) TREE (k, RED, l, f r);
elif (key_lt k ) TREE (k, RED, f l, r);
else TREE (element, RED, l, r);
fi;
end; # fun f
case (f t)
TREE (k, RED, l as TREE(_, RED, _, _), r) => TREE (k, BLACK, l, r);
TREE (k, RED, l, r as TREE(_, RED, _, _)) => TREE (k, BLACK, l, r);
t => t;
esac;
};
fun exists (key, t)
=
get t
where
fun get EMPTY
=>
FALSE;
get (TREE((k, _), _, l, r))
=>
if (b::gt (k, key)) get l;
elif (b::gt (key, k)) get r;
else TRUE;
fi;
end;
end;
fun find (key, t)
=
get t
where
fun get EMPTY
=>
NULL;
get (TREE((k, data), _, l, r))
=>
if (b::gt (k, key)) get l;
elif (b::gt (key, k)) get r;
else THE data;
fi;
end;
end;
fun fold f t start
=
scan (t, start)
where
fun scan (EMPTY, value)
=>
value;
scan (TREE (k, _, l, r), value)
=>
scan (l, f (k, scan (r, value)));
end;
end;
fun make_table l
=
list::fold_backward set empty l;
fun size s
=
fold (\\ (_, count) = count+1) s 0;
fun make_list table
=
fold (!) table NIL;
end;
};
# assumes that a generic table_g with api Table from table.pkg is
# in the dictionary
# In utils.api
# api Hash =
# api
# type Table
# type Element
#
# my size: Table -> Int
# my add: Element * Table -> Table
# my find: Element * Table -> Null_Or( Int )
# my exists: Element * Table -> Bool
# my empty: Table
# end
# hash: creates a hashtable of size n which assigns each distinct member
# a unique integer between 0 and n-1
generic package typelocked_hashtable_g (b: api { Element;
gt: (Element, Element) -> Bool;
}
)
: (weak) Hash # Hash is from src/app/yacc/src/utils.api{
Element = b::Element;
package hashtable
=
table_g (
Key=b::Element;
gt = b::gt;
);
Table
=
{ count: Int,
table: hashtable::Table( Int )
};
empty = { count => 0,
table => hashtable::empty
};
fun size { count, table }
=
count;
fun add (e, { count, table } )
=
{ count => count+1,
table => hashtable::set((e, count), table)
};
fun find (e, { table, count } )
=
hashtable::find (e, table);
fun exists (e, { table, count } )
=
hashtable::exists (e, table);
};