PreviousUpNext

15.4.962  src/lib/src/red-black-numbered-list.pkg

## 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
=
package {

    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 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::SUBSCRIPT;   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::SUBSCRIPT;
                         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::SUBSCRIPT;   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::SUBSCRIPT;
             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::SUBSCRIPT;   fi;

                removed_value
                    =
                    case (find (input, i))
                      
                         THE value => value;
                         NULL      => raise exception lib_base::NOT_FOUND;
                    esac;

                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), removed_value);
            }
            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;
        
            fn initial_value
                =
                fn (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;
        
            fn initial_value
                =
                fn (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;
        
            fn init
                =
                fn (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;
        
            fn initial_value
                =
                fn (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 (fn (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;

        
            fn  ( 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;
        
            fn (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;
        
            fn (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;
        
            fn (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;
        
            fn (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;
};











Comments and suggestions to: bugs@mythryl.org

PreviousUpNext