## red-black-numbered-set-g.pkg
# Compiled by:
# src/lib/std/standard.lib# Unit test code in:
# src/lib/src/red-black-numbered-set-generic-unit-test.pkg# This package implements the converse idea to
#
# src/lib/src/red-black-numbered-list.pkg#
# Here we store an arbitrary set of ordered values into
# a red-black tree, and then use per-node subtree-size
# fields to answer in O(log(N)) time the question
# "How many keys come before this key in sequence order?"
# 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 Ralf Hinze,
# http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
# and the delete 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.
generic package red_black_numbered_set_g (k: Key) # Key is from src/lib/src/key.api:
Numbered_Set # Numbered_Set is from src/lib/src/numbered-set.api where key == k
{
package key = k;
Color
=
RED | BLACK;
# Internal tree node:
#
Tree
= EMPTY
| TREE_NODE ( ( Color,
Tree, # Left subtree.
key::Key, # Key.
Int, # keycount -- number of keys/nodes in this subtree.
Tree # Right subtree.
) );
# Header node. Every complete
# map is represented by one:
#
Numbered_Set
=
NUMBERED_SET (
( Tree # Tree containing one node per key pair in numbering.
)
);
#
fun is_empty (NUMBERED_SET EMPTY) => TRUE;
is_empty _ => FALSE;
end;
empty = NUMBERED_SET EMPTY;
#
fun singleton key
=
NUMBERED_SET (TREE_NODE (RED, EMPTY, key, 1, EMPTY));
# Check invariants:
#
fun all_invariants_hold (NUMBERED_SET EMPTY)
=>
TRUE;
all_invariants_hold (NUMBERED_SET (TREE_NODE (RED,_,_,_,_) ) )
=>
FALSE; # RED root is not ok.
all_invariants_hold (NUMBERED_SET tree)
=>
( black_invariant_ok tree
and
red_invariant_ok (TRUE, tree)
and
child_counts_ok 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;
fun child_counts_ok tree
=
{ { child_count tree;
TRUE;
}
except DOMAIN = FALSE;
}
where
# Count and return number of values in a subtree;
# raise DOMAIN exception if the val_count field
# in any node is incorrect:
#
fun child_count EMPTY
=>
0;
child_count (TREE_NODE (_, left_subtree, _, key_count, right_subtree))
=>
{ left_count = child_count left_subtree;
right_count = child_count right_subtree;
total = left_count + right_count + 1; # +1 for the value in this node.
if (key_count != total ) raise exception DOMAIN; fi;
total;
};
end;
end;
end; # where
end; # fun all_invariants_hold
# A debugging 'print' to show
# structure of tree:
#
fun debug_print_tree (print_key, tree, indent0)
=
debug_print_tree' (tree, 4, 0)
where
fun debug_print_tree' (tree, indent, count)
=
case tree
EMPTY
=>
count;
TREE_NODE (color, left, key, key_count, right)
=>
{ count = debug_print_tree' (left, indent+5, count);
print (do_indent (indent0, []));
printf "%4d: %4d" count key_count;
print " ";
print_key key;
print " key";
print " ";
pad1_string = do_indent (indent, []);
color_string = case color RED => "RED"; BLACK => "BLACK"; esac;
string = pad1_string + color_string;
size = string::length_in_bytes string;
pad2_string = do_indent (40-size, []);
print string;
print pad2_string;
print "\n";
debug_print_tree' (right, indent+5, count+1);
}
where
fun do_indent (n, l)
=
if (n > 0 ) { do_indent (n - 1, " " ! l); };
else cat l; fi;
end;
esac;
end;
fun debug_print ( NUMBERED_SET tree,
print_key
)
=
{ print "\n";
debug_print_tree (print_key, tree, 0);
};
fun keys_in EMPTY => 0;
keys_in (TREE_NODE (_,_, _, keys, _)) => keys;
end;
fun tree_node (color, left, key, right)
=
{ keys = keys_in left
+ keys_in right
+ 1;
TREE_NODE (color, left, key, keys, right);
};
#
fun set (NUMBERED_SET m, key1)
=
{ m = case (set'' m)
TREE_NODE (RED, left_subtree, key, keys, 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, keys, right_subtree);
other => other;
esac;
NUMBERED_SET m;
}
where
#
fun set'' EMPTY
=>
TREE_NODE (RED, EMPTY, key1, 1, EMPTY);
set'' (s as TREE_NODE (s_color, a, key2, _, b))
=>
case (key::compare (key1, key2))
LESS
=>
case a
TREE_NODE (RED, c, key3, _, d)
=>
case (key::compare (key1, key3))
LESS
=>
case (set'' c)
TREE_NODE (RED, e, wk, _, f)
=>
tree_node (RED, tree_node (BLACK, e, wk, f), key3, tree_node (BLACK, d, key2, b));
c
=>
tree_node (BLACK, tree_node (RED, c, key3, d), key2, b);
esac;
EQUAL
=>
tree_node (s_color, tree_node (RED, c, key1, d), key2, b);
GREATER
=>
case (set'' d)
TREE_NODE (RED, e, wk, _, f)
=>
tree_node (RED, tree_node (BLACK, c, key3, e), wk, tree_node (BLACK, f, key2, b));
d
=>
tree_node (BLACK, tree_node (RED, c, key3, d), key2, b);
esac;
esac;
_ => tree_node (BLACK, set'' a, key2, b);
esac;
EQUAL
=>
tree_node (s_color, a, key1, b);
GREATER
=>
case b
TREE_NODE (RED, c, key3, _, d)
=>
case (key::compare (key1, key3))
LESS
=>
case (set'' c)
TREE_NODE (RED, e, wk, _, f)
=>
tree_node (RED, tree_node (BLACK, a, key2, e), wk, tree_node (BLACK, f, key3, d));
c
=>
tree_node (BLACK, a, key2, tree_node (RED, c, key3, d) );
esac;
EQUAL
=>
tree_node (s_color, a, key2, tree_node (RED, c, key1, d));
GREATER
=>
case (set'' d)
TREE_NODE (RED, e, wk, _, f)
=>
tree_node (RED, tree_node (BLACK, a, key2, c), key3, tree_node (BLACK, e, wk, f));
d
=>
tree_node (BLACK, a, key2, tree_node (RED, c, key3, d));
esac;
esac;
_ => tree_node (BLACK, a, key2, set'' b);
esac;
esac;
end;
end;
# A synonym for 'set', so that we can write
# map $= (key, val);
# instead of the clumsier
# map = set( map, key, val );
#
fun m $ key1
=
set (m, key1);
#
fun set' (key1, m)
=
set (m, key1);
# Is a key in the domain of the map?
#
fun contains_key (NUMBERED_SET t, k)
=
find' t
where
fun find' EMPTY
=>
FALSE;
find' (TREE_NODE(_, a, key2, _, b))
=>
case (key::compare (k, key2))
LESS => find' a;
EQUAL => TRUE;
GREATER => find' b;
esac;
end;
end;
# Return (THE ordinal) corresponding to a key 'k',
# where 'ordinal' the number of keys preceding
# 'k' in the overall Numbered_Set.
#
# Return NULL if the key is not present.
#
fun find (NUMBERED_SET t, k)
=
find' (0, t)
where
fun find' (_, EMPTY)
=>
NULL;
find' (n, TREE_NODE(_, left_subtree, key, _, right_subtree))
=>
case (key::compare (k, key))
LESS => find' (n, left_subtree);
EQUAL => THE (n + keys_in left_subtree);
GREATER => find' (n + keys_in left_subtree + 1, right_subtree);
esac;
end;
end;
# Remove a keyval, returning new map and value removed.
# Raise lib_base::NOT_FOUND if not found.
#
stipulate
Descent_Path
= TOP
| LEFT ((Color, key::Key, Tree, Descent_Path) )
| RIGHT ((Color, Tree, key::Key, Descent_Path) );
herein
fun remove (input as NUMBERED_SET input_tree, key_to_remove)
=
{
# We produce our result tree by copying
# our descent path nodes one by one,
# starting at the leafward end and proceeding
# to the root.
#
# We have two copying cases to consider:
#
# 1) Initially, our deletion may have produced
# a violation of the RED/BLACK invariants
# -- specifically, a BLACK deficit -- forcing
# us to do on-the-fly rebalancing as we go.
#
# 2) Once the BLACK deficit is resolved (or immediately,
# if none was created), copying cannot produce any
# additional invariant violations, so path copying
# becomes an utterly trivial matter of node duplication.
#
# We have two separate routines to handle these two cases:
#
# copy_path Handles the trivial case.
# copy_path' Handles the rebalancing-needed case.
#
fun copy_path (TOP, t) => t;
copy_path (LEFT (color, key, b, rest_of_path), a) => copy_path (rest_of_path, tree_node (color, a, key, b));
copy_path (RIGHT (color, a, key, rest_of_path), b) => copy_path (rest_of_path, tree_node (color, a, key, b));
end;
# copy_path' propagates a black deficit
# up the descent path until either the top
# is reached, or the deficit can be
# covered.
#
# Arguments:
# o descent_path, the worklist of nodes which need to be copied.
# o result_tree, our results-so-far accumulator.
#
#
# Its return value is a pair containing:
# o black_deficit: A boolean flag which is TRUE iff there is still a deficit.
# o The new 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))));
# 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);
# 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_delete: 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_delete, EMPTY, descent_path)
=>
raise exception lib_base::NOT_FOUND;
descend (key_to_delete, TREE_NODE (color, left_subtree, key, _, right_subtree), descent_path)
=>
case (key::compare (key_to_delete, key))
LESS => descend (key_to_delete, left_subtree, LEFT (color, key, right_subtree, descent_path));
GREATER => descend (key_to_delete, 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-val pair 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;
removed_value
=
case (find (input, key_to_remove))
THE value => value;
NULL => raise exception lib_base::NOT_FOUND;
esac;
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, keys, right_subtree)
=>
TREE_NODE (BLACK, left_subtree, key, keys, right_subtree);
ok => ok;
esac;
(NUMBERED_SET new_tree, removed_value);
};
end; # stipulate
fun first_key_else_null (NUMBERED_SET t)
=
f t
where
fun f EMPTY => NULL;
f (TREE_NODE(_, EMPTY, key1, _, _)) => THE key1;
f (TREE_NODE(_, a, _, _, _)) => f a;
end;
end;
# Return the number of items in the map:
#
fun vals_count (NUMBERED_SET (TREE_NODE (_,_,_, keys, _))) => keys;
vals_count (NUMBERED_SET EMPTY) => 0;
end;
# XXX BUGGO FIXME The stuff below here is probably mostly broken;
# it isn't clear if it even makes sense to have
# this stuff in this package. Needs inspection,
# thinking and testing.
#
fun fold_forward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, key, _, b), accum)
=>
foldf (b, f (key, foldf (a, accum)));
end;
\\ init
=
\\ (NUMBERED_SET m)
=
foldf (m, init);
};
#
fun keyed_fold_forward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, key, keys, b), accum)
=>
foldf (b, f (key, keys, foldf (a, accum)));
end;
\\ init
=
\\ (NUMBERED_SET m)
=
foldf (m, init);
};
#
fun fold_backward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, key, _, b), accum)
=>
foldf (a, f (key, foldf (b, accum)));
end;
\\ init
=
\\ (NUMBERED_SET m)
=
foldf (m, init);
};
#
fun keyed_fold_backward f
=
{ fun foldf (EMPTY, accum)
=>
accum;
foldf (TREE_NODE(_, a, key, keys, b), accum)
=>
foldf (a, f (key, keys, foldf (b, accum)));
end;
\\ init
=
\\ (NUMBERED_SET m)
=
foldf (m, init);
};
# Return an ordered list of the keys in the map:
#
fun keys_list m
=
keyed_fold_backward (\\ (k, _, l) = k ! l) [] m;
# 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, []);
# Support for constructing red-black trees
# in linear time from increasing ordered
# sequences.
#
# Based on a description by Ralf Hinze
# http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
# which represents tree structures
# via binary numbers using only the digits
# 1 and 2. (0 is used only for the empty tree.)
#
# 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 ((key::Key, Tree, Digit) )
| TWO ((key::Key, Tree, key::Key, Tree, Digit) );
# Add a keyval that is guaranteed
# to be larger than any in l:
#
fun add_item (key, l)
=
incr (key, EMPTY, l)
where
fun incr (key, tree, ZERO)
=>
ONE (key, tree, ZERO);
incr ( key1, tree1,
ONE ( key2, tree2,
rest
)
)
=>
TWO ( key1, tree1,
key2, tree2,
rest
);
incr ( key1, tree1,
TWO ( key2, tree2,
key3, tree3,
rest
)
)
=>
ONE ( key1, tree1,
incr ( key2, tree_node (BLACK, tree3, key3, tree2),
rest
)
);
end;
end;
# Link the digits into a tree:
#
fun link_all digits
=
link (EMPTY, digits)
where
# We consume digits from our second argument and
# accumulate our eventual result in our first argument:
#
fun link (result_tree, ZERO)
=>
result_tree;
link (result_tree, ONE (key, tree, rest))
=>
link (tree_node (BLACK, tree, key, result_tree), rest);
link ( result_tree,
TWO ( key1, tree1,
key2, tree2,
rest
)
)
=>
link ( tree_node (BLACK, tree_node (RED, tree2, key2, tree1), key1, result_tree),
rest
);
end;
end;
stipulate
#
fun wrap f (NUMBERED_SET map1, NUMBERED_SET map2)
=
{ my (n, result)
=
f (start map1, start map2, 0, ZERO);
NUMBERED_SET (link_all result);
};
#
fun set'' ((EMPTY, _), n, result)
=>
(n, result);
set'' ((TREE_NODE(_, _, key1, _, _), r), n, result)
=>
set'' (next r, n+1, add_item (key1, result));
end;
herein
# Return a map whose domain is the union
# of the domains of the two input maps,
# using 'merge_fn' to select the vals
# for keys that are in both domains.
#
# XXX BUGGO FIXME merge_fn does nothing
fun union_with merge_fn
=
wrap union
where
fun union (tree1, tree2, n, result)
=
case ( next tree1,
next tree2
)
((EMPTY, _), (EMPTY, _)) => (n, result);
((EMPTY, _), tree2 ) => set'' (tree2, n, result);
(tree1, (EMPTY, _)) => set'' (tree1, n, result);
( (TREE_NODE(_, _, key1, _, _), rest1),
(TREE_NODE(_, _, key2, _, _), rest2)
)
=>
case (key::compare (key1, key2))
LESS => union (rest1, tree2, n+1, add_item (key1, result));
EQUAL => union (rest1, rest2, n+1, add_item (key1, result));
GREATER => union (tree1, rest2, n+1, add_item (key2, result));
esac;
esac;
end;
#
# XXX BUGGO FIXME merge_fn does nothing
fun keyed_union_with merge_fn
=
{ fun union (tree1, tree2, n, result)
=
case ( next tree1,
next tree2
)
((EMPTY, _), (EMPTY, _)) => (n, result);
((EMPTY, _), tree2 ) => set'' (tree2, n, result);
(tree1, (EMPTY, _)) => set'' (tree1, n, result);
( (TREE_NODE(_, _, key1, _, _), rest1),
(TREE_NODE(_, _, key2, _, _), rest2)
)
=>
case (key::compare (key1, key2))
LESS => union (rest1, tree2, n+1, add_item (key1, result));
EQUAL => union (rest1, rest2, n+1, add_item (key1, result));
GREATER => union (tree1, rest2, n+1, add_item (key2, result));
esac;
esac;
wrap union;
};
# Return a map whose domain is
# the intersection of the domains
# of the two input maps, using the
# supplied function to define the range.
#
# XXX BUGGO FIXME merge_fn does nothing
fun intersect_with merge_fn
=
{ fun intersect (tree1, tree2, n, result)
=
case ( next tree1,
next tree2
)
( (TREE_NODE(_, _, key1, _, _), r1),
(TREE_NODE(_, _, key2, _, _), r2)
)
=>
case (key::compare (key1, key2))
LESS => intersect (r1, tree2, n, result);
EQUAL => intersect (r1, r2, n+1, add_item (key1, result));
GREATER => intersect (tree1, r2, n, result);
esac;
_ => (n, result);
esac;
wrap intersect;
};
#
# XXX BUGGO FIXME merge_fn does nothing
fun keyed_intersect_with merge_fn
=
{ fun intersect (tree1, tree2, n, result)
=
case ( next tree1,
next tree2
)
( (TREE_NODE(_, _, key1, _, _), r1),
(TREE_NODE(_, _, key2, _, _), r2)
)
=>
case (key::compare (key1, key2))
LESS => intersect (r1, tree2, n, result);
EQUAL => intersect (r1, r2, n+1, add_item (key1, result));
GREATER => intersect (tree1, r2, n, result);
esac;
_ => (n, result);
esac;
wrap intersect;
};
#
fun apply f
=
{ fun appf EMPTY
=>
();
appf (TREE_NODE(_, a, key, _, b))
=>
{ appf a;
f key;
appf b;
};
end;
\\ (NUMBERED_SET m)
=
appf m;
};
#
fun keyed_apply f
=
{ fun appf EMPTY
=>
();
appf (TREE_NODE(_, a, key, keys, b))
=>
{ appf a;
f (key, keys);
appf b;
};
end;
\\ (NUMBERED_SET m)
=
appf m;
};
# Filter out those elements of the map
# that do not satisfy given predicate.
#
# The filtering is done in increasing map order:
#
fun filter predicate (NUMBERED_SET t)
=
NUMBERED_SET (link_all result)
where
fun walk (EMPTY, n, result)
=>
(n, result);
walk (TREE_NODE(_, a, key1, _, b), n, result)
=>
{ my (n, result)
=
walk (a, n, result);
if (predicate key1) walk (b, n+1, add_item (key1, result));
else walk (b, n, result); fi;
};
end;
my (n, result)
=
walk (t, 0, ZERO);
end;
#
fun keyed_filter predicate (NUMBERED_SET t)
=
NUMBERED_SET (link_all result)
where
fun walk (EMPTY, n, result)
=>
(n, result);
walk (TREE_NODE(_, a, key, keys, b), n, result)
=>
{ my (n, result)
=
walk (a, n, result);
if (predicate (key, keys)) walk (b, n+1, add_item (key, result));
else walk (b, n, result); fi;
};
end;
my (n, result)
=
walk (t, 0, ZERO);
end;
end;
fun from_list list
=
loop (ZERO, list)
where
fun loop (result, [])
=>
NUMBERED_SET (link_all result);
loop (result, this ! rest)
=>
loop (add_item (this, result), rest );
end;
end;
};