## red-black-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-tagged-numbered-list.pkg# src/lib/src/red-black-map-g.pkg # src/lib/src/red-black-set-g.pkg #
# Also, see 'ropes':
# Ropes: an Alternative to Strings (1995) by Hans-J. Boehm , Russ Atkinson , Michael Plass
# http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.14.9450
#
# And apparently red-black trees with fingers
# can be concatenated in logarithmic time:
#
# http://stackoverflow.com/questions/3176863/concatenating-red-black-trees
#
# says
# "An implementation of red-black trees with fingers is described by
# Heather D. Booth in a chapter from her thesis. With fingers, a red-black tree
# of size n can be split into two trees of size p and q in amortized O(lg (min (p,q)))
# time and two red-black trees of size p and q can be concatenated in the same bound.
# Additionally, an element can be added or deleted at either end of an rb tree in
# amortized O(1) time."
#
# with URL for her thesis given as
# http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.4454
# Unit test code in:
# src/lib/src/red-black-sequence-unit-test.pkg# 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.
### ""Beware of bugs in the above code;
### I have only proved it correct, not tried it."
###
### -- Don Knuth
# 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_numbered_list
: Numbered_List # Numbered_List is from src/lib/src/numbered-list.api{
Color = RED | BLACK;
# Tree in which nodes have implicit keys
# derived on-the-fly from node count fields:
#
Numbered_Tree(X)
= IMPLICIT_EMPTY
| IMPLICIT_NODE ( ( Color,
Numbered_Tree(X), # Left subtree.
Int, # Count of nodes in this subtree.
X, # Value.
Numbered_Tree(X) # Right subtree.
) );
# 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 implicitly represented sequences.
# Every complete implicit sequence is represented by one:
#
Numbered_List(X)
=
NUMBERED_LIST
(
Numbered_Tree(X) # Tree containing one node per key-val pair in sequence.
);
# 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.
) );
#
fun is_empty (NUMBERED_LIST (IMPLICIT_EMPTY)) => TRUE;
is_empty _ => FALSE;
end;
empty = NUMBERED_LIST ( IMPLICIT_EMPTY);
fun kids_of IMPLICIT_EMPTY => 0;
kids_of (IMPLICIT_NODE (_,_, kids, _,_)) => kids;
end;
fun implicit_node (color, left, value, right)
=
{ kids = kids_of left
+ kids_of right
+ 1;
IMPLICIT_NODE (color, left, kids, value, right);
};
fun explicit_tree_to_implicit_tree
explicit_tree
=
#2 (to_implicit explicit_tree)
where
# Arg is the root of the subtree to process.
#
# First result is number of values in converted subtree.
# Second result is the converted subtree.
#
fun to_implicit EXPLICIT_EMPTY
=>
(0, IMPLICIT_EMPTY);
to_implicit
(EXPLICIT_NODE (color, left_tree, key, value, right_tree))
=>
{ my ( leftkids, left_tree') = to_implicit left_tree;
my (rightkids, right_tree') = to_implicit right_tree;
value_count # Total number of values in this subtree.
=
leftkids + rightkids + 1;
( value_count,
IMPLICIT_NODE (
color,
left_tree',
value_count,
value,
right_tree'
)
);
};
end;
end;
# Change an Explicit_Sequence
# into an implicit Sequence.
#
# As above, we completely ignore the existing 'key'
# fields and just compute the size of each subtree
# as we go:
#
fun explicit_sequence_to_implicit_sequence (EXPLICIT_SEQUENCE (count, explicit_tree))
=
NUMBERED_LIST (explicit_tree_to_implicit_tree explicit_tree);
#
fun singleton value
=
NUMBERED_LIST (IMPLICIT_NODE (BLACK, IMPLICIT_EMPTY, 1, value, IMPLICIT_EMPTY));
# Check invariants:
#
fun all_invariants_hold (NUMBERED_LIST IMPLICIT_EMPTY )
=>
TRUE;
all_invariants_hold (NUMBERED_LIST (IMPLICIT_NODE (RED,_,_,_,_) ) )
=>
FALSE; # RED root is not ok.
all_invariants_hold (NUMBERED_LIST 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, IMPLICIT_EMPTY)
=>
n == black_depth;
check_blackdepth_on_all_paths (n, IMPLICIT_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, IMPLICIT_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, IMPLICIT_EMPTY) => n;
leftmost_blackdepth (n, IMPLICIT_NODE (RED, left_subtree, _,_,_)) => leftmost_blackdepth (n, left_subtree);
leftmost_blackdepth (n, IMPLICIT_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, IMPLICIT_EMPTY)
=>
TRUE;
red_invariant_ok (parent_was_black, IMPLICIT_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, IMPLICIT_NODE (BLACK, left_subtree, _,_, right_subtree))
=>
red_invariant_ok (TRUE, left_subtree)
and
red_invariant_ok (TRUE, right_subtree);
end;
# The val_count field in every node must
# equal the number of values 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_EMPTY
=>
0;
child_count (IMPLICIT_NODE (_, left_subtree, val_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 (val_count != total) raise exception DOMAIN; fi;
total;
};
end;
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_EMPTY
=>
count;
IMPLICIT_NODE (color, left, keys, value, right)
=>
{ count = debug_print_tree' (left, indent+5, count);
print (do_indent (indent0, []));
printf "%4d: " count;
print_val value;
printf " %d keys" keys;
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_LIST tree,
print_val
)
=
{ print "\n";
debug_print_tree (print_val, tree, 0);
};
#
fun set (NUMBERED_LIST m, key, value)
=
{
if (key < 0 ) raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
case ( set'' (key, value, m))
IMPLICIT_NODE (RED, left, kids, value, right)
=>
# 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.
#
NUMBERED_LIST
(IMPLICIT_NODE (BLACK, left, kids, value, right));
other =>
NUMBERED_LIST other;
esac;
}
where
#
fun set'' (key, value, IMPLICIT_EMPTY)
=>
{ if (key != 0)
raise exception exceptions::INDEX_OUT_OF_BOUNDS;
fi;
IMPLICIT_NODE (RED, IMPLICIT_EMPTY, 1, value, IMPLICIT_EMPTY);
};
set'' (key, value, s as IMPLICIT_NODE (s_color, s_left, s_kids, s_val, s_right))
=>
{ kids_of_s_left
=
kids_of s_left;
order = int::compare (key, kids_of_s_left+1);
case order
LESS
=>
case (s_left)
IMPLICIT_NODE (RED, s_left_left, _, s_left_val, s_left_right)
=>
{ kids_of_s_left_left
=
kids_of s_left_left;
order = int::compare (key, kids_of_s_left_left+1);
case order
LESS
=>
case (set'' (key, value, s_left_left))
IMPLICIT_NODE (RED, r_left, _, r_val, r_right)
=>
implicit_node
(
RED,
implicit_node (BLACK, r_left, r_val, r_right),
s_left_val,
implicit_node (BLACK, s_left_right, s_val, s_right)
);
s_left_left
=>
implicit_node
(
BLACK,
implicit_node (RED, s_left_left, s_left_val, s_left_right),
s_val,
s_right
);
esac;
(GREATER | EQUAL)
=>
{
if (order == EQUAL)
# 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 (value, s_left_val) = (s_left_val, value);
key = key + 1;
fi;
case (set'' (key - (kids_of_s_left_left + 1), value, s_left_right))
IMPLICIT_NODE (RED, r_left, _, r_val, r_right)
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left_left, s_left_val, r_left),
r_val,
implicit_node (BLACK, r_right, s_val, s_right)
);
s_left_right
=>
implicit_node
(
BLACK,
implicit_node (RED, s_left_left, s_left_val, s_left_right),
s_val,
s_right
);
esac;
};
esac;
};
_ =>
implicit_node (BLACK, set'' (key, value, s_left), s_val, s_right);
esac;
(GREATER | EQUAL)
=>
{
if (order == EQUAL)
# 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 (value, s_val) = (s_val, value);
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 - (kids_of_s_left + 1);
case s_right
IMPLICIT_NODE (RED, s_right_left, s_right_kids, s_right_val, s_right_right)
=>
{ kids_of_s_right_left
=
kids_of s_right_left;
order = int::compare (key, kids_of_s_right_left+1);
case order
LESS
=>
case (set'' (key, value, s_right_left))
IMPLICIT_NODE (RED, r_left, _, r_val, r_right)
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left, s_val, r_left),
r_val,
implicit_node (BLACK, r_right, s_right_val, s_right_right)
);
s_right_left
=>
implicit_node
(
BLACK,
s_left,
s_val,
implicit_node (RED, s_right_left, s_right_val, s_right_right)
);
esac;
(GREATER | EQUAL)
=>
{
if (order == EQUAL)
# 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 (value, s_right_val) = (s_right_val, value);
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 - (kids_of_s_right_left + 1);
case (set'' (key, value, s_right_right))
IMPLICIT_NODE (RED, r_left, _, r_val, r_right)
=>
implicit_node
(
RED,
implicit_node (BLACK, s_left, s_val, s_right_left),
s_right_val,
implicit_node (BLACK, r_left, r_val, r_right)
);
s_right_right
=>
implicit_node
(
BLACK,
s_left,
s_val,
implicit_node (RED, s_right_left, s_right_val, s_right_right)
);
esac;
};
esac;
};
_ =>
implicit_node (BLACK, s_left, s_val, set'' (key, value, s_right));
esac;
};
esac;
};
end;
end;
# A synonym for 'set', so that we can write
# map $= (key, value);
# instead of the clumsier
# map = set( map, key, value );
#
fun m $ (key1, val1)
=
set (m, key1, val1);
#
fun set' ((key1, val1), m)
=
set (m, key1, val1);
fun min_key (NUMBERED_LIST (IMPLICIT_EMPTY )) => NULL;
min_key _ => THE 0;
end;
fun max_key (NUMBERED_LIST (IMPLICIT_EMPTY )) => NULL;
max_key (NUMBERED_LIST (IMPLICIT_NODE (_,_, kids, _,_))) => THE (kids - 1);
end;
# Is a key in the domain of the sequence?
#
fun contains_key (sequence, key)
=
case (max_key sequence)
#
NULL => FALSE;
THE n => key >= 0 and
key <= n;
esac;
# Return (THE value) corresponding to a key,
# or NULL if the key is not present:
#
fun find (NUMBERED_LIST tree, key)
=
find' (tree, key)
where
fun find' (IMPLICIT_EMPTY, key)
=>
NULL;
find' ((IMPLICIT_NODE(_, left, kids2, val2, right)), key)
=>
{ left_kids = kids_of left;
#
if (key < 0) raise exception exceptions::INDEX_OUT_OF_BOUNDS; fi;
case (int::compare (key, left_kids))
#
LESS => find' (left, key);
EQUAL => THE val2;
GREATER => find' (right, key - (left_kids+1));
esac;
};
end;
end;
fun get (sequence, i)
=
case (find (sequence, i))
#
NULL => raise exception exceptions::INDEX_OUT_OF_BOUNDS;
THE value => value;
esac;
# Note: The (_[]) enables 'vec[index]' notation;
#
my (_[]) = get;
# Remove a keyval, returning new sequence and value removed.
# 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, Numbered_Tree(X), Descent_Path(X)) ) # Descent went left; remember node's value and right subtree.
| WENT_RIGHT ((Color, X, Numbered_Tree(X), Descent_Path(X)) ); # Descent went right; remember node's value and left subtree.
herein
# Remove the i-th value from a Sequence,
# returning the new Sequence and also
# the removed value.
#
# 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 (
input as NUMBERED_LIST (input_tree),
i
)
=
{ # Sanity check:
#
if (i < 0) 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 (RED, left_subtree, val_count, value, right_subtree)
=>
IMPLICIT_NODE (BLACK, left_subtree, val_count, value, right_subtree);
ok => ok;
esac;
NUMBERED_LIST (new_tree);
}
where
fun color_name RED => "RED";
color_name BLACK => "BLACK";
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, value, right_subtree, rest_of_path), left_subtree) => copy_path (rest_of_path, implicit_node (color, left_subtree, value, right_subtree));
copy_path (WENT_RIGHT (color, value, left_subtree, rest_of_path), right_subtree) => copy_path (rest_of_path, implicit_node (color, left_subtree, value, 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, IMPLICIT_NODE (RED, c, _, val2, d), path), a) # Case 1L
=>
copy_path' (WENT_LEFT (RED, val1, c, WENT_LEFT (BLACK, val2, 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, IMPLICIT_NODE (RED, c, _, val2, d), path), b) # Case 1R
=>
copy_path' (WENT_RIGHT (RED, val1, d, WENT_RIGHT (BLACK, val2, 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, IMPLICIT_NODE (BLACK, IMPLICIT_NODE (RED, c, _, val2, d), _, val3, e), path), a) # Case 3L
=>
copy_path' (WENT_LEFT (color, val1, implicit_node (BLACK, c, val2, implicit_node (RED, d, val3, 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, IMPLICIT_NODE (BLACK, c, _, val2, IMPLICIT_NODE (RED, d, _, val3, e)), path), b) # Case 4R
=>
copy_path' (WENT_RIGHT (color, val1, implicit_node (BLACK, implicit_node (RED, c, val2, d), val3, e), path), b);
# 1 2 Wikipedia Case 5 (Mirrored)
# / \ / \
# 2B b -> c 1B
# c 3R 3R b
# d e d e
#
# OLD BROKEN CODE (FALSE, copy_path (path, implicit_node (color, c, val2, implicit_node (BLACK, implicit_node (RED, d, val3, e), val1, b))));
# 1X 2X Wikipedia Case 6
# / \ / \
# a 2B -> 1B 3B
# c 3R a c d e
# d e
#
copy_path' (WENT_LEFT (color, val1, IMPLICIT_NODE (BLACK, c, _, val2, IMPLICIT_NODE (RED, d, _, val3, e)), path), a) # Case 4L
=>
(FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, a, val1, c), val2, implicit_node (BLACK, d, val3, 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, IMPLICIT_NODE (BLACK, IMPLICIT_NODE (RED, c, _, val3, d), _, val2, e), path), b) # Case 3R
=>
(FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, c, val3, d), val2, implicit_node (BLACK, e, val1, b))));
# 1 1
# / \ / \
# 2B b -> 3B b
# 3R e c 2R
# c d d e
#
# OLD BROKEN CODE copy_path' (WENT_RIGHT (color, val1, implicit_node (BLACK, c, val3, implicit_node (RED, d, val2, e)), path), b);
# 1B 1B Wikipedia Case 3
# / \ / \
# a 2B -> a 2R
# c d c d
#
copy_path' (WENT_LEFT (BLACK, val1, IMPLICIT_NODE (BLACK, c, _, val2, d), path), a) # Case 2L
=>
copy_path' (path, implicit_node (BLACK, a, val1, implicit_node (RED, c, val2, 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, IMPLICIT_NODE (BLACK, c, _, val2, d), path), b) # Case 2R
=>
copy_path' (path, implicit_node (BLACK, implicit_node (RED, c, val2, d), val1, 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, IMPLICIT_NODE (BLACK, c, _, val2, d), path), a) # Case 2L
=>
(FALSE, copy_path (path, implicit_node (BLACK, a, val1, implicit_node (RED, c, val2, 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, IMPLICIT_NODE (BLACK, c, _, val2, d), path), b) # Case 2R
=>
(FALSE, copy_path (path, implicit_node (BLACK, implicit_node (RED, c, val2, d), val1, 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_EMPTY, descent_path)
=>
raise exception lib_base::NOT_FOUND;
descend (node_to_delete, IMPLICIT_NODE (color, left_subtree, kidcount, value, right_subtree), descent_path)
=>
{ left_kids
=
kids_of left_subtree;
case (int::compare (node_to_delete, left_kids))
LESS => descend (node_to_delete, left_subtree, WENT_LEFT (color, value, right_subtree, descent_path));
GREATER => descend (node_to_delete - (left_kids + 1), right_subtree, WENT_RIGHT (color, value, left_subtree, 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, IMPLICIT_EMPTY, IMPLICIT_EMPTY, descent_path) => copy_path (descent_path, IMPLICIT_EMPTY);
join (RED, left_subtree, IMPLICIT_EMPTY, descent_path) => copy_path (descent_path, left_subtree );
join (RED, IMPLICIT_EMPTY, right_subtree, descent_path) => copy_path (descent_path, right_subtree );
join (BLACK, left_subtree, IMPLICIT_EMPTY, descent_path) => #2 (copy_path' (descent_path, left_subtree));
join (BLACK, IMPLICIT_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 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:
#
replacement_value = 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, left_subtree, descent_path) );
}
where
#
fun min_val (IMPLICIT_NODE (_, IMPLICIT_EMPTY, _, value, _)) => value;
min_val (IMPLICIT_NODE (_, left_subtree, _, _, _)) => min_val left_subtree;
min_val IMPLICIT_EMPTY => raise exception MATCH; # "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 (NUMBERED_LIST (tree))
=
leftmost_descendent tree
where
fun leftmost_descendent IMPLICIT_EMPTY => NULL;
leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_EMPTY, _, value, _)) => THE value;
leftmost_descendent (IMPLICIT_NODE(_, left_subtree, _, _, _)) => leftmost_descendent left_subtree;
end;
end;
#
fun first_keyval_else_null (NUMBERED_LIST (tree))
=
leftmost_descendent tree
where
fun leftmost_descendent IMPLICIT_EMPTY => NULL;
leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_EMPTY, _, value, _)) => THE (0, value);
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_EMPTY => NULL;
rightmost_descendent (IMPLICIT_NODE(_,_,_, value, IMPLICIT_EMPTY)) => THE value;
rightmost_descendent (IMPLICIT_NODE(_,_,_, _, right_subtree )) => rightmost_descendent right_subtree;
end;
herein
fun last_val_else_null (NUMBERED_LIST (tree))
=
rightmost_descendent tree;
#
fun last_keyval_else_null (NUMBERED_LIST (IMPLICIT_EMPTY))
=>
NULL;
last_keyval_else_null (NUMBERED_LIST (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 (NUMBERED_LIST (IMPLICIT_EMPTY )) => 0;
vals_count (NUMBERED_LIST (IMPLICIT_NODE (_,_, kids, _,_))) => kids;
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, value)
=
set (sequence, 0, value);
# 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, value)
=
set (sequence, vals_count sequence, value);
# Call
# f (value, result_so_far)
# once for every value in the sequence, in order,
# returning the final result:
#
fun fold_forward f
=
{ fun foldf (IMPLICIT_EMPTY, result)
=>
result;
foldf (IMPLICIT_NODE(_, left_subtree, _, value, right_subtree), result)
=>
foldf (right_subtree, f (value, foldf (left_subtree, result)));
end;
\\ initial_value
=
\\ (NUMBERED_LIST (tree))
=
foldf (tree, initial_value);
};
# Call
# f (key, value, result_so_far)
# once for every key, value pair in the sequence,
# in order, returning the final result:
#
#
fun keyed_fold_forward f
=
{ fun foldf (IMPLICIT_EMPTY, result, key)
=>
(result, key);
foldf (IMPLICIT_NODE(_, left_subtree, _, value, right_subtree), result, key)
=>
{ my (result, key)
=
foldf (left_subtree, result, key);
result
=
f (key, value, result);
foldf (right_subtree, result, key+1);
};
end;
\\ initial_value
=
\\ (NUMBERED_LIST (tree))
=
{ my (result, _) = foldf (tree, initial_value, 0);
result;
};
};
#
fun fold_backward f
=
{ fun foldf (IMPLICIT_EMPTY, accum)
=>
accum;
foldf (IMPLICIT_NODE(_, left, _, value, right), accum)
=>
foldf (left, f (value, foldf (right, accum)));
end;
\\ init
=
\\ (NUMBERED_LIST (m))
=
foldf (m, init);
};
#
fun keyed_fold_backward f
=
{ fun foldf (IMPLICIT_EMPTY, result, key)
=>
(result, key);
foldf (IMPLICIT_NODE(_, left_subtree, _, value, right_subtree), result, key)
=>
{ my (result, key)
=
foldf (right_subtree, result, key);
result
=
f (key, value, result);
foldf (left_subtree, result, key - 1);
};
end;
\\ initial_value
=
\\ (NUMBERED_LIST IMPLICIT_EMPTY)
=>
initial_value;
(seq as (NUMBERED_LIST (tree as IMPLICIT_NODE (_,_, val_count,_,_))))
=>
{ my (result, _) = foldf (tree, initial_value, val_count - 1);
result;
};
end;
};
#
fun vals_list sequence
=
fold_backward (!) [] 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_EMPTY, _)
# =>
# (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_EMPTY, []);
end
also
fun left (IMPLICIT_EMPTY, 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 cmp (tree1, tree2)
=
case (next tree1, next tree2)
((IMPLICIT_EMPTY, _), (IMPLICIT_EMPTY, _)) => EQUAL;
((IMPLICIT_EMPTY, _), _ ) => LESS;
(_, (IMPLICIT_EMPTY, _)) => GREATER;
( (IMPLICIT_NODE(_, _, _, val1, _), r1),
(IMPLICIT_NODE(_, _, _, val2, _), r2)
)
=>
case (compare_vals (val1, val2))
EQUAL => cmp (r1, r2);
order => order;
esac;
esac;
\\ ( NUMBERED_LIST (tree1),
NUMBERED_LIST (tree2)
)
=
cmp (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, value, digits)
=
incr (key, value, EXPLICIT_EMPTY, digits)
where
fun incr (key, value, tree, ZERO) # Incrementing ZERO produces ONE.
=>
ONE (key, value, 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, value, tree, rest),
result_tree
)
=>
link ( rest,
EXPLICIT_NODE (BLACK, tree, key, value, 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
=
NUMBERED_LIST (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
( NUMBERED_LIST m1,
NUMBERED_LIST m2
)
=
{ my (n, digits)
=
f (start m1, start m2, 0, ZERO);
digits_to_sequence digits;
};
#
fun set'' ((IMPLICIT_EMPTY, _), n, digits)
=>
(n, digits);
set'' ((IMPLICIT_NODE(_, _, _, value, _), r), n, digits)
=>
set'' (next r, n+1, add_item (n, value, digits));
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.
#
fun union_with merge_fn
=
wrap union
where
fun union (tree1, tree2, n, result)
=
case ( next tree1,
next tree2
)
((IMPLICIT_EMPTY, _), (IMPLICIT_EMPTY, _)) => (n, result);
((IMPLICIT_EMPTY, _), tree2 ) => set'' (tree2, n, result);
(tree1, (IMPLICIT_EMPTY, _)) => set'' (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_EMPTY, _), (IMPLICIT_EMPTY, _)) => (n, result);
((IMPLICIT_EMPTY, _), tree2 ) => set'' (tree2, n, result);
(tree1, (IMPLICIT_EMPTY, _)) => set'' (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_EMPTY, _),
(IMPLICIT_EMPTY, _)
)
=>
(n, result);
((IMPLICIT_EMPTY, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
=>
mergef (n, NULL, THE val2, tree1, r2, n, result);
((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_EMPTY, _))
=>
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_EMPTY, _),
(IMPLICIT_EMPTY, _)
)
=>
(n, result);
((IMPLICIT_EMPTY, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
=>
mergef (n, NULL, THE val2, tree1, r2, n, result);
((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_EMPTY, _))
=>
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_EMPTY
=>
();
appf (IMPLICIT_NODE(_, left_subtree, _, value, right_subtree))
=>
{ appf left_subtree;
f value;
appf right_subtree;
};
end;
\\ (NUMBERED_LIST m)
=
appf m;
};
#
fun keyed_apply f
=
{ fun appf (n, IMPLICIT_EMPTY)
=>
n;
appf (n, IMPLICIT_NODE(_, left, key, value, right))
=>
{ n = appf (n, left);
f (n, value);
appf (n+1, right);
};
end;
\\ (NUMBERED_LIST (m))
=
{ appf (0, m);
();
};
};
#
fun map f
=
{ fun mapf IMPLICIT_EMPTY
=>
IMPLICIT_EMPTY;
mapf (IMPLICIT_NODE (color, left, val_count, value, right))
=>
IMPLICIT_NODE (color, mapf left, val_count, f value, mapf right);
end;
\\ (NUMBERED_LIST m)
=
NUMBERED_LIST (mapf m);
};
#
fun keyed_map f
=
{ fun mapf (n, IMPLICIT_NODE (color, left_subtree, val_count, value, right_subtree))
=>
{ my (n, left_subtree' ) = mapf (n, left_subtree);
value' = f (n, value);
my (n, right_subtree') = mapf (n+1, right_subtree);
(n, IMPLICIT_NODE (color, left_subtree', val_count, value', right_subtree'));
};
mapf (n, IMPLICIT_EMPTY)
=>
(n, IMPLICIT_EMPTY);
end;
\\ (NUMBERED_LIST tree)
=
NUMBERED_LIST (#2 (mapf (0, tree)));
};
# Construct a new sequence containing
# only those values satisfying 'predicate':
#
# The filtering is done in sequence order:
#
fun filter predicate (NUMBERED_LIST(t))
=
digits_to_sequence digits
where
fun walk (IMPLICIT_EMPTY, n, digits)
=>
digits;
walk (IMPLICIT_NODE(_, left, _, value, right), n, digits)
=>
{ digits = walk (left, n, digits);
if (predicate value) walk (right, n+1, add_item (n, value, digits));
else walk (right, n, digits);
fi;
};
end;
digits
=
walk (t, 0, ZERO);
end;
#
fun keyed_filter predicate (NUMBERED_LIST t)
=
digits_to_sequence digits
where
fun walk (IMPLICIT_NODE(_, a, _, value, b), n, result)
=>
{ result = walk (a, n, result);
if (predicate (n, value)) walk (b, n+1, add_item (n, value, result));
else walk (b, n, result);
fi;
};
walk (IMPLICIT_EMPTY, n, result)
=>
(result);
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' (value, result)
=
case (f value)
THE value' => push (result, value');
NULL => result;
esac;
end;
#
fun keyed_map' f
=
keyed_fold_forward f' empty
where
fun f' (key, value, result)
=
case (f (key, value))
NULL => result;
THE value' => push (result, value');
esac;
end;
};