## red-black-tagged-numbered-list.pkg
# Compiled by:
# src/lib/std/standard.lib# Compare with:
# src/lib/src/binary-random-access-list.pkg# src/lib/src/red-black-numbered-list.pkg# Unit test code in:
# src/lib/src/red-black-tagged-numbered-list-unit-test.pkg#########################################################################
#########################################################################
# TO DO
# 2008-02-13
#
# Probably 'sub' and 'update' should become 'get' and 'set' everywhere.
# Making 'insert' and 'remove' into 'put' and 'del' would fit the 3-char pattern.
# The set operations 'add' and 'delete' should probably also be just 'put' and 'del'
# -- trying to have different names for the same ops in every file is the road to madness.
#
# Now that I grok that numbering can be added to any of the vanilla trees,
# some naming rationalization is probably in order:
#
# o Both of the standard red-black tree types ('map' and 'set')
# can have a Numbered_ variant which keeps and uses 'nodes'
# (count of nodes in subtree) fields in each node.
#
# o 'set' is just 'map' sans value fields, and 'sequence' is just
# 'set' sans key fields, so the naming should reflect that:
# 'Numbered_List' maybe.
#
# o Since numbering is basically a mixin that can be added to
# the standard trees, the numbering-specific operations need
# to have names which don't overlap the regular set/map operation
# names.
#
# o Tagging maps and sets is pointless because the tags do
# nothing that the existing key fields don't already do.
# Tagging is essentially synthesizing an invisible set of
# unique ordered keys.
#
# o Supporting access to i-th char, i-th line etc
# (in addition to i-th node) can also be done as a
# monotonic mixin to the vanilla 'set' and 'map'
# classes.
#
# o I dunno if we can or should have master source files that
# generate all these tree flavors. This may be an example
# of a case where vanilla C-style #IFDEF cases would get the
# job done better than generics.
# 2008-02-12
#
# This version uses 'up' pointers to parent nodes
# and is thus imperative -- you can't share a node
# which has a pointer to its parent. Ick! :) I did it
# this way because I couldn't figure out a fully-persisent
# way of doing it.
#
# Scott Crosby provided me with a better solution:
#
# o Junk the 'up' pointers and the current 'tag' pointers.
#
# o External node tags become integers;
# we can just allot them sequentially.
#
# o Each node has a 'tag' field holding its tag.
#
# o Each node also holds an integer 'key' field.
#
# o The tree is kept sorted by 'key' field. We keep the
# key numbers dense enough to fit in a 31-bit integer,
# but sparse enough that insertions can usually be
# done without needing to re-key; when necessary,
# we re-key in the usual order maintenance fashion.
# (I'd guess 1/8 density is a good target, re-keying
# when it rises above 1/2 or drops below 1/32.)
#
# o We use a vanilla red-black tree to map tags to keys.
# When we re-key nodes, we update this mapping.
# Tags never have to change, and never do.
#
# Now everything works cleanly:
#
# o When inserting, we pick a new node key anywhere between
# the existing neighbors (maybe stopping to re-key as needed),
# assign a new tag sequentially, enter the new tag->key
# mapping into our tag table, and return the tag.
#
# o When deleting a node, we use the tag in it to
# delete the tag->key mapping from the tag table.
#
# o To find a node by sequence position, we dive down the
# tree guided by the nodes-in-this-subtree fields.
#
# o To find a node by tag, we map tag to key, then
# dive down the tree doing a conventional binary lookup
# on the 'key' fields. As we go, we can also sum
# predecessor nodes, and thus compute the sequence
# position of the node/value named by the tag.
#
#########################################################################
#########################################################################
# Implementation of applicative-style
# (side-effect free) sequences.
#
# By a "sequence" we here mean essentially a
# numbered list. Our motivation is to support
# such things as representing a text document in
# memory as a sequence of lines supporting easy
# insertion and deletion of lines for editing.
#
# We implement this by adapting our tried-and-true
# red-black trees.
#
# The obvious idea of representing a sequence by a
# vanilla red-black tree which maps successive integers
# to values fails because when we insert or delete the i-th value,
# we would have to explicitly renumber all subsequent values
# in the sequence, which would be intolerably slow -- it would
# make INSERT and DELETE O(N) instead of O(log(N)).
#
# We avoid this renumbering by representing keys less explicitly:
# in each node we store not the key itself, but rather the count
# of values (nodes) in the subtree rooted at that point.
#
# This information can easily be updated in log(N) time as we insert
# and delete, and is sufficient to allow us to efficiently compute
# the actual integer key value for each node on the fly as we do so.
# (For example, the key of the root node is the number of values in
# its left subtree, which can be computed in O(1) time just by
# examining the root node of its left subtree.)
#
# The converse idea is implemented in
#
# src/lib/src/red-black-numbered-set-g.pkg#
# 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.
#
# Wikipedia has a good discussion of basic insertion and deletion:
# http://en.wikipedia.org/wiki/Red_black_tree
#
# 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.
# To do:
#
# o Should write a converse implementation in
# which the keys are vanilla and the values
# are nodes-in-subtree counts. I'd call
# it "Numbering": It is useful for mapping
# from an arbitrary key sequence to a dense
# integer numbering 0..N-1.
# (The fourth logical combination, in which
# both key and val fields are nodecounts, is
# of limited practical utility. ;-)
#
# o I believe the from_list/digits stuff can be
# rewritten without too much effort to use
# Implicit_Tree instead of Explicit_Tree.
#
# If so, at that point it should be practical
# to delete all the Explicit_Tree stuff, and
# then drop the "Implicit_" and "IMPLICIT_"
# prefices.
#
# Also, I think the IMPLICIT_SEQUENCE headers
# could be dispensed with.
#
# o We should probably implement a '@'
# append operator, maybe even 'cat'.
#
# o We should probably implement a sub-sequence
# extraction operator, along the lines of that
# supplied for Vector &Co. More generally,
# we should perhaps support the Vector interface,
# to allow using Sequence as a drop-in replacement
# for Vector when desired.
#
# o It should be practical to rewrite so as to
# use space much more efficiently:
#
# * Make color implicit in the header rather
# than an explicit field.
#
# * Eliminate EMPTY fields by making them
# implicit in the header as well.
#
# * (Maybe) store 1-4 values per leaf node
# instead of always just one.
#
# It may be that this is just a bass-ackwards
# way of re-inventing 2-3-4 trees...? (I've
# never really looked at them.)
#
# If so, it might make more sense just to do a
# from-scratch implementation of them, and
# leave the existing red-black code alone.
package red_black_tagged_numbered_list
: Tagged_Numbered_List # Tagged_Numbered_List is from src/lib/src/tagged-numbered-list.api{
Color
=
RED | BLACK;
# Tree in which nodes have implicit keys
# derived on-the-fly from node count fields:
#
Implicit_Tree(X)
#
= IMPLICIT_NULL
#
| IMPLICIT_NODE
{ color: Color,
left: Implicit_Tree(X), # Left subtree.
key: Int, # Unique ID, because Mythryl does not have pointer equality.
val: X, # Value.
tag: Int, # Tag for this value.
right: Implicit_Tree(X), # Right subtree.
nodes: Int # Count of nodes in this subtree.
};
# Header node for tagged sequences.
# Since we update tagged sequences via side-effects,
# this has to be an updatable reference:
#
Tagged_Numbered_List(X)
=
TAGGED_SEQUENCE( Implicit_Tree(X) );
# Tag for a value in an Implicit_Tree:
#
Tag(X) = Int;
# # Tree in which nodes have explicit keys:
# #
# Explicit_Tree(X)
# = EXPLICIT_EMPTY
# | EXPLICIT_NODE ( ( Color,
# Explicit_Tree(X), # Left subtree.
# Int, # Key.
# X, # Value.
# Explicit_Tree(X) # Right subtree.
# ) );
# # Header node for explicitly represented sequences.
# # Every complete explicit sequence is represented by one:
# #
# Explicit_Sequence(X)
# =
# EXPLICIT_SEQUENCE
# ( ( Int, # Count of nodes in the tree -- zero for an empty sequence.
# Explicit_Tree(X) # Tree containing one node per key-val pair in sequence.
# ) );
my next_tag = REF 0;
#
empty = TAGGED_SEQUENCE IMPLICIT_NULL;
#
fun is_empty (TAGGED_SEQUENCE IMPLICIT_NULL) => TRUE;
is_empty _ => FALSE;
end;
# fun tag_value (REF (IMPLICIT_NODE { val, ... })) => val;
# tag_value (REF IMPLICIT_NULL) => raise exception IMPOSSIBLE;
# end;
fun nodes_in IMPLICIT_NULL => 0;
nodes_in (IMPLICIT_NODE { nodes, ... }) => nodes;
end;
fun implicit_node (color, left, key, val, tag, right)
=
{ nodes = nodes_in left
+ nodes_in right
+ 1;
IMPLICIT_NODE { color, left, key, val, tag, right, nodes };
};
# Check invariants:
#
fun all_invariants_hold ((TAGGED_SEQUENCE IMPLICIT_NULL): Tagged_Numbered_List(X))
=>
TRUE;
all_invariants_hold (TAGGED_SEQUENCE (IMPLICIT_NODE { color => RED, ... } ) )
=>
FALSE; # RED root is not ok.
all_invariants_hold (TAGGED_SEQUENCE tree)
=>
( black_invariant_ok tree
and
red_invariant_ok (TRUE, tree)
and
child_counts_ok tree
# and
# tags_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, IMPLICIT_NULL)
=>
n == black_depth;
check_blackdepth_on_all_paths (n, IMPLICIT_NODE { color => BLACK, left, right, ... })
=>
check_blackdepth_on_all_paths (n+1, left)
and
check_blackdepth_on_all_paths (n+1, right);
check_blackdepth_on_all_paths (n, IMPLICIT_NODE { color => RED, left, right, ... })
=>
check_blackdepth_on_all_paths (n, left)
and
check_blackdepth_on_all_paths (n, right);
end;
end;
}
where
fun leftmost_blackdepth (n, IMPLICIT_NULL) => n;
leftmost_blackdepth (n, IMPLICIT_NODE { color => RED, left, ... }) => leftmost_blackdepth (n, left);
leftmost_blackdepth (n, IMPLICIT_NODE { color => BLACK, left, ... }) => leftmost_blackdepth (n+1, left);
end;
end;
# A RED node must always have a BLACK parent:
#
fun red_invariant_ok (parent_was_black, IMPLICIT_NULL)
=>
TRUE;
red_invariant_ok (parent_was_black, IMPLICIT_NODE { color => RED, left, right, ... })
=>
parent_was_black
and
red_invariant_ok (FALSE, left)
and
red_invariant_ok (FALSE, right);
red_invariant_ok (parent_was_black, IMPLICIT_NODE { color => BLACK, left, right, ... })
=>
red_invariant_ok (TRUE, left)
and
red_invariant_ok (TRUE, right);
end;
# The nodes field in every node must
# equal the number of nodes in that subtree:
#
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 IMPLICIT_NULL
=>
0;
child_count (IMPLICIT_NODE { nodes, left, right, ... })
=>
{ left_count = child_count left;
right_count = child_count right;
total = left_count + right_count + 1; # +1 for the value in this node.
if nodes != total then raise exception DOMAIN; fi;
total;
};
end;
end;
# The tag for every node must point back to it:
#
# fun tags_ok IMPLICIT_NULL
# =>
# TRUE;
#
# tags_ok (IMPLICIT_NODE { id, left, tag, right, ... })
# =>
# tags_ok left
# and
# tags_ok right
# and
# case *tag
# IMPLICIT_NODE { id => id', ... } => { if id != id' then printf "tag for node %d points to node %d?!\n" id id'; fi; id == id'; };
# IMPLICIT_NULL => FALSE; # "Impossible".
# esac;
# end;
end;
end;
# A debugging 'print' to show
# structure of tree:
#
fun debug_print_tree (print_val, tree, indent0)
=
debug_print_tree' (tree, 4, 0)
where
fun debug_print_tree' (tree, indent, count)
=
case tree
IMPLICIT_NULL
=>
count;
IMPLICIT_NODE { color, left, key, val, tag, right, nodes }
=>
{ count = debug_print_tree' (left, indent+5, count);
print (do_indent (indent0, []));
printf "%4d: " count;
print_val val;
printf " %4d nodes" nodes;
printf " %4d key" key;
printf " %4d tag" tag;
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 then { do_indent (n - 1, " " . l); };
else cat l; fi;
end;
esac;
end;
fun debug_print ( REF tree,
print_val
)
=
{ print "\n";
debug_print_tree (print_val, tree, 0);
};
#
fun insert (header as (TAGGED_SEQUENCE tree), i, val)
=
{
if i < 0 then raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
new_tree
=
case (insert'' (i, val, tree))
IMPLICIT_NODE { color => RED, left, key, val, tag, right, nodes }
=>
# 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.
#
{ result = implicit_node (BLACK, left, key, val, tag, right);
tag := result;
result;
};
other =>
other;
esac;
header := new_tree;
result_tag;
}
where
#
fun insert'' (i, val, IMPLICIT_NULL)
=>
{ if i != 0
then
raise exception exceptions::INDEX_OUT_OF_BOUNDS;
fi;
implicit_node (RED, IMPLICIT_NULL, val, result_tag, IMPLICIT_NULL);
};
insert'' (key, val, s as IMPLICIT_NODE { color => s_color, left => s_left, nodes => s_nodes, val => s_val, tag => s_tag, right => s_right, ... })
=>
{ nodes_in_s_left
=
nodes_in s_left;
order = int::compare (key, nodes_in_s_left+1);
case order
LESS
=>
case s_left
IMPLICIT_NODE { color => RED, left => s_left_left, val => s_left_val, tag => s_left_tag, right => s_left_right, ... }
=>
{ nodes_in_s_left_left
=
nodes_in s_left_left;
order = int::compare (key, nodes_in_s_left_left+1);
case order
LESS
=>
case (insert'' (key, val, s_left_left))
IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
=>
implicit_node
(
RED,
implicit_node (BLACK, r_left, r_val, r_tag, r_right),
s_left_val,
s_left_tag,
implicit_node (BLACK, s_left_right, s_val, s_tag, s_right)
);
s_left_left
=>
implicit_node
(
BLACK,
implicit_node (RED, s_left_left, s_left_val, s_left_tag, s_left_right),
s_val,
s_tag,
s_right
);
esac;
(GREATER | EQUAL)
=>
{
if order == EQUAL
then
# EQUAL case (inserting 'val' in this node)
# is the same as the GREATER case except
# that the roles of 'val' and 's_left_val'
# are interchanged, and 'key' incremented:
my (val, s_left_val) = (s_left_val, val);
key = key + 1;
fi;
case (insert'' (key - (nodes_in_s_left_left + 1), val, s_left_right))
IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left_left, s_left_val, s_left_tag, r_left),
r_val,
r_tag,
implicit_node (BLACK, r_right, s_val, s_tag, s_right)
);
s_left_right
=>
implicit_node
(
BLACK,
implicit_node (RED, s_left_left, s_left_val, s_left_tag, s_left_right),
s_val,
s_tag,
s_right
);
esac;
};
esac;
};
_ =>
implicit_node (BLACK, insert'' (key, val, s_left), s_val, s_tag, s_right);
esac;
(GREATER | EQUAL)
=>
{
if order == EQUAL
then
# EQUAL case (inserting 'val' in this node)
# is the same as the GREATER case except
# that the roles of 'val' and 's_val'
# are interchanged, and 'key' incremented:
my (val, s_val) = (s_val, val);
key = key + 1;
fi;
# Insertion will take place in our right subtree,
# so convert 'key' to that subtree's "coordinates"
# by subtracting off the number of values in this
# node (1) plus its left subtree:
#
key = key - (nodes_in_s_left + 1);
case s_right
IMPLICIT_NODE { color => RED, left => s_right_left, nodes => s_right_kids, val => s_right_val, tag => s_right_tag, right => s_right_right, ... }
=>
{ nodes_in_s_right_left
=
nodes_in s_right_left;
order = int::compare (key, nodes_in_s_right_left+1);
case order
LESS
=>
case (insert'' (key, val, s_right_left))
IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left, s_val, s_tag, r_left),
r_val,
r_tag,
implicit_node (BLACK, r_right, s_right_val, s_right_tag, s_right_right)
);
s_right_left
=>
implicit_node
(
BLACK,
s_left,
s_val,
s_tag,
implicit_node (RED, s_right_left, s_right_val, s_right_tag, s_right_right)
);
esac;
(GREATER | EQUAL)
=>
{
if order == EQUAL
then
# EQUAL case (inserting 'val' in this node)
# is the same as the GREATER case except
# that the roles of 'val' and 's_right_val'
# are interchanged, and 'key' incremented:
my (val, s_right_val) = (s_right_val, val);
key = key + 1;
fi;
# Transform key into "coordinate system" of our
# right subtree by subtracting off number of values
# in this node plus its left subtree:
#
key = key - (nodes_in_s_right_left + 1);
case (insert'' (key, val, s_right_right))
IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left, s_val, s_tag, s_right_left),
s_right_val,
s_right_tag,
implicit_node (BLACK, r_left, r_val, r_tag, r_right)
);
s_right_right
=>
implicit_node
(
BLACK,
s_left,
s_val,
s_tag,
implicit_node (RED, s_right_left, s_right_val, s_right_tag, s_right_right)
);
esac;
};
esac;
};
_ =>
implicit_node (BLACK, s_left, s_val, s_tag, insert'' (key, val, s_right));
esac;
};
esac;
};
end;
end;
# A synonym for 'insert', so that we can write
# map $= (key, val);
# instead of the clumsier
# map = insert( map, key, val );
#
fun m $ (key1, val1)
=
insert (m, key1, val1);
#
fun insert' ((key1, val1), m)
=
insert (m, key1, val1);
# Return i such that tagged node has i predecessors in the sequence:
#
stipulate
fun find_tag' (last_id, predecessors, IMPLICIT_NULL)
=>
predecessors; # We've reached the top of the tree, so 'predecessors' is total number of predecessors in sequence.
find_tag' (last_id, predecessors, IMPLICIT_NODE { id, up, left => IMPLICIT_NULL, ... })
=>
find_tag' (id, predecessors, *up); # Left subtree is empty, so we have no additional predecessors on this level.
find_tag' (last_id, predecessors, IMPLICIT_NODE { id, up, left => IMPLICIT_NODE { nodes, id => left_id, ... }, ... })
=>
if left_id == last_id
then
find_tag' (id, predecessors, *up); # We came up from left subtree, so don't count nodes in it as newly found predecessors.
else find_tag' (id, predecessors + nodes + 1, *up); fi; # We came up from right subtree, so all nodes in left subtree are newfound predecessors -- plus this node.
end;
herein
fun find_tag (REF IMPLICIT_NULL)
=>
raise exception IMPOSSIBLE; # Tag points to node holding some inserted value, so it cannot point to an IMPLICIT_NULL.
find_tag (REF (IMPLICIT_NODE { id, up, left => IMPLICIT_NULL, ... }))
=>
find_tag' (id, 0, *up); # Our left subtree is empty, so we have no predecessors at this level.
find_tag (REF (IMPLICIT_NODE { id, up, left => IMPLICIT_NODE { nodes, ... }, ... }))
=>
find_tag' (id, nodes, *up); # Our initial count of predecessors is the number of nodes in our left subtree.
end;
end;
# Return (THE tag) corresponding to a key,
# or NULL if the key is not present:
#
fun nth_tag (REF tree, key)
=
find' (tree, key)
where
fun find' (IMPLICIT_NULL, key)
=>
NULL;
find' ((IMPLICIT_NODE { left, tag, right, ... }), key)
=>
{ left_kids = nodes_in left;
if key < 0 then raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
case (int::compare (key, left_kids))
LESS => find' (left, key);
EQUAL => THE tag;
GREATER => find' (right, key - (left_kids+1));
esac;
};
end;
end;
# Return (THE val) corresponding to a key,
# or NULL if the key is not present:
#
fun find (REF tree, key)
=
find' (tree, key)
where
fun find' (IMPLICIT_NULL, key)
=>
NULL;
find' ((IMPLICIT_NODE { left, val, right, ... }), key)
=>
{ left_kids = nodes_in left;
if key < 0 then raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
case (int::compare (key, left_kids))
LESS => find' (left, key);
EQUAL => THE val;
GREATER => find' (right, key - (left_kids+1));
esac;
};
end;
end;
fun sub (sequence, i)
=
case (find (sequence, i))
#
THE val => val;
NULL => raise exception exceptions::INDEX_OUT_OF_BOUNDS;
esac;
# Note: The (_[]) enables 'vec[index]' notation;
my (_[]) = sub;
# Remove n-th value.
# Raise lib_base::NOT_FOUND if not found.
#
stipulate
# As with most applicative ("side-effect free")
# datastructures, we work by path copying:
# given an input tree, we build and return
# a mutated copy of some node path from root
# to (typically) leaf. The input tree is
# untouched, and almost all of the result tree's
# nodes are shared with the input tree.
#
# To remove the n-th value from a Sequence,
# we must first descend into the tree
# to find the node holding that value,
# then retrace our steps, copying nodes
# to produce the result tree, and also
# rebalancing the tree as needed to
# maintain our RED/BLACK invariants.
#
# We use a Descent_Path to record our
# descent; it is essentially an explicit
# stack upon which we push the information
# which we will need upon our return trip,
# such as whether we descended down
# the LEFT or RIGHT subtree of a given node:
#
Descent_Path(X)
= TOP
| WENT_LEFT ((Color, X, Tag(X), Implicit_Tree(X), Descent_Path(X)) ) # Descent went left; remember node's val, tag and right subtree.
| WENT_RIGHT ((Color, X, Tag(X), Implicit_Tree(X), Descent_Path(X)) ); # Descent went right; remember node's val, tag and left subtree.
herein
# Remove the i-th value from a Sequence.
#
# Three useful observations:
#
# (1) We can always reduce the case of deleting
# a node with two children to the (easier)
# case of deleting a node with at most one
# child, just by bubbling values up into
# the two-kid node.
#
# (2) When deleting a RED node with only one child,
# we can simply replace it by its child; this
# preserves all invariants.
#
# (3) When deleting a BLACK node with one RED child,
# we can simply replace it by its child, recolored
# BLACK: This again preserves all invariants.
#
# Thus, the most interesting case is deleting
# a BLACK node with one BLACK child, or no child:
# This will result in a BLACK-node deficit in that
# subtree, which we must find a way to repair
# via rotations.
#
fun remove (
sequence as (REF input_tree),
i
)
=
{ # Sanity check:
#
if i < 0 then raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
new_tree
=
case (descend (i, input_tree, TOP))
# Enforce the invariant that
# the root node is always BLACK:
#
IMPLICIT_NODE { color => RED, left, val, right, tag, ... }
=>
implicit_node ( BLACK, left, val, tag, right );
ok => ok;
esac;
sequence := new_tree;
}
where
# fun color_name RED => "RED";
# color_name BLACK => "BLACK";
# end;
#
# fun print_path TOP => print " TOP of descent path\n";
# print_path (WENT_LEFT (color, val, tree, rest)) => { printf " WENT_LEFT %5s " (color_name color); print_val val; print "\n"; debug_print_tree (print_val, tree, 8); print_path rest; };
# print_path (WENT_RIGHT (color, val, tree, rest)) => { printf " WENT_RIGHT %5s " (color_name color); print_val val; print "\n"; debug_print_tree (print_val, tree, 8); print_path rest; };
# end;
# 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 (WENT_LEFT (color, val, tag, right_subtree, rest_of_path), left_subtree) => copy_path (rest_of_path, implicit_node (color, left_subtree, val, tag, right_subtree));
copy_path (WENT_RIGHT (color, val, tag, left_subtree, rest_of_path), right_subtree) => copy_path (rest_of_path, implicit_node (color, left_subtree, val, tag, right_subtree));
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, result_tree)
=>
(TRUE, result_tree);
# Nomenclature: In the below diagrams, I use '1B' == "BLACK node containing val1"
# '2R' == "RED node containing val2"
# 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' (WENT_LEFT (BLACK, val1, tag1, IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, path), a) # Case 1L
=>
copy_path' (WENT_LEFT (RED, val1, tag1, c, WENT_LEFT (BLACK, val2, tag2, d, path)), a);
#
# We ('a') now have a RED parent and BLACK sibling, so case 4, 5 or 6 will apply.
# 1B 2B Wikipidia Case 2 (Mirrored)
# / \ / \
# 2R b -> c 1R
# c d d b
#
copy_path' (WENT_RIGHT (BLACK, val1, tag1, IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, path), b) # Case 1R
=>
copy_path' (WENT_RIGHT (RED, val1, tag1, d, WENT_RIGHT (BLACK, val2, tag2, c, path)), b);
#
# We ('b') now have a RED parent and BLACK sibling, so mirrored 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' (WENT_LEFT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, val => val3, tag => tag3, right => e, ... }, path), a) # Case 3L
=>
copy_path' (WENT_LEFT (color, val1, tag1, implicit_node (BLACK, c, val2, tag2, implicit_node (RED, d, val3, tag3, e)), path), a);
# 1 1 Wikipedia Case 5 (Mirrored)
# / \ / \
# 2B b -> 3B b
# c 3R 2R e
# d e c d
#
copy_path' (WENT_RIGHT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => IMPLICIT_NODE { color => RED, left => d, val => val3, tag => tag3, right => e, ... }, ... }, path), b) # Case 4R
=>
copy_path' (WENT_RIGHT (color, val1, tag1, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val3, tag3, e), path), b);
# 1X 2X Wikipedia Case 6
# / \ / \
# a 2B -> 1B 3B
# c 3R a c d e
# d e
#
copy_path' (WENT_LEFT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => IMPLICIT_NODE { color => RED, left => d, val => val3, tag => tag3, right => e, ... }, ... }, path), a) # Case 4L
=>
(FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, a, val1, tag1, c), val2, tag2, implicit_node (BLACK, d, val3, tag3, e))));
# 1X 2X Wikipedia Case 6 (Mirrored)
# / \ / \
# 2B b -> 3B 1B
# 3R e c d e b
# c d
#
copy_path' (WENT_RIGHT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => IMPLICIT_NODE { color => RED, left => c, val => val3, tag => tag3, right => d, ... }, val => val2, tag => tag2, right => e, ... }, path), b) # Case 3R
=>
(FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, c, val3, tag3, d), val2, tag2, implicit_node (BLACK, e, val1, tag1, b))));
# 1B 1B Wikipedia Case 3
# / \ / \
# a 2B -> a 2R
# c d c d
#
copy_path' (WENT_LEFT (BLACK, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), a) # Case 2L
=>
copy_path' (path, implicit_node (BLACK, a, val1, tag1, implicit_node (RED, c, val2, tag2, 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 1B Wikipedia Case 3 (Mirrored)
# / \ / \
# 2B b -> 2R b
# c d c d
#
copy_path' (WENT_RIGHT (BLACK, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), b) # Case 2R
=>
copy_path' (path, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val1, tag1, b));
#
# Changing BLACK sib to RED locally rebalances in the
# sense that paths through us ('b') 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.
# 1R 1B Wikipedia Case 4
# / \ / \
# a 2B -> a 2R
# c d c d
#
copy_path' (WENT_LEFT (RED, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), a) # Case 2L
=>
(FALSE, copy_path (path, implicit_node (BLACK, a, val1, tag1, implicit_node (RED, c, val2, tag2, 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.
# 1R 1B Wikipedia Case 4 (Mirrored)
# / \ / \
# 2B b -> 2R b
# c d c d
#
copy_path' (WENT_RIGHT (RED, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), b) # Case 2R
=>
(FALSE, copy_path (path, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val1, tag1, 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.
copy_path' (path, t)
=>
(FALSE, copy_path (path, t));
end;
# Here's our routine for the descent phase.
#
# Arguments:
# node_to_delete: Integer identifying which node to delete, relative to local subtree numbering of 0..N
# 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 (node_to_delete, IMPLICIT_NULL, descent_path)
=>
raise exception lib_base::NOT_FOUND;
descend (node_to_delete, IMPLICIT_NODE { color, left, nodes, val, tag, right, ... }, descent_path)
=>
{ left_kids
=
nodes_in left;
case (int::compare (node_to_delete, left_kids))
LESS => descend (node_to_delete, left, WENT_LEFT (color, val, tag, right, descent_path));
GREATER => descend (node_to_delete - (left_kids + 1), right, WENT_RIGHT (color, val, tag, left, descent_path));
EQUAL => join (color, left, right, 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, IMPLICIT_NULL, IMPLICIT_NULL, descent_path) => copy_path (descent_path, IMPLICIT_NULL);
join (RED, left_subtree, IMPLICIT_NULL, descent_path) => copy_path (descent_path, left_subtree );
join (RED, IMPLICIT_NULL, right_subtree, descent_path) => copy_path (descent_path, right_subtree );
join (BLACK, left_subtree, IMPLICIT_NULL, descent_path) => #2 (copy_path' (descent_path, left_subtree));
join (BLACK, IMPLICIT_NULL, 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 value to fill this node,
# creating a delete-node problem below which is
# guaranteed to have at most one nonempty child:
#
# Replace deleted value with
# value from first node in our
# right subtree:
#
my (replacement_value, replacement_tag)
=
min_val right_subtree;
# Now, act as though the delete never happened:
# just continue our descent, with node 0 in
# right subtree as our new delete target:
#
descend( 0, right_subtree, WENT_RIGHT (color, replacement_value, replacement_tag, left_subtree, descent_path) );
}
where
#
fun min_val (IMPLICIT_NODE { left => IMPLICIT_NULL, val, tag, ... }) => (val, tag);
min_val (IMPLICIT_NODE { left, ... }) => min_val left;
min_val IMPLICIT_NULL => raise exception IMPOSSIBLE;
end;
end;
end;
end;
end; # stipulate
# # Return the first value in the sequence (or NULL if it is empty):
# #
# fun first_val_else_null (IMPLICIT_SEQUENCE tree)
# =
# leftmost_descendent tree
# where
# fun leftmost_descendent IMPLICIT_NULL => NULL;
# leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_NULL, _, val, _)) => THE val;
# leftmost_descendent (IMPLICIT_NODE(_, left_subtree, _, _, _)) => leftmost_descendent left_subtree;
# end;
# end;
#
# #
# fun first_keyval_else_null (IMPLICIT_SEQUENCE tree)
# =
# leftmost_descendent tree
# where
# fun leftmost_descendent IMPLICIT_NULL => NULL;
# leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_NULL, _, val, _)) => THE (0, val);
# leftmost_descendent (IMPLICIT_NODE(_, left_subtree, _, _, _)) => leftmost_descendent left_subtree;
# end;
# end;
#
# # Return the last value in the sequence (or NULL if it is empty):
# #
# stipulate
#
# fun rightmost_descendent IMPLICIT_NULL => NULL;
# rightmost_descendent (IMPLICIT_NODE(_,_,_, val, IMPLICIT_NULL)) => THE val;
# rightmost_descendent (IMPLICIT_NODE(_,_,_, _, right_subtree )) => rightmost_descendent right_subtree;
# end;
# herein
# fun last_val_else_null (IMPLICIT_SEQUENCE tree)
# =
# rightmost_descendent tree;
#
# #
# fun last_keyval_else_null (IMPLICIT_SEQUENCE IMPLICIT_NULL)
# =>
# NULL;
#
# last_keyval_else_null (IMPLICIT_SEQUENCE (tree as IMPLICIT_NODE (_,_,val_count,_,_)))
# =>
# THE (val_count - 1, the (rightmost_descendent tree));
# end;
# end;
#
# Return the number of items in the sequence:
#
fun vals_count (REF (IMPLICIT_NULL )) => 0;
vals_count (REF (IMPLICIT_NODE { nodes, ... })) => nodes;
end;
# # Remove and return first value in sequence:
# #
# fun shift sequence
# =
# (THE (remove (sequence, 0)))
# except
# lib_base::NOT_FOUND = NULL;
#
#
# # Prepend a value to sequence:
# #
# fun unshift (sequence, val)
# =
# insert (sequence, 0, val);
#
# # Remove and return last value in sequence:
# #
# fun pop sequence
# =
# case (vals_count sequence)
# 0 => NULL;
# n => THE (remove (sequence, n - 1));
# esac;
#
# # Append a value to sequence:
# #
# fun push (sequence, val)
# =
# insert (sequence, vals_count sequence, val);
#
#
# # Call
# # f (val, result_so_far)
# # once for every value in the sequence, in order,
# # returning the final result:
# #
# fun fold_forward f
# =
# { fun foldf (IMPLICIT_NULL, result)
# =>
# result;
#
# foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result)
# =>
# foldf (right_subtree, f (val, foldf (left_subtree, result)));
# end;
#
# \\ initial_value
# =
# \\ (IMPLICIT_SEQUENCE tree)
# =
# foldf (tree, initial_value);
# };
#
# # Call
# # f (key, val, result_so_far)
# # once for every key, val pair in the sequence,
# # in order, returning the final result:
# #
# #
# fun keyed_fold_forward f
# =
# { fun foldf (IMPLICIT_NULL, result, key)
# =>
# (result, key);
#
# foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result, key)
# =>
# { my (result, key)
# =
# foldf (left_subtree, result, key);
#
# result
# =
# f (key, val, result);
#
# foldf (right_subtree, result, key+1);
# };
# end;
#
# \\ initial_value
# =
# \\ (IMPLICIT_SEQUENCE tree)
# =
# { my (result, _) = foldf (tree, initial_value, 0);
# result;
# };
# };
#
# #
# fun fold_backward f
# =
# { fun foldf (IMPLICIT_NULL, accum)
# =>
# accum;
#
# foldf (IMPLICIT_NODE(_, left, _, val, right), accum)
# =>
# foldf (left, f (val, foldf (right, accum)));
# end;
#
# \\ init
# =
# \\ (IMPLICIT_SEQUENCE (m))
# =
# foldf (m, init);
# };
#
# #
# fun keyed_fold_backward f
# =
# { fun foldf (IMPLICIT_NULL, result, key)
# =>
# (result, key);
#
# foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result, key)
# =>
# { my (result, key)
# =
# foldf (right_subtree, result, key);
#
# result
# =
# f (key, val, result);
#
# foldf (left_subtree, result, key - 1);
# };
# end;
#
# \\ initial_value
# =
# \\ (IMPLICIT_SEQUENCE IMPLICIT_NULL)
# =>
# initial_value;
#
# (seq as (IMPLICIT_SEQUENCE (tree as IMPLICIT_NODE (_,_, val_count,_,_))))
# =>
# { my (result, _) = foldf (tree, initial_value, val_count - 1);
# result;
# };
# end;
# };
#
# #
# fun vals_list sequence
# =
# fold_backward (op . ) [] sequence;
#
# #
# fun keyvals_list sequence
# =
# keyed_fold_backward (\\ (key1, val1, l) = (key1, val1) . l) [] sequence;
#
#
# # Return an ordered list of the keys in the sequence:
# #
# fun keys_list sequence
# =
# case (min_key sequence, max_key sequence)
# (THE low, THE high) => (low .. high);
# _ => [];
# esac;
#
#
# # Functions for walking the tree
# # while keeping a stack of parents
# # to be visited.
# #
# # Usage protocol is:
# #
# # loop (start sequence)
# # where
# # fun loop (IMPLICIT_NULL, _)
# # =>
# # done;
# #
# # loop (IMPLICIT_NODE n, state)
# # =>
# # { do_stuff_with n;
# # loop (next state);
# # };
# # end;
# # end;
# #
# fun next ((tree as IMPLICIT_NODE(_, _, _, _, right_subtree)) . rest) => (tree, left (right_subtree, rest));
# next _ => (IMPLICIT_NULL, []);
# end
#
# also
# fun left (IMPLICIT_NULL, rest)
# =>
# rest;
#
# left (tree as IMPLICIT_NODE(_, left_subtree, _, _, _), rest)
# =>
# left (left_subtree, tree . rest);
# end;
#
# #
# fun start sequence
# =
# left (sequence, []);
#
#
#
# # Given an ordering on sequence values,
# # return an ordering on sequences:
# #
# fun compare_sequences compare_vals
# =
# { fun compare (tree1, tree2)
# =
# case (next tree1, next tree2)
#
# ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) => EQUAL;
# ((IMPLICIT_NULL, _), _ ) => LESS;
# (_, (IMPLICIT_NULL, _)) => GREATER;
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
# (IMPLICIT_NODE(_, _, _, val2, _), r2)
# )
# =>
# case (compare_vals (val1, val2))
# EQUAL => compare (r1, r2);
# order => order;
# esac;
# esac;
#
#
# \\ ( IMPLICIT_SEQUENCE tree1,
# IMPLICIT_SEQUENCE tree2
# )
# =
# compare (start tree1, start tree2);
# };
#
#
#
# # 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 X
# = ZERO
# | ONE ((Int, X, Explicit_Tree(X), Digit(X)) )
# | TWO ((Int, X, Explicit_Tree(X), Int, X, Explicit_Tree(X), Digit(X)) );
#
# # Add a keyval whose key is guaranteed
# # to be larger than any in 'digits':
# #
# fun add_item (key, val, digits)
# =
# incr (key, val, EXPLICIT_EMPTY, digits)
# where
# fun incr (key, val, tree, ZERO) # Incrementing ZERO produces ONE.
# =>
# ONE (key, val, tree, ZERO);
#
# incr ( key1, val1, tree1, # Incrementing a ONE digit produces a TWO digit.
# ONE ( key2, val2, tree2,
# rest
# )
# )
# =>
# TWO ( key1, val1, tree1,
# key2, val2, tree2,
# rest
# );
#
# incr ( key1, val1, tree1, # Incrementing a TWO digit produces a ONE digit -- plus a carry.
# TWO ( key2, val2, tree2,
# key3, val3, tree3,
# rest
# )
# )
# =>
# ONE ( key1, val1, tree1,
# incr ( key2, val2, EXPLICIT_NODE (BLACK, tree3, key3, val3, tree2),
# rest
# )
# );
# end;
# end;
#
# # Link the digits into a tree:
# #
# fun digits_to_explicit_tree digits
# =
# link (digits, EXPLICIT_EMPTY)
# where
# # We consume digits from our first argument and
# # accumulate our eventual result in our second argument:
# #
# fun link (ZERO, result_tree)
# =>
# result_tree;
#
# link ( ONE (key, val, tree, rest),
# result_tree
# )
# =>
# link ( rest,
# EXPLICIT_NODE (BLACK, tree, key, val, result_tree)
# );
#
# link ( TWO ( key1, val1, tree1,
# key2, val2, tree2,
# rest
# ),
#
# result_tree
# )
# =>
# link ( rest,
#
# EXPLICIT_NODE
# ( BLACK,
# EXPLICIT_NODE (RED, tree2, key2, val2, tree1),
# key1, val1,
# result_tree
# )
# );
# end;
# end;
#
#
# fun digits_to_implicit_tree digits
# =
# explicit_tree_to_implicit_tree
# (digits_to_explicit_tree digits);
#
#
# fun digits_to_sequence digits
# =
# IMPLICIT_SEQUENCE (digits_to_implicit_tree digits);
#
#
# fun explicit_from_list list
# =
# loop (ZERO, 0, list)
# where
# fun loop (result, index, [])
# =>
# EXPLICIT_SEQUENCE (index, digits_to_explicit_tree result);
#
# loop (result, index, this . rest)
# =>
# loop (add_item (index, this, result), index + 1, rest );
# end;
# end;
#
# fun implicit_from_list list
# =
# explicit_sequence_to_implicit_sequence (explicit_from_list list);
#
#
# from_list = implicit_from_list;
#
#
# stipulate
#
# #
# fun wrap
# f
# ( IMPLICIT_SEQUENCE m1,
# IMPLICIT_SEQUENCE m2
# )
# =
# { my (n, digits)
# =
# f (start m1, start m2, 0, ZERO);
#
# digits_to_sequence digits;
# };
#
# #
# fun insert'' ((IMPLICIT_NULL, _), n, digits)
# =>
# (n, digits);
#
# insert'' ((IMPLICIT_NODE(_, _, _, val, _), r), n, digits)
# =>
# insert'' (next r, n+1, add_item (n, val, digits));
# end;
# of
#
# # 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.
# #
# fun union_with merge_fn
# =
# wrap union
# where
# fun union (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) => (n, result);
# ((IMPLICIT_NULL, _), tree2 ) => insert'' (tree2, n, result);
# (tree1, (IMPLICIT_NULL, _)) => insert'' (tree1, n, result);
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), rest1),
# (IMPLICIT_NODE(_, _, _, val2, _), rest2)
# )
# =>
# union (rest1, rest2, n+1, add_item (n, merge_fn (val1, val2), result));
# esac;
# end;
#
# #
# fun keyed_union_with merge_fn
# =
# { fun union (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) => (n, result);
# ((IMPLICIT_NULL, _), tree2 ) => insert'' (tree2, n, result);
# (tree1, (IMPLICIT_NULL, _)) => insert'' (tree1, n, result);
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), rest1),
# (IMPLICIT_NODE(_, _, _, val2, _), rest2)
# )
# =>
# union (rest1, rest2, n+1, add_item (n, merge_fn (n, val1, val2), result));
# 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.
# #
# fun intersect_with merge_fn
# =
# { fun intersect (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
# (IMPLICIT_NODE(_, _, _, val2, _), r2)
# )
# =>
# intersect (r1, r2, n+1, add_item (n, merge_fn (val1, val2), result));
#
# _ => (n, result);
# esac;
#
#
# wrap intersect;
# };
# #
# fun keyed_intersect_with merge_fn
# =
# { fun intersect (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
# (IMPLICIT_NODE(_, _, _, val2, _), r2)
# )
# =>
# intersect (r1, r2, n+1, add_item (n, merge_fn (n, val1, val2), result));
#
# _ => (n, result);
# esac;
#
# wrap intersect;
# };
#
# #
# fun merge_with merge_fn
# =
# wrap merge
# where
# fun merge (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ( (IMPLICIT_NULL, _),
# (IMPLICIT_NULL, _)
# )
# =>
# (n, result);
#
# ((IMPLICIT_NULL, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
# =>
# mergef (n, NULL, THE val2, tree1, r2, n, result);
#
# ((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_NULL, _))
# =>
# mergef (n, THE val1, NULL, r1, tree2, n, result);
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
# (IMPLICIT_NODE(_, _, _, val2, _), r2)
# )
# =>
# mergef (n, THE val1, THE val2, r1, r2, n, result);
# esac
#
# also
# fun mergef (k, x1, x2, r1, r2, n, result)
# =
# case (merge_fn (x1, x2))
# THE val2 => merge (r1, r2, n+1, add_item (n, val2, result));
# NULL => merge (r1, r2, n, result );
# esac;
# end;
#
# #
# fun keyed_merge_with merge_fn
# =
# wrap merge
# where
# fun merge (tree1, tree2, n, result)
# =
# case ( next tree1,
# next tree2
# )
#
# ( (IMPLICIT_NULL, _),
# (IMPLICIT_NULL, _)
# )
# =>
# (n, result);
#
# ((IMPLICIT_NULL, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
# =>
# mergef (n, NULL, THE val2, tree1, r2, n, result);
#
# ((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_NULL, _))
# =>
# mergef (n, THE val1, NULL, r1, tree2, n, result);
#
# ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
# (IMPLICIT_NODE(_, _, _, val2, _), r2)
# )
# =>
# mergef (n, THE val1, THE val2, r1, r2, n, result);
# esac
#
# also
# fun mergef (k, x1, x2, r1, r2, n, result)
# =
# case (merge_fn (k, x1, x2))
# THE val2 => merge (r1, r2, n+1, add_item (n, val2, result));
# NULL => merge (r1, r2, n, result);
# esac;
# end;
# end; # stipulate
#
# #
# fun apply f
# =
# { fun appf IMPLICIT_NULL
# =>
# ();
#
# appf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree))
# =>
# { appf left_subtree;
# f val;
# appf right_subtree;
# };
# end;
#
# \\ (IMPLICIT_SEQUENCE m)
# =
# appf m;
# };
#
# #
# fun keyed_apply f
# =
# { fun appf (n, IMPLICIT_NULL)
# =>
# n;
#
# appf (n, IMPLICIT_NODE(_, left, key, val, right))
# =>
# { n = appf (n, left);
# f (n, val);
# appf (n+1, right);
# };
# end;
#
# \\ (IMPLICIT_SEQUENCE (m))
# =
# { appf (0, m);
# ();
# };
# };
#
# #
# fun map f
# =
# { fun mapf IMPLICIT_NULL
# =>
# IMPLICIT_NULL;
#
# mapf (IMPLICIT_NODE (color, left, val_count, val, right))
# =>
# IMPLICIT_NODE (color, mapf left, val_count, f val, mapf right);
# end;
#
# \\ (IMPLICIT_SEQUENCE m)
# =
# IMPLICIT_SEQUENCE (mapf m);
# };
#
# #
# fun keyed_map f
# =
# { fun mapf (n, IMPLICIT_NULL)
# =>
# (n, IMPLICIT_NULL);
#
# mapf (n, IMPLICIT_NODE (color, left_subtree, val_count, val, right_subtree))
# =>
# { my (n, left_subtree' ) = mapf (n, left_subtree);
#
# val' = f (n, val);
#
# my (n, right_subtree') = mapf (n+1, right_subtree);
#
# (n, IMPLICIT_NODE (color, left_subtree', val_count, val', right_subtree'));
# };
# end;
#
# \\ (IMPLICIT_SEQUENCE tree)
# =
# IMPLICIT_SEQUENCE (#2 (mapf (0, tree)));
# };
#
#
#
# # Construct a new sequence containing
# # only those values satisfying 'predicate':
# #
# # The filtering is done in sequence order:
# #
# fun filter predicate (IMPLICIT_SEQUENCE t)
# =
# digits_to_sequence digits
# where
# fun walk (IMPLICIT_NULL, n, digits)
# =>
# digits;
#
# walk (IMPLICIT_NODE(_, left, _, val, right), n, digits)
# =>
# { digits
# =
# walk (left, n, digits);
#
# if predicate val
# then walk (right, n+1, add_item (n, val, digits));
# else walk (right, n, digits); fi;
# };
# end;
#
# digits
# =
# walk (t, 0, ZERO);
# end;
#
# #
# fun keyed_filter predicate (IMPLICIT_SEQUENCE t)
# =
# digits_to_sequence digits
# where
# fun walk (IMPLICIT_NULL, n, result)
# =>
# result;
#
# walk (IMPLICIT_NODE(_, a, _, val, b), n, result)
# =>
# { my result
# =
# walk (a, n, result);
#
# if predicate (n, val)
# then walk (b, n+1, add_item (n, val, result));
# else walk (b, n, result); fi;
# };
# end;
#
# digits
# =
# walk (t, 0, ZERO);
# end;
#
# # Map a partial function
# # over the elements of a map
# # in increasing map order:
# #
# fun map' f
# =
# fold_forward f' empty
# where
# fun f' (val, result)
# =
# case (f val)
# THE val' => push (result, val');
# NULL => result;
# esac;
# end;
#
# #
# fun keyed_map' f
# =
# keyed_fold_forward f' empty
# where
# fun f' (key, val, result)
# =
# case (f (key, val))
# NULL => result;
# THE val' => push (result, val');
# esac;
# end;
};