## red-black-set-g.pkg
# Compiled by:
# src/lib/std/standard.lib# This code is based on Chris Okasaki's implementation of
# red-black trees. The linear-time tree construction code is
# based on the paper "Constructing red-black trees" by Hinze,
# and the drop function is based on the description in Cormen,
# Leiserson, and Rivest.
#
# A red-black tree should satisfy the following two invariants:
#
# Red Invariant: each red node has a black parent.
#
# Black Condition: each path from the root to an empty node has the
# same number of black nodes (the tree's black height).
#
# The Red condition implies that the root is always black and the Black
# condition implies that any node with only one child will be black and
# its child will be a red leaf.
### "Solitary trees,
### if they grow at all,
### grow strong."
###
### -- Winston Churchill
generic package red_black_set_g (k: Key) # Key is from src/lib/src/key.api :
Set # Set is from src/lib/src/set.apiwhere
key == k
{
package key = k;
Item = k::Key;
Color = RED | BLACK;
Tree
= EMPTY
| TREE_NODE ((Color, Tree, Item, Tree));
Set = SET ((Int, Tree));
# Check invariants:
#
fun all_invariants_hold (SET (nodecount, EMPTY))
=>
nodecount == 0;
all_invariants_hold (SET (nodecount, TREE_NODE (RED,_,_,_) ) )
=>
FALSE; # RED root is not ok.
all_invariants_hold (SET (nodecount, tree))
=>
( black_invariant_ok tree
and
red_invariant_ok (TRUE, tree)
and
nodecount_ok (nodecount, tree)
)
where
# Every path from root to any leaf must
# contain the same number of BLACK nodes:
#
fun black_invariant_ok tree
=
{ # Compute the black depth along one
# arbitrary path for reference:
#
black_depth = leftmost_blackdepth (0, tree);
# Check that black depth along all other paths matches:
#
check_blackdepth_on_all_paths (0, tree)
where
fun check_blackdepth_on_all_paths (n, EMPTY)
=>
n == black_depth;
check_blackdepth_on_all_paths (n, TREE_NODE (BLACK, left_subtree,_, right_subtree))
=>
check_blackdepth_on_all_paths (n+1, left_subtree)
and
check_blackdepth_on_all_paths (n+1, right_subtree);
check_blackdepth_on_all_paths (n, TREE_NODE (RED, left_subtree,_, right_subtree))
=>
check_blackdepth_on_all_paths (n, left_subtree)
and
check_blackdepth_on_all_paths (n, right_subtree);
end;
end;
}
where
fun leftmost_blackdepth (n, EMPTY) => n;
leftmost_blackdepth (n, TREE_NODE (RED, left_subtree, _,_)) => leftmost_blackdepth (n, left_subtree);
leftmost_blackdepth (n, TREE_NODE (BLACK, left_subtree, _,_)) => leftmost_blackdepth (n+1, left_subtree);
end;
end;
# A RED node must always have a BLACK parent:
#
fun red_invariant_ok (parent_was_black, EMPTY)
=>
TRUE;
red_invariant_ok (parent_was_black, TREE_NODE (RED, left_subtree, _, right_subtree))
=>
parent_was_black
and
red_invariant_ok (FALSE, left_subtree)
and
red_invariant_ok (FALSE, right_subtree);
red_invariant_ok (parent_was_black, TREE_NODE (BLACK, left_subtree, _, right_subtree))
=>
red_invariant_ok (TRUE, left_subtree)
and
red_invariant_ok (TRUE, right_subtree);
end;
# The count field in the header must
# equal the number of nodes in the tree:
#
fun nodecount_ok (nodecount, tree)
=
nodecount == count_nodes tree
where
fun count_nodes EMPTY
=>
0;
count_nodes (TREE_NODE (_, left_subtree, _, right_subtree))
=>
count_nodes left_subtree
+
count_nodes right_subtree
+
1;
end;
end;
end;
end;
#
fun is_empty (SET(_, EMPTY)) => TRUE;
is_empty _ => FALSE;
end;
empty = SET (0, EMPTY);
#
fun singleton x
=
SET (1, TREE_NODE (RED, EMPTY, x, EMPTY));
#
fun add (SET (n_items, m), x)
=
{ m = case (ins m)
#
TREE_NODE (RED, left_subtree, key, right_subtree)
=>
# Enforce invariant that root is always BLACK.
# (It is always safe to change the root from
# RED to BLACK.)
#
# Since the well-tested SML/NJ code returns
# trees with RED roots, this may not be necessary.
#
TREE_NODE (BLACK, left_subtree, key, right_subtree);
other => other;
esac;
SET (*n_items', m);
}
where
n_items' = REF n_items;
#
fun ins EMPTY
=>
{ n_items' := n_items+1;
TREE_NODE (RED, EMPTY, x, EMPTY);
};
ins (s as TREE_NODE (color, a, y, b))
=>
case (k::compare (x, y))
#
LESS
=>
case a
#
TREE_NODE (RED, c, z, d)
=>
case (k::compare (x, z))
#
LESS => case (ins c)
#
TREE_NODE (RED, e, w, f)
=>
TREE_NODE (RED, TREE_NODE (BLACK, e, w, f), z, TREE_NODE (BLACK, d, y, b));
c => TREE_NODE (BLACK, TREE_NODE (RED, c, z, d), y, b);
esac;
EQUAL => TREE_NODE (color, TREE_NODE (RED, c, x, d), y, b);
GREATER
=>
case (ins d)
#
TREE_NODE (RED, e, w, f)
=>
TREE_NODE (RED, TREE_NODE (BLACK, c, z, e), w, TREE_NODE (BLACK, f, y, b));
d => TREE_NODE (BLACK, TREE_NODE (RED, c, z, d), y, b);
esac;
esac;
_ => TREE_NODE (BLACK, ins a, y, b);
esac;
EQUAL => TREE_NODE (color, a, x, b);
GREATER
=>
case b
#
TREE_NODE (RED, c, z, d)
=>
case (k::compare (x, z))
#
LESS => case (ins c)
#
TREE_NODE (RED, e, w, f)
=>
TREE_NODE (RED, TREE_NODE (BLACK, a, y, e), w, TREE_NODE (BLACK, f, z, d));
c => TREE_NODE (BLACK, a, y, TREE_NODE (RED, c, z, d));
esac;
EQUAL => TREE_NODE (color, a, y, TREE_NODE (RED, c, x, d));
GREATER
=>
case (ins d)
#
TREE_NODE (RED, e, w, f)
=>
TREE_NODE (RED, TREE_NODE (BLACK, a, y, c), z, TREE_NODE (BLACK, e, w, f));
d => TREE_NODE (BLACK, a, y, TREE_NODE (RED, c, z, d));
esac;
esac;
_ => TREE_NODE (BLACK, a, y, ins b);
esac;
esac;
end;
end;
#
fun add' (x, m)
=
add (m, x);
($) = add;
#
fun add_list (s, [])
=>
s;
add_list (s, x ! r)
=>
add_list (add (s, x), r);
end;
fun from_list l
=
add_list (empty, l);
# Remove an item. Raises LibBase::NOT_FOUND if not found.
#
stipulate
Descent_Path
= TOP
| LEFT ((Color, Item, Tree, Descent_Path))
| RIGHT ((Color, Tree, Item, Descent_Path));
#
fun drop' (SET (n_items, input_tree), key_to_remove)
=
{
fun copy_path (TOP, t) => t;
copy_path (LEFT (color, x, b, rest_of_path), a) => copy_path (rest_of_path, TREE_NODE (color, a, x, b));
copy_path (RIGHT (color, a, x, rest_of_path), b) => copy_path (rest_of_path, TREE_NODE (color, a, x, b));
end;
# copy_path' propagates a black deficit up the tree until either the top
# is reached, or the deficit can be covered. It returns a boolean
# that is TRUE if there is still a deficit and the copy_pathped tree.
#
fun copy_path' (TOP, t)
=>
(TRUE, t);
# Nomenclature: In the below diagrams, I use '1B' == "BLACK node containing key1"
# '2R' == "RED node containing key2"
# etc.
# 'X' can match RED or BLACK (but not both) within any given rule.
# 'a', 'b' represent the current node/subtree.
# 'c', 'd', 'e' represent arbitrary other node/subtrees (possibly EMPTY).
#
# For the cited Wikipedia case discussions and diagrams, see
# http://en.wikipedia.org/wiki/Red_black_tree
#
# 1B 2B Wikipedia Case 2
# / \ -> / d
# a 2R 1R
# c d a c
#
#
copy_path' (LEFT (BLACK, key1, TREE_NODE (RED, c, key2, d), path), a) # Case 1L
=>
copy_path' (LEFT (RED, key1, c, LEFT (BLACK, key2, d, path)), a);
#
# We ('a') now have a RED parent and BLACK sibling, so case 4, 5 or 6 will apply.
# 1 1 Wikipedia Case 5
# / \ / \
# a 3B -> a 2B
# 2R e c 3R
# c d d e
#
copy_path' (LEFT (color, key1, TREE_NODE (BLACK, TREE_NODE (RED, c, key2, d), key3, e), path), a) # Case 3L
=>
copy_path' (LEFT (color, key1, TREE_NODE (BLACK, c, key2, TREE_NODE (RED, d, key3, e)), path), a);
# 1X 2X Wikipedia Case 6
# / \ / \
# a 2B -> 1B 3B
# c 3R a c d e
# d e
#
copy_path' (LEFT (color, key1, TREE_NODE (BLACK, c, key2, TREE_NODE (RED, d, key3, e)), path), a) # Case 4L
=>
(FALSE, copy_path (path, TREE_NODE (color, TREE_NODE (BLACK, a, key1, c), key2, TREE_NODE (BLACK, d, key3, e))));
# 1R 1B Wikipedia Case 4
# / \ / \
# a 2B -> a 2R
# c d c d
#
copy_path' (LEFT (RED, key1, TREE_NODE (BLACK, c, key2, d), path), a) # Case 2L
=>
(FALSE, copy_path (path, TREE_NODE (BLACK, a, key1, TREE_NODE (RED, c, key2, d))));
#
# BLACK sib has exchanged color with RED parent;
# this makes up the BLACK deficit on our side
# without affecting black path counts on sib's side,
# so we're done rebalancing and can revert to
# simple path copying for the rest of the way back
# to the root.
# 1B 1B Wikipedia Case 3
# / \ / \
# a 2B -> a 2R
# c d c d
#
copy_path' (LEFT (BLACK, key1, TREE_NODE (BLACK, c, key2, d), path), a) # Case 2L
=>
copy_path' (path, TREE_NODE (BLACK, a, key1, TREE_NODE (RED, c, key2, d)));
#
# Changing BLACK sib to RED locally rebalances in the
# sense that paths through us ('a') and our sib (2)
# both have the same number of BLACK nodes, but our
# subtree as a whole has a BLACK pathcount one lower
# than initially, so we continue the rebalancing
# act in our parent.
# 1B 2B Wikipidia Case 2 (Mirrored)
# / \ / \
# 2R b -> c 1R
# c d d b
# _____
copy_path' (RIGHT (BLACK, TREE_NODE (RED, c, key2, d), key1, path), b) # Case 1R
=>
copy_path' (RIGHT (RED, d, key1, RIGHT (BLACK, c, key2, path)), b);
#
# We ('b') now have a RED parent and BLACK sibling, so mirrored case 4, 5 or 6 will apply.
# 1X 2X Wikipedia Case 6 (Mirrored)
# / \ / \
# 2B b -> 3B 1B
# 3R e c d e b
# c d
#
copy_path' (RIGHT (color, TREE_NODE (BLACK, TREE_NODE (RED, c, key3, d), key2, e), key1, path), b) # Case 3R
=>
(FALSE, copy_path (path, TREE_NODE (color, TREE_NODE (BLACK, c, key3, d), key2, TREE_NODE (BLACK, e, key1, b))));
# OLD BROKEN CODE copy_path' (RIGHT (color, TREE_NODE (BLACK, c, key3, TREE_NODE (RED, d, key2, e)), key1, path), b);
# 1 1 Wikipedia Case 5 (Mirrored)
# / \ / \
# 2B b -> 3B b
# c 3R 2R e
# d e c d
#
copy_path' (RIGHT (color, TREE_NODE (BLACK, c, key2, TREE_NODE (RED, d, key3, e)), key1, path), b) # Case 4R
=>
copy_path' (RIGHT (color, TREE_NODE (BLACK, TREE_NODE (RED, c, key2, d), key3, e), key1, path), b);
# OLD BROKEN CODE (FALSE, copy_path (path, TREE_NODE (color, c, key2, TREE_NODE (BLACK, TREE_NODE (RED, d, key3, e), key1, b))));
# 1R 1B Wikipedia Case 4 (Mirrored)
# / \ / \
# 2B b -> 2R b
# c d c d
#
copy_path' (RIGHT (RED, TREE_NODE (BLACK, c, key2, d), key1, path), b) # Case 2R
=>
(FALSE, copy_path (path, TREE_NODE (BLACK, TREE_NODE (RED, c, key2, d), key1, b)));
#
# BLACK sib has exchanged color with RED parent;
# this makes up the BLACK deficit on our side
# without affecting black path counts on sib's side,
# so we're done rebalancing and can revert to
# simple path copying for the rest of the way back
# to the root.
# 1B 1B Wikipedia Case 3 (Mirrored)
# / \ / \
# 2B b -> 2R b
# c d c d
#
copy_path' (RIGHT (BLACK, TREE_NODE (BLACK, c, key2, d), key1, path), b) # Case 2R
=>
copy_path' (path, TREE_NODE (BLACK, TREE_NODE (RED, c, key2, d), key1, b));
copy_path' (path, t)
=>
(FALSE, copy_path (path, t));
end;
# Here's our routine for the descent phase.
#
# Arguments:
# key_to_drop: key identifying which node to delete
# current_subtree: Subtree to search, using "in-order": Left subtree first, then this node, then right subtree.
# descent_path: Stack of values recording our descent path to date.
#
fun descend (key_to_drop, EMPTY, descent_path)
=>
raise exception lib_base::NOT_FOUND;
descend (key_to_drop, TREE_NODE (color, left_subtree, key, right_subtree), descent_path)
=>
case (key::compare (key_to_drop, key))
#
LESS => descend (key_to_drop, left_subtree, LEFT (color, key, right_subtree, descent_path));
GREATER => descend (key_to_drop, right_subtree, RIGHT (color, left_subtree, key, descent_path));
EQUAL => join (color, left_subtree, right_subtree, descent_path);
esac;
end
# Once we've found and removed the requested node,
# we are left with the problem of combining its
# former left and right subtrees into a replacement
# for the node -- while preserving or restoring
# our RED/BLACK invariants. That's our job here.
#
# Arguments:
# color: Color of now-deleted node.
# left_subtree: Left subtree of now-deleted node.
# right_subtree: Right subtree of now-deleted node.
# descent_path: Path by which we reached now-deleted node.
# (To us at this point the descent_path reperesents
# the worklist of nodes to duplicate in order to
# produce the result tree.)
#
also
fun join (RED, EMPTY, EMPTY, descent_path) => copy_path (descent_path, EMPTY );
join (RED, left_subtree, EMPTY, descent_path) => copy_path (descent_path, left_subtree );
join (RED, EMPTY, right_subtree, descent_path) => copy_path (descent_path, right_subtree );
join (BLACK, left_subtree, EMPTY, descent_path) => #2 (copy_path' (descent_path, left_subtree));
join (BLACK, EMPTY, right_subtree, descent_path) => #2 (copy_path' (descent_path, right_subtree));
join (color, left_subtree, right_subtree, descent_path)
=>
{ # We have two non-empty children.
#
# We bubble up a key to fill this node,
# creating a delete-node problem below which is
# guaranteed to have at most one nonempty child:
#
# Replace deleted key with
# key from first node in our
# right subtree:
#
replacement_key = min_key right_subtree;
# Now, act as though the delete never happened:
# just continue our descent, with replacement_key in
# right subtree as our new delete target:
#
descend( replacement_key, right_subtree, RIGHT (color, left_subtree, replacement_key, descent_path) );
}
where
#
fun min_key (TREE_NODE (_, EMPTY, key, _)) => key;
min_key (TREE_NODE (_, left_subtree, _, _)) => min_key left_subtree;
min_key EMPTY => raise exception MATCH; # "Impossible"
end;
end;
end;
new_tree
=
case (descend (key_to_remove, input_tree, TOP))
#
# Enforce the invariant that
# the root node is always BLACK:
#
TREE_NODE (RED, left_subtree, key, right_subtree)
=>
TREE_NODE (BLACK, left_subtree, key, right_subtree);
ok => ok;
esac;
SET (n_items - 1, new_tree);
# #
# fun del_min (TREE_NODE (RED, EMPTY, y, b), z) => (y, (FALSE, copy_path (z, b)));
# del_min (TREE_NODE (BLACK, EMPTY, y, b), z) => (y, copy_path' (z, b));
# del_min (TREE_NODE (color, a, y, b), z) => del_min (a, LEFT (color, y, b, z));
# del_min (EMPTY, _) => raise exception MATCH;
# end;
# #
# fun join (RED, EMPTY, EMPTY, z) => copy_path (z, EMPTY);
# join ( _, a, EMPTY, z) => #2 (copy_path' (z, a)); # Color = black
# join ( _, EMPTY, b, z) => #2 (copy_path' (z, b)); # Color = black
#
# join (color, a, b, z)
# =>
# { (del_min (b, TOP))
# ->
# (x, (need_b, b'));
#
# if need_b #2 (copy_path' (z, TREE_NODE (color, a, x, b')));
# else copy_path (z, TREE_NODE (color, a, x, b')) ;
# fi;
# };
# end;
# #
# fun del (EMPTY, z)
# =>
# raise exception lib_base::NOT_FOUND;
#
# del (TREE_NODE (color, a, y, b), z)
# =>
# case (k::compare (k, y))
# LESS => del (a, LEFT (color, y, b, z));
# EQUAL => join (color, a, b, z);
# GREATER => del (b, RIGHT (color, a, y, z));
# esac;
# end;
# SET (n_items - 1, del (t, TOP));
};
herein
fun drop (input, key_to_remove)
=
drop' (input, key_to_remove)
except
lib_base::NOT_FOUND = input;
end; # stipulate
# Return TRUE if and only if item is an element in the set
#
fun member (SET(_, t), k)
=
{ fun find' EMPTY
=>
FALSE;
find' (TREE_NODE(_, a, y, b))
=>
case (k::compare (k, y))
#
LESS => find' a;
EQUAL => TRUE;
GREATER => find' b;
esac;
end;
find' t;
};
fun preceding_member (SET(_, t), k)
=
get' (t, NULL)
where
fun maxkey (EMPTY, result)
=>
result;
maxkey (TREE_NODE(_, a, y, b), result)
=>
maxkey (b, THE y);
end;
fun get' (EMPTY, result)
=>
result;
get' (TREE_NODE(_, a, y, b), result)
=>
case (key::compare (k, y))
#
LESS => get' (a, result);
EQUAL => maxkey(a, result);
GREATER => get' (b, THE y);
esac;
end;
end;
fun following_member (SET(_, t), k)
=
get' (t, NULL)
where
fun minkey (EMPTY, result)
=>
result;
minkey (TREE_NODE(_, a, y, b), result)
=>
minkey (a, THE y);
end;
fun get' (EMPTY, result)
=>
result;
get' (TREE_NODE(_, a, y, b), result)
=>
case (key::compare (k, y))
#
LESS => get' (a, THE y);
EQUAL => minkey(b, result);
GREATER => get' (b, result);
esac;
end;
end;
# Return the number of items in the map:
#
fun vals_count (SET (n, _))
=
n;
#
fun fold_forward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, x, b), accum)
=>
foldf (b, f (x, foldf (a, accum)));
end;
\\ init
=
\\ (SET(_, m))
=
foldf (m, init);
};
#
fun fold_backward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, x, b), accum)
=>
foldf (a, f (x, foldf (b, accum)));
end;
\\ init
=
\\ (SET(_, m))
=
foldf (m, init);
};
# Return an ordered list of the items in the set.
#
fun vals_list s
=
fold_backward
(\\ (x, l) = x ! l)
[]
s;
# Functions for walking the tree
# while keeping a stack of parents
# to be visited.
#
fun next ((t as TREE_NODE(_, _, _, b)) ! rest)
=>
(t, left (b, rest));
next _
=>
(EMPTY, []);
end
also
fun left (EMPTY, rest)
=>
rest;
left (t as TREE_NODE(_, a, _, _), rest)
=>
left (a, t ! rest);
end;
#
fun start m
=
left (m, []);
# Return TRUE if and only if the two sets are equal
#
fun equal (SET(_, s1), SET(_, s2))
=
compare (start s1, start s2)
where
fun compare (t1, t2)
=
case (next t1, next t2)
#
((EMPTY, _), (EMPTY, _)) => TRUE;
((EMPTY, _), _ ) => FALSE;
(_, (EMPTY, _ )) => FALSE;
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
EQUAL => compare (r1, r2);
_ => FALSE;
esac;
esac;
end;
# Return the lexical order of two sets:
#
fun compare (SET(_, s1), SET(_, s2))
=
compare (start s1, start s2)
where
fun compare (t1, t2)
=
case (next t1, next t2)
#
((EMPTY, _), (EMPTY, _)) => EQUAL;
((EMPTY, _), _) => LESS;
(_, (EMPTY, _ )) => GREATER;
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
EQUAL => compare (r1, r2);
order => order;
esac;
esac;
end;
# Return TRUE if and only if the
# first set is a subset of the second:
#
fun is_subset (SET(_, s1), SET(_, s2))
=
compare (start s1, start s2)
where
fun compare (t1, t2)
=
case (next t1, next t2)
#
((EMPTY, _), (EMPTY, _)) => TRUE;
((EMPTY, _), _) => TRUE;
(_, (EMPTY, _)) => FALSE;
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
LESS => FALSE;
EQUAL => compare (r1, r2);
GREATER => compare (t1, r2);
esac;
esac;
end;
# Support for constructing red-black trees
# in linear time from increasing ordered
# sequences (based on a description by RED. Hinze).
# Note that the elements in the digits are
# ordered with the largest on the left,
# whereas the elements of the trees are
# ordered with the largest on the right.
#
Digit
= ZERO
| ONE ((Item, Tree, Digit))
| TWO ((Item, Tree, Item, Tree, Digit))
;
# Add an item that is guaranteed to be larger than any in l
#
fun add_item (a, l)
=
incr (a, EMPTY, l)
where
fun incr (a, t, ZERO) => ONE (a, t, ZERO);
incr (a1, t1, ONE (a2, t2, r)) => TWO (a1, t1, a2, t2, r);
incr (a1, t1, TWO (a2, t2, a3, t3, r))
=>
ONE (a1, t1, incr (a2, TREE_NODE (BLACK, t3, a3, t2), r));
end;
end;
# Link the digits into a tree
#
fun link_all t
=
link (EMPTY, t)
where
fun link (t, ZERO) => t;
link (t1, ONE (a, t2, r)) => link (TREE_NODE(BLACK, t2, a, t1), r);
link (t, TWO (a1, t1, a2, t2, r))
=>
link (TREE_NODE(BLACK, TREE_NODE (RED, t2, a2, t1), a1, t), r);
end;
end;
# Return the union of the two sets:
#
fun union (SET(_, s1), SET(_, s2))
=
{ fun ins ((EMPTY, _), n, result)
=>
(n, result);
ins ((TREE_NODE(_, _, x, _), r), n, result)
=>
ins (next r, n+1, add_item (x, result));
end;
#
fun union' (t1, t2, n, result)
=
case (next t1, next t2)
#
((EMPTY, _), (EMPTY, _)) => (n, result);
((EMPTY, _), t2 ) => ins (t2, n, result);
(t1, (EMPTY, _) ) => ins (t1, n, result);
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
LESS => union' (r1, t2, n+1, add_item (x, result));
EQUAL => union' (r1, r2, n+1, add_item (x, result));
GREATER => union' (t1, r2, n+1, add_item (y, result));
esac;
esac;
my (n, result)
=
union' (start s1, start s2, 0, ZERO);
SET (n, link_all result);
};
# Set intersection
#
fun intersection (SET(_, s1), SET(_, s2))
=
{ fun intersect (t1, t2, n, result)
=
case (next t1, next t2)
#
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
LESS => intersect (r1, t2, n, result);
EQUAL => intersect (r1, r2, n+1, add_item (x, result));
GREATER => intersect (t1, r2, n, result);
esac;
_ => (n, result);
esac;
my (n, result)
=
intersect (start s1, start s2, 0, ZERO);
SET (n, link_all result);
};
# Set difference
#
fun difference (SET(_, s1), SET(_, s2))
=
{ fun ins ((EMPTY, _), n, result)
=>
(n, result);
ins ((TREE_NODE(_, _, x, _), r), n, result)
=>
ins (next r, n+1, add_item (x, result));
end;
#
fun diff (t1, t2, n, result)
=
case (next t1, next t2)
#
((EMPTY, _), _ ) => (n, result);
(t1, (EMPTY, _)) => ins (t1, n, result);
((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
=>
case (key::compare (x, y))
#
LESS => diff (r1, t2, n+1, add_item (x, result));
EQUAL => diff (r1, r2, n, result);
GREATER => diff (t1, r2, n, result);
esac;
esac;
my (n, result)
=
diff (start s1, start s2, 0, ZERO);
SET (n, link_all result);
};
#
fun apply f
=
{ fun appf EMPTY => ();
appf (TREE_NODE(_, a, x, b))
=>
{ appf a;
f x;
appf b;
};
end;
\\ (SET(_, m))
=
appf m;
};
#
fun map f
=
{ fun addf (x, m)
=
add (m, f x);
fold_forward addf empty;
};
# Filter out those elements of the set that do not satisfy the
# predicate. The filtering is done in increasing map order.
#
fun filter prior (SET(_, t))
=
{ fun walk (EMPTY, n, result)
=>
(n, result);
walk (TREE_NODE(_, a, x, b), n, result)
=>
{ my (n, result) = walk (a, n, result);
if (prior x) walk (b, n+1, add_item (x, result));
else walk (b, n, result); fi;
};
end;
my (n, result)
=
walk (t, 0, ZERO);
SET (n, link_all result);
};
#
fun partition prior (SET(_, t))
=
{ fun walk (EMPTY, n1, result1, n2, result2)
=>
(n1, result1, n2, result2);
walk (TREE_NODE(_, a, x, b), n1, result1, n2, result2)
=>
{ my (n1, result1, n2, result2)
=
walk (a, n1, result1, n2, result2);
if (prior x) walk (b, n1+1, add_item (x, result1), n2, result2);
else walk (b, n1, result1, n2+1, add_item (x, result2)); fi;
};
end;
my (n1, result1, n2, result2)
=
walk (t, 0, ZERO, 0, ZERO);
( SET (n1, link_all result1),
SET (n2, link_all result2)
);
};
#
fun exists prior
=
{ fun test EMPTY => FALSE;
test (TREE_NODE(_, a, x, b))
=>
test a or prior x or test b;
end;
\\ (SET(_, t))
=
test t;
};
#
fun all prior
=
{ fun test EMPTY => TRUE;
test (TREE_NODE(_, a, x, b))
=>
test a and prior x and test b;
end;
\\ (SET(_, t))
=
test t;
};
#
fun find prior
=
{ fun test EMPTY => NULL;
test (TREE_NODE(_, a, x, b))
=>
case (test a)
#
NULL => if (prior x ) THE x; else test b;fi;
some_item => some_item;
esac;
end;
\\ (SET(_, t))
=
test t;
};
};