PreviousUpNext

15.4.969  src/lib/src/red-black-tagged-numbered-list.pkg

## red-black-tagged-numbered-list.pkg

# Compiled by:
#     src/lib/std/standard.lib

# Compare with:
#     src/lib/src/binary-random-access-list.pkg
#     src/lib/src/red-black-numbered-list.pkg

# Unit test code in:
#     src/lib/src/red-black-tagged-numbered-list-unit-test.pkg

#########################################################################
#########################################################################

#                          TO DO

# 2008-02-13
#
# Probably 'sub' and 'update' should become 'get' and 'set' everywhere.
# Making 'insert' and 'remove' into 'put' and 'del' would fit the 3-char pattern.
# The set operations 'add' and 'delete' should probably also be just 'put' and 'del'
# -- trying to have different names for the same ops in every file is the road to madness.
#
# Now that I grok that numbering can be added to any of the vanilla trees,
# some naming rationalization is probably in order:
#
#  o Both of the standard red-black tree types ('map' and 'set')
#    can have a Numbered_ variant which keeps and uses 'nodes'
#    (count of nodes in subtree) fields in each node.
#
#  o 'set' is just 'map' sans value fields, and 'sequence' is just
#    'set' sans key fields, so the naming should reflect that:
#    'Numbered_List' maybe.
#
#  o Since numbering is basically a mixin that can be added to
#    the standard trees, the numbering-specific operations need
#    to have names which don't overlap the regular set/map operation
#    names.
#
#  o Tagging maps and sets is pointless because the tags do
#    nothing that the existing key fields don't already do.
#    Tagging is essentially synthesizing an invisible set of
#    unique ordered keys.
#    
#  o Supporting access to i-th char, i-th line etc
#    (in addition to i-th node) can also be done as a
#    monotonic mixin to the vanilla 'set' and 'map'
#    classes.
#
#  o I dunno if we can or should have master source files that
#    generate all these tree flavors.  This may be an example
#    of a case where vanilla C-style #IFDEF cases would get the
#    job done better than generics.

# 2008-02-12
#
# This version uses 'up' pointers to parent nodes
# and is thus imperative -- you can't share a node
# which has a pointer to its parent.  Ick! :)  I did it
# this way because I couldn't figure out a fully-persisent
# way of doing it.
#
# Scott Crosby provided me with a better solution:
#
#  o Junk the 'up' pointers and the current 'tag' pointers.
#
#  o External node tags become integers;
#    we can just allocate them sequentially.
#
#  o Each node has a 'tag' field holding its tag.
#
#  o Each node also holds an integer 'key' field.
#
#  o The tree is kept sorted by 'key' field.  We keep the
#    key numbers dense enough to fit in a 31-bit integer,
#    but sparse enough that insertions can usually be
#    done without needing to re-key;  when necessary,
#    we re-key in the usual order maintenance fashion.
#    (I'd guess 1/8 density is a good target, re-keying
#    when it rises above 1/2 or drops below 1/32.)
#
#  o We use a vanilla red-black tree to map tags to keys.
#    When we re-key nodes, we update this mapping.
#    Tags never have to change, and never do.
#
#  Now everything works cleanly:
#
#  o When inserting, we pick a new node key anywhere between
#    the existing neighbors (maybe stopping to re-key as needed),
#    assign a new tag sequentially, enter the new tag->key
#    mapping into our tag table, and return the tag.
#
#  o When deleting a node, we use the tag in it to
#    delete the tag->key mapping from the tag table.
#
#  o To find a node by sequence position, we dive down the
#    tree guided by the nodes-in-this-subtree fields.
#
#  o To find a node by tag, we map tag to key, then
#    dive down the tree doing a conventional binary lookup
#    on the 'key' fields.  As we go, we can also sum
#    predecessor nodes, and thus compute the sequence
#    position of the node/value named by the tag.
#

#########################################################################
#########################################################################

# Implementation of applicative-style
# (side-effect free) sequences.
#
# By a "sequence" we here mean essentially a
# numbered list.  Our motivation is to support
# such things as representing a text document in
# memory as a sequence of lines supporting easy
# insertion and deletion of lines for editing.
#
# We implement this by adapting our tried-and-true
# red-black trees.
#
# The obvious idea of representing a sequence by a
# vanilla red-black tree which maps successive integers
# to values fails because when we insert or delete the i-th value,
# we would have to explicitly renumber all subsequent values
# in the sequence, which would be intolerably slow -- it would
# make INSERT and DELETE O(N) instead of O(log(N)).
#
# We avoid this renumbering by representing keys less explicitly:
# in each node we store not the key itself, but rather the count
# of values (nodes) in the subtree rooted at that point.
#
# This information can easily be updated in log(N) time as we insert
# and delete, and is sufficient to allow us to efficiently compute
# the actual integer key value for each node on the fly as we do so.
# (For example, the key of the root node is the number of values in
# its left subtree, which can be computed in O(1) time just by
# examining the root node of its left subtree.)
#
# The converse idea is implemented in
#
#     src/lib/src/red-black-numbered-set-g.pkg
#
# This code is based on Chris Okasaki's implementation of
# red-black trees.  The linear-time tree construction code is
# based on the paper "Constructing red-black trees" by Ralf Hinze,
#   http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
# and the delete function is based on the description in Cormen,
# Leiserson, and Rivest.
#
# Wikipedia has a good discussion of basic insertion and deletion:
#     http://en.wikipedia.org/wiki/Red_black_tree
#
# A red-black tree should satisfy the following two invariants:
#
#   Red Invariant:    Each red node has a black parent.
#
#   Black Condition:  Each path from the root to an empty node
#                     has the same number of black nodes
#                     (the tree's black height).
#
# The Red condition implies that the root is always black and the Black
# condition implies that any node with only one child will be black and
# its child will be a red leaf.






# To do:
#
#  o  Should write a converse implementation in
#     which the keys are vanilla and the values
#     are nodes-in-subtree counts.  I'd call
#     it "Numbering":  It is useful for mapping
#     from an arbitrary key sequence to a dense
#     integer numbering 0..N-1.
#       (The fourth logical combination, in which
#     both key and val fields are nodecounts, is
#     of limited practical utility. ;-)
#
#  o  I believe the from_list/digits stuff can be
#     rewritten without too much effort to use
#     Implicit_Tree instead of  Explicit_Tree.
#
#     If so, at that point it should be practical
#     to delete all the Explicit_Tree stuff, and
#     then drop the "Implicit_" and "IMPLICIT_"
#     prefices.
#
#     Also, I think the IMPLICIT_SEQUENCE headers
#     could be dispensed with.
#
#  o  We should probably implement a '@'
#     append operator, maybe even 'cat'.
#
#  o  We should probably implement a sub-sequence
#     extraction operator, along the lines of that
#     supplied for Vector &Co.  More generally,
#     we should perhaps support the Vector interface,
#     to allow using Sequence as a drop-in replacement
#     for Vector when desired. 
#  
#  o  It should be practical to rewrite so as to
#     use space much more efficiently:
#
#      *  Make color implicit in the header rather
#         than an explicit field.
#
#      *  Eliminate EMPTY fields by making them
#         implicit in the header as well.
#
#      *  (Maybe) store 1-4 values per leaf node
#         instead of always just one.
#
#     It may be that this is just a bass-ackwards
#     way of re-inventing 2-3-4 trees...?  (I've
#     never really looked at them.)
#
#     If so, it might make more sense just to do a
#     from-scratch implementation of them, and
#     leave the existing red-black code alone.

package red_black_tagged_numbered_list
:                 Tagged_Numbered_List                                          # Tagged_Numbered_List  is from   src/lib/src/tagged-numbered-list.api
{
    Color
        =
        RED | BLACK;


    # Tree in which nodes have implicit keys
    # derived on-the-fly from node count fields:
    #
    Implicit_Tree X
        = IMPLICIT_NULL
        | IMPLICIT_NODE
            { color: Color,
              left:  Implicit_Tree(X),                          # Left subtree.
              key:   Int,                                       # Unique ID, because Mythryl does not have pointer equality.
              val:   X,                                         # Value.
              tag:   Int,                                       # Tag for this value.
              right: Implicit_Tree(X),                          # Right subtree.
              nodes: Int                                        # Count of nodes in this subtree.
            };

    # Header node for tagged sequences.
    # Since we update tagged sequences via side-effects,
    # this has to be an updatable reference:
    #
    Tagged_Numbered_List X
        =
        TAGGED_SEQUENCE( Implicit_Tree(X) );

    # Tag for a value in an Implicit_Tree:
    #
    Tag(X) =  Int;



#    # Tree in which nodes have explicit keys:
#    #
#    Explicit_Tree X
#       = EXPLICIT_EMPTY
#       | EXPLICIT_NODE  ( ( Color,
#                         Explicit_Tree(X),                     # Left subtree.
#                         Int,                                  # Key.
#                         X,                                    # Value.
#                         Explicit_Tree(X)                      # Right subtree.
#                     ) );

#    # Header node for explicitly represented sequences.
#    # Every complete explicit sequence is represented by one:
#    #
#    Explicit_Sequence X
#        =
#        EXPLICIT_SEQUENCE
#            ( ( Int,                                           # Count of nodes in the tree -- zero for an empty sequence.
#                Explicit_Tree(X)                               # Tree containing one node per key-val pair in sequence.
#            ) );


    my next_tag = REF 0;

    #
    empty = TAGGED_SEQUENCE IMPLICIT_NULL;

    #
    fun is_empty (TAGGED_SEQUENCE IMPLICIT_NULL) =>  TRUE;
        is_empty _                               =>  FALSE;
    end;

#    fun tag_value (REF (IMPLICIT_NODE { val, ... })) =>  val;
#        tag_value (REF IMPLICIT_NULL)                =>  raise exception IMPOSSIBLE;
#    end;

    fun nodes_in  IMPLICIT_NULL                  =>  0;
        nodes_in (IMPLICIT_NODE  { nodes, ... }) =>  nodes;
    end;

    fun implicit_node (color, left, key, val, tag, right)
        =
        {   nodes =  nodes_in  left
                  +  nodes_in  right
                  +  1;

            IMPLICIT_NODE { color, left, key, val, tag, right, nodes };
        };


    # Check invariants:
    #
    fun all_invariants_hold ((TAGGED_SEQUENCE IMPLICIT_NULL): Tagged_Numbered_List(X))
            =>
            TRUE;

        all_invariants_hold (TAGGED_SEQUENCE (IMPLICIT_NODE { color => RED, ... } ) )
            =>
            FALSE;      # RED root is not ok.

        all_invariants_hold (TAGGED_SEQUENCE tree)
            =>
            (   black_invariant_ok  tree
                and
                red_invariant_ok   (TRUE, tree)
                and
                child_counts_ok     tree
#               and
#               tags_ok             tree
            )
            where
                # Every path from root to any leaf must
                # contain the same number of BLACK nodes:
                #
                fun black_invariant_ok  tree
                    =
                    {   # Compute the black depth along one
                        # arbitrary path for reference:
                        #
                        black_depth = leftmost_blackdepth (0, tree);

                        # Check that black depth along all other paths matches:
                        #
                        check_blackdepth_on_all_paths (0, tree)
                        where

                            fun check_blackdepth_on_all_paths (n, IMPLICIT_NULL)
                                    =>
                                    n == black_depth;

                                check_blackdepth_on_all_paths (n, IMPLICIT_NODE { color => BLACK, left, right, ...  })
                                    =>
                                    check_blackdepth_on_all_paths (n+1,  left)
                                    and
                                    check_blackdepth_on_all_paths (n+1, right);


                                check_blackdepth_on_all_paths (n, IMPLICIT_NODE { color => RED, left, right, ...  })
                                    =>
                                    check_blackdepth_on_all_paths (n,  left)
                                    and
                                    check_blackdepth_on_all_paths (n, right);
                            end;
                        end;
                    }
                    where
                        fun leftmost_blackdepth (n, IMPLICIT_NULL)                                =>  n;
                            leftmost_blackdepth (n, IMPLICIT_NODE { color => RED,   left, ... }) =>  leftmost_blackdepth (n,   left);
                            leftmost_blackdepth (n, IMPLICIT_NODE { color => BLACK, left, ... }) =>  leftmost_blackdepth (n+1, left);
                        end;
                    end;

                # A RED node must always have a BLACK parent:
                #
                fun red_invariant_ok  (parent_was_black, IMPLICIT_NULL)
                        =>
                        TRUE;

                    red_invariant_ok  (parent_was_black, IMPLICIT_NODE { color => RED, left, right, ... })
                        =>
                         parent_was_black
                        and
                        red_invariant_ok  (FALSE,  left)
                        and
                        red_invariant_ok  (FALSE, right);

                    red_invariant_ok  (parent_was_black, IMPLICIT_NODE { color => BLACK, left, right, ... })
                        =>
                        red_invariant_ok  (TRUE,  left)
                        and
                        red_invariant_ok  (TRUE, right);

                end;

                # The nodes field in every node must
                # equal the number of nodes in that subtree:
                #
                fun child_counts_ok tree
                    =
                    {   {   child_count tree;
                            TRUE;
                        }
                        except DOMAIN = FALSE;
                    }
                    where
                        # Count and return number of values in a subtree;
                        # raise DOMAIN exception if the val_count field
                        # in any node is incorrect:
                        #
                        fun child_count   IMPLICIT_NULL
                                =>
                                0;

                            child_count   (IMPLICIT_NODE { nodes, left, right, ... })
                                =>
                                {    left_count  =  child_count   left;
                                     right_count =  child_count  right;

                                     total       =  left_count + right_count + 1;       # +1 for the value in this node.

                                     if   nodes != total   then   raise exception DOMAIN;   fi;

                                     total;
                                };
                        end;
                    end;

                # The tag for every node must point back to it:
                #
#                fun tags_ok IMPLICIT_NULL
#                        =>
#                        TRUE;
#
#                    tags_ok  (IMPLICIT_NODE { id, left, tag, right, ... })
#                        =>
#                        tags_ok  left
#                        and
#                        tags_ok right
#                        and
#                        case *tag
#                             IMPLICIT_NODE { id => id', ... } =>  { if id != id' then printf "tag for node %d points to node %d?!\n" id id'; fi; id == id'; };
#                             IMPLICIT_NULL                    =>  FALSE;                       # "Impossible".
#                        esac;
#                end;


            end;
    end;

    # A debugging 'print' to show
    # structure of tree:
    #
    fun debug_print_tree (print_val, tree, indent0)
        =
        debug_print_tree' (tree, 4, 0)
        where
            fun debug_print_tree' (tree, indent, count)
                =
                case tree

                     IMPLICIT_NULL
                         =>
                         count;

                     IMPLICIT_NODE { color, left, key, val, tag, right, nodes }
                         =>
                         {   count = debug_print_tree' (left, indent+5, count);

                             print (do_indent (indent0, []));

                             printf "%4d: "  count;
                             print_val val;
                             printf " %4d nodes"   nodes;
                             printf " %4d key"     key;
                             printf " %4d tag"     tag;

                             print  "    "; 

                             pad1_string   =  do_indent (indent, []);
                             color_string  =  case color   RED => "RED"; BLACK => "BLACK"; esac;
                             string        =  pad1_string + color_string;
                             size          =  string::length string;
                             pad2_string   =  do_indent (40-size, []);
                             print  string;
                             print  pad2_string;

                             print "\n";

                             debug_print_tree' (right, indent+5, count+1);
                         }
                         where
                             fun do_indent (n, l)
                                 =
                                 if n > 0 then   { do_indent (n - 1, " " . l); };
                                          else cat l;  fi;
                         end;
                esac;
        end;

    fun debug_print ( REF tree,
                      print_val
                    )
        =
        {   print "\n";
            debug_print_tree (print_val, tree, 0);
        };

    #
    fun insert (header as (TAGGED_SEQUENCE tree), i, val)
        =
        {
            if   i < 0   then  raise exception exceptions::SUBSCRIPT;   fi;

            new_tree
                =
                case  (insert'' (i, val, tree))

                      IMPLICIT_NODE { color => RED, left, key, val, tag, right, nodes }
                          =>
                          # Enforce invariant that root is always BLACK.
                          #     (It is always safe to change the root from
                          # RED to BLACK.)
                          #     
                          #     Since the well-tested SML/NJ code returns
                          # trees with RED roots, this may not be necessary.
                          #     
                          {   result  =  implicit_node (BLACK, left, key, val, tag, right);
                              tag :=  result;
                              result;
                          };

                      other =>
                          other;

                esac;

            header := new_tree;

            result_tag;
        }
        where 

            #
            fun insert'' (i, val, IMPLICIT_NULL)
                    =>
                    {    if   i != 0
                         then
                              raise exception exceptions::SUBSCRIPT;
                         fi;

                         implicit_node (RED, IMPLICIT_NULL, val, result_tag, IMPLICIT_NULL);
                    };

                insert'' (key, val, s as IMPLICIT_NODE { color => s_color, left => s_left, nodes => s_nodes, val => s_val, tag => s_tag, right => s_right, ... })
                    =>
                    {   nodes_in_s_left
                            =
                            nodes_in  s_left;

                        order = int::compare (key, nodes_in_s_left+1);

                        case order

                             LESS
                                 =>
                                 case s_left

                                      IMPLICIT_NODE { color => RED, left => s_left_left, val => s_left_val, tag => s_left_tag, right => s_left_right, ... }
                                          =>
                                          {   nodes_in_s_left_left
                                                  =
                                                  nodes_in  s_left_left; 

                                              order = int::compare (key, nodes_in_s_left_left+1);

                                              case order

                                                   LESS
                                                       =>
                                                       case (insert'' (key, val, s_left_left))

                                                            IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
                                                                =>
                                                                implicit_node
                                                                    ( 
                                                                      RED,
                                                                      implicit_node (BLACK, r_left,       r_val, r_tag, r_right),
                                                                      s_left_val,
                                                                      s_left_tag,
                                                                      implicit_node (BLACK, s_left_right, s_val, s_tag, s_right)
                                                                    );

                                                            s_left_left
                                                                =>
                                                                implicit_node
                                                                    ( 
                                                                      BLACK,
                                                                      implicit_node (RED, s_left_left, s_left_val, s_left_tag, s_left_right),
                                                                      s_val,
                                                                      s_tag,
                                                                      s_right
                                                                    );
                                                       esac;

                                                   (GREATER | EQUAL)
                                                       =>
                                                       {
                                                           if   order == EQUAL
                                                           then
                                                                # EQUAL case (inserting 'val' in this node)
                                                                # is the same as the GREATER case except
                                                                # that the roles of 'val' and 's_left_val'
                                                                # are interchanged, and 'key' incremented:

                                                                my (val, s_left_val) = (s_left_val, val);

                                                                key = key + 1;
                                                           fi;

                                                           case (insert'' (key - (nodes_in_s_left_left + 1), val, s_left_right))

                                                                IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
                                                                    =>
                                                                    implicit_node
                                                                        ( 
                                                                          RED,
                                                                          implicit_node (BLACK, s_left_left, s_left_val, s_left_tag, r_left),
                                                                          r_val,
                                                                          r_tag,
                                                                          implicit_node (BLACK, r_right,          s_val,      s_tag, s_right)
                                                                        );

                                                                s_left_right
                                                                    =>
                                                                    implicit_node
                                                                        ( 
                                                                          BLACK,
                                                                          implicit_node (RED, s_left_left, s_left_val, s_left_tag, s_left_right),
                                                                          s_val,
                                                                          s_tag,
                                                                          s_right
                                                                        );
                                                           esac;
                                                       };

                                              esac;
                                          };

                                      _   =>
                                          implicit_node (BLACK, insert'' (key, val, s_left), s_val, s_tag, s_right);
                                 esac;


                             (GREATER | EQUAL)
                                 =>
                                 {
                                     if   order == EQUAL
                                     then
                                          # EQUAL case (inserting 'val' in this node)
                                          # is the same as the GREATER case except
                                          # that the roles of 'val' and 's_val'
                                          # are interchanged, and 'key' incremented:

                                          my (val, s_val) = (s_val, val);

                                          key = key + 1;
                                     fi;

                                     # Insertion will take place in our right subtree,
                                     # so convert 'key' to that subtree's "coordinates"
                                     # by subtracting off the number of values in this
                                     # node (1) plus its left subtree:
                                     #
                                     key = key - (nodes_in_s_left + 1);

                                     case s_right

                                          IMPLICIT_NODE { color => RED, left => s_right_left, nodes => s_right_kids, val => s_right_val, tag => s_right_tag, right => s_right_right, ... }
                                              =>
                                              {   nodes_in_s_right_left
                                                      =
                                                      nodes_in  s_right_left; 

                                                  order = int::compare (key, nodes_in_s_right_left+1);

                                                  case order

                                                       LESS
                                                           =>
                                                           case (insert'' (key, val, s_right_left))

                                                                IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
                                                                    =>
                                                                    implicit_node
                                                                        ( 
                                                                          RED,
                                                                          implicit_node (BLACK, s_left, s_val, s_tag, r_left),
                                                                          r_val,
                                                                          r_tag,
                                                                          implicit_node (BLACK, r_right, s_right_val, s_right_tag, s_right_right)
                                                                        );

                                                                s_right_left
                                                                    =>
                                                                    implicit_node
                                                                        (
                                                                          BLACK,
                                                                          s_left,
                                                                          s_val,
                                                                          s_tag,
                                                                          implicit_node (RED, s_right_left, s_right_val, s_right_tag, s_right_right)
                                                                        );
                                                           esac;


                                                       (GREATER | EQUAL)
                                                           =>
                                                           {
                                                               if   order == EQUAL
                                                               then
                                                                    # EQUAL case (inserting 'val' in this node)
                                                                    # is the same as the GREATER case except
                                                                    # that the roles of 'val' and 's_right_val'
                                                                    # are interchanged, and 'key' incremented:

                                                                    my (val, s_right_val) = (s_right_val, val);

                                                                    key = key + 1;
                                                               fi;

                                                               # Transform key into "coordinate system" of our
                                                               # right subtree by subtracting off number of values
                                                               # in this node plus its left subtree:
                                                               #
                                                               key = key - (nodes_in_s_right_left + 1);

                                                               case (insert'' (key, val, s_right_right))

                                                                    IMPLICIT_NODE { color => RED, left => r_left, val => r_val, tag => r_tag, right => r_right, ... }
                                                                        =>
                                                                        implicit_node
                                                                            ( 
                                                                              RED,
                                                                              implicit_node (BLACK, s_left, s_val, s_tag, s_right_left),
                                                                              s_right_val,
                                                                              s_right_tag,
                                                                              implicit_node (BLACK, r_left, r_val, r_tag, r_right)
                                                                            );

                                                                    s_right_right
                                                                        =>
                                                                        implicit_node
                                                                            ( 
                                                                              BLACK,
                                                                              s_left,
                                                                              s_val,
                                                                              s_tag,
                                                                              implicit_node (RED, s_right_left, s_right_val, s_right_tag, s_right_right)
                                                                            );
                                                               esac;
                                                           };
                                                  esac;
                                              };

                                          _   =>
                                              implicit_node (BLACK, s_left, s_val, s_tag, insert'' (key, val, s_right));

                                      esac;
                                 };
                        esac;
                    };
            end;
        end;


    # A synonym for 'insert', so that we can write
    #     map $= (key, val);
    # instead of the clumsier
    #     map = insert( map, key, val );
    #
    fun m $ (key1, val1)
        =
        insert (m, key1, val1);

    #
    fun insert' ((key1, val1), m)
        =
        insert (m, key1, val1);



    # Return i such that tagged node has i predecessors in the sequence:
    #
    stipulate

        fun find_tag' (last_id, predecessors, IMPLICIT_NULL)
                =>
                predecessors;                                                                   # We've reached the top of the tree, so 'predecessors' is total number of predecessors in sequence.

            find_tag' (last_id, predecessors, IMPLICIT_NODE { id, up, left => IMPLICIT_NULL, ... })
                =>
                find_tag'  (id, predecessors, *up);                                             # Left subtree is empty, so we have no additional predecessors on this level.

            find_tag' (last_id, predecessors, IMPLICIT_NODE { id, up, left => IMPLICIT_NODE { nodes, id => left_id, ... }, ... })
                =>
                if   left_id == last_id
                then
                     find_tag' (id, predecessors,             *up);                                     # We came up from left  subtree, so don't count nodes in it as newly found predecessors. 
                else find_tag' (id, predecessors + nodes + 1, *up);   fi;                               # We came up from right subtree, so all nodes in left subtree are newfound predecessors -- plus this node.
        end;

    herein

        fun find_tag (REF IMPLICIT_NULL)
                =>
                raise exception IMPOSSIBLE;                                                             # Tag points to node holding some inserted value, so it cannot point to an IMPLICIT_NULL.

            find_tag (REF (IMPLICIT_NODE { id, up, left => IMPLICIT_NULL, ... }))
                =>   
                find_tag' (id, 0, *up);                                                         # Our left subtree is empty, so we have no predecessors at this level.

            find_tag (REF (IMPLICIT_NODE { id, up, left => IMPLICIT_NODE { nodes, ... }, ... }))
                =>   
                find_tag' (id, nodes, *up);                                                     # Our initial count of predecessors is the number of nodes in our left subtree.
        end;
    end;

    # Return (THE tag) corresponding to a key,
    # or NULL if the key is not present:
    #
    fun nth_tag (REF tree, key)
        =
        find' (tree, key)
        where
            fun find' (IMPLICIT_NULL, key)
                    =>
                    NULL;

                find' ((IMPLICIT_NODE { left, tag, right, ... }), key)
                    =>
                    {   left_kids =  nodes_in left;

                        if   key < 0   then  raise exception exceptions::SUBSCRIPT;   fi;

                        case (int::compare (key, left_kids))
                             LESS    =>  find' (left,  key);
                             EQUAL   =>  THE tag;
                             GREATER =>  find' (right, key - (left_kids+1));
                        esac;
                    };
            end;
        end;

    # Return (THE val) corresponding to a key,
    # or NULL if the key is not present:
    #
    fun find (REF tree, key)
        =
        find' (tree, key)
        where
            fun find' (IMPLICIT_NULL, key)
                    =>
                    NULL;

                find' ((IMPLICIT_NODE { left, val, right, ... }), key)
                    =>
                    {   left_kids =  nodes_in left;

                        if   key < 0   then  raise exception exceptions::SUBSCRIPT;   fi;

                        case (int::compare (key, left_kids))
                             LESS    =>  find' (left,  key);
                             EQUAL   =>  THE val;
                             GREATER =>  find' (right, key - (left_kids+1));
                        esac;
                    };
            end;
        end;

    fun sub (sequence, i)
        =
        case (find (sequence, i))
             THE val =>  val;
             NULL    =>  raise exception exceptions::SUBSCRIPT;
        esac;

    # Note:  The (_[])   enables   'vec[index]'           notation;

    my (_[]) = sub;


    # Remove n-th value.
    # Raise lib_base::NOT_FOUND if not found.
    #
    stipulate

        # As with most applicative ("side-effect free")
        # datastructures, we work by path copying:
        # given an input tree, we build and return
        # a mutated copy of some node path from root
        # to (typically) leaf.  The input tree is
        # untouched, and almost all of the result tree's
        # nodes are shared with the input tree.
        #
        # To remove the n-th value from a Sequence,
        # we must first descend into the tree
        # to find the node holding that value,
        # then retrace our steps, copying nodes
        # to produce the result tree, and also
        # rebalancing the tree as needed to
        # maintain our RED/BLACK invariants.
        #
        # We use a Descent_Path to record our
        # descent;  it is essentially an explicit
        # stack upon which we push the information
        # which we will need upon our return trip,
        # such as whether we descended down
        # the LEFT or RIGHT subtree of a given node:
        #
        Descent_Path(X)
            = TOP
            | WENT_LEFT   ((Color, X, Tag(X), Implicit_Tree(X), Descent_Path(X)) )      # Descent went left;  remember node's val, tag and right subtree.
            | WENT_RIGHT  ((Color, X, Tag(X), Implicit_Tree(X), Descent_Path(X)) );     # Descent went right; remember node's val, tag and left  subtree.
    herein
        # Remove the i-th value from a Sequence.
        # 
        # Three useful observations:
        # 
        # (1) We can always reduce the case of deleting
        #     a node with two children to the (easier)
        #     case of deleting a node with at most one
        #     child, just by bubbling values up into
        #     the two-kid node.  
        # 
        # (2) When deleting a RED node with only one child,
        #     we can simply replace it by its child;  this
        #     preserves all invariants.
        #
        # (3) When deleting a BLACK node with one RED child,
        #     we can simply replace it by its child, recolored
        #     BLACK:  This again preserves all invariants.
        #
        # Thus, the most interesting case is deleting
        # a BLACK node with one BLACK child, or no child:
        # This will result in a BLACK-node deficit in that
        # subtree, which we must find a way to repair
        # via rotations.
        # 
        fun remove (
                sequence as (REF input_tree),
                i
            )
            =
            {   # Sanity check:
                #
                if   i < 0   then  raise exception exceptions::SUBSCRIPT;   fi;

                new_tree
                    =
                    case (descend (i, input_tree, TOP))

                         # Enforce the invariant that
                         # the root node is always BLACK:
                         #
                         IMPLICIT_NODE { color => RED, left, val, right, tag, ... }
                             =>
                             implicit_node ( BLACK, left, val, tag, right );

                         ok  => ok;
                    esac;
            
                sequence := new_tree;
            }
            where 
#                fun color_name RED   => "RED";
#                    color_name BLACK => "BLACK";
#                end;
#
#                fun print_path TOP => print "    TOP of descent path\n";
#                    print_path (WENT_LEFT  (color, val, tree, rest)) => { printf "  WENT_LEFT  %5s " (color_name color); print_val val; print "\n"; debug_print_tree (print_val, tree, 8); print_path rest; };
#                    print_path (WENT_RIGHT (color, val, tree, rest)) => { printf "  WENT_RIGHT %5s " (color_name color); print_val val; print "\n"; debug_print_tree (print_val, tree, 8); print_path rest; };
#                end;



                # We produce our result tree by copying
                # our descent path nodes one by one,
                # starting at the leafward end and proceeding
                # to the root.
                #
                # We have two copying cases to consider:
                #
                # 1)  Initially, our deletion may have produced
                #     a violation of the RED/BLACK invariants
                #     -- specifically, a BLACK deficit -- forcing
                #     us to do on-the-fly rebalancing as we go.
                #
                # 2)  Once the BLACK deficit is resolved (or immediately,
                #     if none was created), copying cannot produce any
                #     additional invariant violations, so path copying
                #     becomes an utterly trivial matter of node duplication.
                #
                # We have two separate routines to handle these two cases:
                #
                #   copy_path   Handles the trivial case.
                #   copy_path'  Handles the rebalancing-needed case.
                #
                fun copy_path (TOP, t) => t;
                    copy_path (WENT_LEFT  (color, val, tag, right_subtree, rest_of_path),  left_subtree) =>  copy_path (rest_of_path, implicit_node (color, left_subtree, val, tag, right_subtree));
                    copy_path (WENT_RIGHT (color, val, tag, left_subtree,  rest_of_path), right_subtree) =>  copy_path (rest_of_path, implicit_node (color, left_subtree, val, tag, right_subtree));
                end;


                # copy_path' propagates a black deficit
                # up the descent path until either the top
                # is reached, or the deficit can be
                # covered.
                #
                # Arguments:
                #   o  descent_path, the worklist of nodes which need to be copied.
                #   o  result_tree,  our results-so-far accumulator.
                #
                #
                # Its return value is a pair containing:
                #   o  black_deficit:    A boolean flag which is TRUE iff there is still a deficit.
                #   o  The new tree.
                #
                fun copy_path' (TOP, result_tree)
                        =>
                        (TRUE, result_tree);

                    # Nomenclature: In the below diagrams, I use  '1B' == "BLACK node containing val1"
                    #                                             '2R' == "RED   node containing val2"
                    #                                              etc.
                    #               'X' can match RED or BLACK (but not both) within any given rule.
                    #               'a', 'b' represent the current node/subtree.
                    #               'c', 'd', 'e' represent arbitrary other node/subtrees (possibly EMPTY).
                    #
                    # For the cited Wikipedia case discussions and diagrams, see
                    #     http://en.wikipedia.org/wiki/Red_black_tree

                    #
                    #    1B              2B                Wikipedia Case 2
                    #   / \         ->  /  d
                    #  a   2R          1R
                    #     c  d        a  c
                    #         
                    #
                    copy_path' (WENT_LEFT (BLACK, val1, tag1, IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, path), a)                                   # Case 1L 
                        =>
                        copy_path' (WENT_LEFT (RED, val1, tag1, c, WENT_LEFT (BLACK, val2, tag2, d, path)), a);
                        # 
                        # We ('a') now have a RED parent and BLACK sibling, so case 4, 5 or 6 will apply.


                    #         1B            2B        Wikipidia Case 2  (Mirrored)
                    #        / \          /  \
                    #      2R   b  ->    c   1R        
                    #     c  d              d  b
                    #
                    copy_path' (WENT_RIGHT (BLACK, val1, tag1, IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, path), b)                                  # Case 1R 
                        =>
                        copy_path' (WENT_RIGHT (RED, val1, tag1, d, WENT_RIGHT (BLACK, val2, tag2, c, path)), b);
                        #
                        # We ('b') now have a RED parent and BLACK sibling, so mirrored case 4, 5 or 6 will apply.



                    #     1               1           Wikipedia Case 5
                    #    / \             / \
                    #   a  3B       ->  a  2B
                    #     2R e            c  3R
                    #    c d                d  e
                    #
                    copy_path' (WENT_LEFT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => IMPLICIT_NODE { color => RED, left => c, val => val2, tag => tag2, right => d, ... }, val => val3, tag => tag3, right => e, ... }, path), a)      # Case 3L 
                        =>
                        copy_path' (WENT_LEFT (color, val1, tag1, implicit_node (BLACK, c, val2, tag2, implicit_node (RED, d, val3, tag3, e)), path), a);



                    #         1               1           Wikipedia Case 5 (Mirrored)
                    #        / \             / \
                    #      2B   b    ->    3B   b
                    #     c  3R          2R  e
                    #       d  e        c  d
                    #
                    copy_path' (WENT_RIGHT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => IMPLICIT_NODE { color => RED, left => d, val => val3, tag => tag3, right => e, ... }, ... }, path), b)     # Case 4R 
                        =>
                        copy_path' (WENT_RIGHT (color, val1, tag1, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val3, tag3, e), path), b);


                    #     1X                  2X       Wikipedia Case 6
                    #    /  \                /  \
                    #   a    2B      ->    1B    3B
                    #       c  3R         a  c  d  e
                    #         d  e 
                    #
                    copy_path' (WENT_LEFT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => IMPLICIT_NODE { color => RED, left => d, val => val3, tag => tag3, right => e, ... }, ... }, path), a)      # Case 4L 
                        =>
                        (FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, a, val1, tag1, c), val2, tag2, implicit_node (BLACK, d, val3, tag3, e))));


                    #         1X              2X       Wikipedia Case 6 (Mirrored)
                    #        /  \            /  \
                    #      2B    b    ->   3B    1B
                    #    3R  e            c  d  e  b
                    #   c  d
                    #
                    copy_path' (WENT_RIGHT (color, val1, tag1, IMPLICIT_NODE { color => BLACK, left => IMPLICIT_NODE { color => RED, left => c, val => val3, tag => tag3, right => d, ... }, val => val2, tag => tag2, right => e, ... }, path), b)     # Case 3R 
                        =>
                        (FALSE, copy_path (path, implicit_node (color, implicit_node (BLACK, c, val3, tag3, d), val2, tag2, implicit_node (BLACK, e, val1, tag1, b))));



                    #      1B              1B         Wikipedia Case 3
                    #     /  \            /  \
                    #    a    2B    ->   a    2R
                    #        c  d            c  d
                    #
                    copy_path' (WENT_LEFT (BLACK, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), a)                                 # Case 2L 
                        =>
                        copy_path' (path, implicit_node (BLACK, a, val1, tag1, implicit_node (RED, c, val2, tag2, d)));
                        #
                        # Changing BLACK sib to RED locally rebalances in the
                        # sense that paths through us ('a') and our sib (2)
                        # both have the same number of BLACK nodes, but our
                        # subtree as a whole has a BLACK pathcount one lower
                        # than initially, so we continue the rebalancing
                        # act in our parent.


                    #         1B             1B         Wikipedia Case 3 (Mirrored)
                    #        /  \           /  \
                    #      2B    b    ->   2R   b
                    #     c  d            c  d
                    #
                    copy_path' (WENT_RIGHT (BLACK, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), b)                                        # Case 2R 
                        =>
                        copy_path' (path, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val1, tag1, b));
                        #
                        # Changing BLACK sib to RED locally rebalances in the
                        # sense that paths through us ('b') and our sib (2)
                        # both have the same number of BLACK nodes, but our
                        # subtree as a whole has a BLACK pathcount one lower
                        # than initially, so we continue the rebalancing
                        # act in our parent.


                    #      1R              1B         Wikipedia Case 4 
                    #     /  \            /  \
                    #    a    2B    ->   a    2R
                    #        c  d            c  d
                    #
                    copy_path' (WENT_LEFT (RED, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), a)                                   # Case 2L 
                        =>
                        (FALSE, copy_path (path, implicit_node (BLACK, a, val1, tag1, implicit_node (RED, c, val2, tag2, d))));
                        #
                        # BLACK sib has exchanged color with RED parent;
                        # this makes up the BLACK deficit on our side
                        # without affecting black path counts on sib's side,
                        # so we're done rebalancing and can revert to
                        # simple path copying for the rest of the way back
                        # to the root.


                    #         1R             1B         Wikipedia Case 4 (Mirrored)
                    #        /  \           /  \
                    #      2B    b    ->   2R   b
                    #     c  d            c  d
                    #
                    copy_path' (WENT_RIGHT (RED, val1, tag1, IMPLICIT_NODE { color => BLACK, left => c, val => val2, tag => tag2, right => d, ... }, path), b)                                  # Case 2R 
                        =>
                        (FALSE, copy_path (path, implicit_node (BLACK, implicit_node (RED, c, val2, tag2, d), val1, tag1, b)));
                        #
                        # BLACK sib has exchanged color with RED parent;
                        # this makes up the BLACK deficit on our side
                        # without affecting black path counts on sib's side,
                        # so we're done rebalancing and can revert to
                        # simple path copying for the rest of the way back
                        # to the root.
                    

                    copy_path' (path, t)
                        =>
                        (FALSE, copy_path (path, t));

                end;


                # Here's our routine for the descent phase.
                #
                # Arguments:
                #     node_to_delete:    Integer identifying which node to delete, relative to local subtree numbering of 0..N
                #     current_subtree:   Subtree to search, using "in-order":  Left subtree first, then this node, then right subtree.
                #     descent_path:      Stack of values recording our descent path to date.
                #
                fun descend (node_to_delete, IMPLICIT_NULL, descent_path)
                        =>
                        raise exception lib_base::NOT_FOUND;

                    descend (node_to_delete, IMPLICIT_NODE { color, left, nodes, val, tag, right, ... },  descent_path)
                        =>
                        {   left_kids
                                =
                                nodes_in  left;

                            case (int::compare (node_to_delete, left_kids))

                                 LESS    =>  descend (node_to_delete,                    left,  WENT_LEFT  (color, val, tag, right, descent_path));
                                 GREATER =>  descend (node_to_delete - (left_kids + 1),  right, WENT_RIGHT (color, val, tag,  left, descent_path));

                                 EQUAL   =>  join (color, left, right, descent_path);
                            esac;
                        };
                end


                # Once we've found and removed the requested node,
                # we are left with the problem of combining its
                # former left and right subtrees into a replacement
                # for the node -- while preserving or restoring
                # our RED/BLACK invariants.  That's our job here.
                #
                # Arguments:
                #    color:         Color of now-deleted node.
                #    left_subtree:  Left subtree of now-deleted node.
                #    right_subtree: Right subtree of now-deleted node.
                #    descent_path:  Path by which we reached now-deleted node.
                #                   (To us at this point the descent_path reperesents
                #                   the worklist of nodes to duplicate in order to
                #                   produce the result tree.)
                #
                also
                fun join (RED,   IMPLICIT_NULL,  IMPLICIT_NULL, descent_path) =>     copy_path  (descent_path, IMPLICIT_NULL);
                    join (RED,   left_subtree,   IMPLICIT_NULL, descent_path) =>     copy_path  (descent_path,  left_subtree );
                    join (RED,   IMPLICIT_NULL, right_subtree,  descent_path) =>     copy_path  (descent_path, right_subtree );
                    join (BLACK, left_subtree,   IMPLICIT_NULL, descent_path) => #2 (copy_path' (descent_path,  left_subtree));
                    join (BLACK, IMPLICIT_NULL, right_subtree,  descent_path) => #2 (copy_path' (descent_path, right_subtree));

                    join (color, left_subtree,   right_subtree,  descent_path)
                        =>
                        {   # We have two non-empty children.  
                            #
                            # We bubble up a value to fill this node,
                            # creating a delete-node problem below which is
                            # guaranteed to have at most one nonempty child:
                            #

                            # Replace deleted value with
                            # value from first node in our
                            # right subtree:
                            #
                            my (replacement_value, replacement_tag)
                                =
                                min_val right_subtree;

                            # Now, act as though the delete never happened:
                            # just continue our descent, with node 0 in
                            # right subtree as our new delete target:
                            #
                            descend( 0, right_subtree, WENT_RIGHT (color, replacement_value, replacement_tag, left_subtree, descent_path) );
                        }
                        where
                            #
                            fun min_val (IMPLICIT_NODE { left => IMPLICIT_NULL, val, tag, ... }) =>  (val, tag);
                                min_val (IMPLICIT_NODE { left, ...                            }) =>  min_val left;

                                min_val  IMPLICIT_NULL                                =>  raise exception IMPOSSIBLE;
                            end;
                        end;
                end;
            end;
    end;                #  stipulate

#    # Return the first value in the sequence (or NULL if it is empty):
#    # 
#    fun first_val_else_null (IMPLICIT_SEQUENCE tree)
#        =
#       leftmost_descendent  tree
#        where
#            fun leftmost_descendent IMPLICIT_NULL => NULL;
#               leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_NULL, _, val, _)) =>  THE val;
#               leftmost_descendent (IMPLICIT_NODE(_, left_subtree,     _, _, _)) =>  leftmost_descendent  left_subtree;
#            end;
#       end;
#
#    #
#    fun first_keyval_else_null (IMPLICIT_SEQUENCE tree)
#        =
#       leftmost_descendent  tree
#        where
#            fun leftmost_descendent  IMPLICIT_NULL => NULL;
#               leftmost_descendent (IMPLICIT_NODE(_, IMPLICIT_NULL, _, val, _)) =>  THE (0, val);
#               leftmost_descendent (IMPLICIT_NODE(_, left_subtree,   _,   _, _)) =>  leftmost_descendent  left_subtree;
#            end;
#       end;
#
#    # Return the last value in the sequence (or NULL if it is empty):
#    # 
#    stipulate
#
#       fun rightmost_descendent IMPLICIT_NULL => NULL;
#           rightmost_descendent (IMPLICIT_NODE(_,_,_, val, IMPLICIT_NULL)) =>  THE val;
#           rightmost_descendent (IMPLICIT_NODE(_,_,_,   _, right_subtree )) =>  rightmost_descendent  right_subtree;
#       end;
#    herein
#       fun last_val_else_null (IMPLICIT_SEQUENCE tree)
#           =
#           rightmost_descendent  tree;
#
#       # 
#       fun last_keyval_else_null (IMPLICIT_SEQUENCE IMPLICIT_NULL)
#               =>
#               NULL; 
#
#           last_keyval_else_null (IMPLICIT_SEQUENCE (tree as IMPLICIT_NODE (_,_,val_count,_,_)))
#               =>
#               THE (val_count - 1, the (rightmost_descendent tree));
#       end;
#    end;
#
    # Return the number of items in the sequence:
    #
    fun vals_count (REF (IMPLICIT_NULL               )) =>  0;
        vals_count (REF (IMPLICIT_NODE { nodes, ... })) =>  nodes;
    end;

#     # Remove and return first value in sequence:
#     #
#     fun shift sequence
#         =
#         (THE (remove (sequence, 0)))
#         except
#             lib_base::NOT_FOUND = NULL;
#
#
#     # Prepend a value to sequence:
#     #
#     fun unshift (sequence, val)
#         =
#         insert (sequence, 0, val);
#
#     # Remove and return last value in sequence:
#     #
#     fun pop sequence
#         =
#         case (vals_count sequence)
#              0 =>  NULL;
#              n =>  THE (remove (sequence, n - 1));
#         esac;
#
#     # Append a value to sequence:
#     #
#     fun push (sequence, val)
#         =
#         insert (sequence, vals_count sequence, val);
#
#
#    # Call
#    #      f (val, result_so_far)
#    # once for every value in the sequence, in order,
#    # returning the final result:
#    #
#    fun fold_forward f
#        =
#        {   fun foldf (IMPLICIT_NULL, result)
#                    =>
#                    result;
#
#               foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result)
#                    =>
#                   foldf (right_subtree, f (val, foldf (left_subtree, result)));
#            end;
#       
#           fn initial_value
#                =
#                fn (IMPLICIT_SEQUENCE tree)
#                    =
#                    foldf (tree, initial_value);
#       };
#
#    # Call
#    #      f (key, val, result_so_far)
#    # once for every key, val pair in the sequence,
#    # in order, returning the final result:
#    #
#    #
#    fun keyed_fold_forward f
#        =
#        {   fun foldf (IMPLICIT_NULL, result, key)
#                    =>
#                    (result, key);
#
#               foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result, key)
#                    =>
#                    {    my (result, key)
#                             =
#                             foldf (left_subtree, result, key);
#
#                         result
#                            =
#                             f (key, val, result);
#
#                        foldf (right_subtree, result, key+1);
#                    };
#            end;
#       
#           fn initial_value
#                =
#                fn (IMPLICIT_SEQUENCE tree)
#                    =
#                    {   my (result, _) = foldf (tree, initial_value, 0);
#                        result;
#                    };
#       };
#
#    #
#    fun fold_backward f
#        =
#        {   fun foldf (IMPLICIT_NULL, accum)
#                    =>
#                    accum;
#
#               foldf (IMPLICIT_NODE(_, left, _, val, right), accum)
#                    =>
#                   foldf (left, f (val, foldf (right, accum)));
#            end;
#       
#           fn init
#                =
#                fn (IMPLICIT_SEQUENCE (m))
#                    =
#                    foldf (m, init);
#       };
#
#    #
#    fun keyed_fold_backward f
#        =
#        {   fun foldf (IMPLICIT_NULL, result, key)
#                    =>
#                    (result, key);
#
#               foldf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree), result, key)
#                    =>
#                    {    my (result, key)
#                             =
#                             foldf (right_subtree, result, key);
#
#                         result
#                            =
#                             f (key, val, result);
#
#                        foldf (left_subtree, result, key - 1);
#                    };
#            end;
#       
#           fn initial_value
#                =
#                fn (IMPLICIT_SEQUENCE IMPLICIT_NULL)
#                        =>
#                        initial_value;
#
#                   (seq as (IMPLICIT_SEQUENCE (tree as IMPLICIT_NODE (_,_, val_count,_,_))))
#                        =>
#                       {   my (result, _) = foldf (tree, initial_value, val_count - 1);
#                           result;
#                       };
#            end;
#       };
#
#    #
#    fun vals_list  sequence
#        =
#        fold_backward (op . ) [] sequence;
#
#    #
#    fun keyvals_list sequence
#        =
#        keyed_fold_backward (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_NULL, _)
#    #                 =>
#    #                 done;
#    #
#    #             loop (IMPLICIT_NODE n, state)
#    #                 =>
#    #                 {   do_stuff_with n;
#    #                     loop (next state);
#    #                 };
#    #         end;
#    #     end;
#    #
#    fun next ((tree as IMPLICIT_NODE(_, _, _, _, right_subtree)) . rest) =>  (tree, left (right_subtree, rest));
#        next _                                                           =>  (IMPLICIT_NULL, []);
#    end 
#
#    also
#    fun left (IMPLICIT_NULL, rest)
#            =>
#            rest;
#
#        left (tree as IMPLICIT_NODE(_, left_subtree, _, _, _), rest)
#            =>
#            left (left_subtree, tree . rest);
#    end;
#
#    #
#    fun start sequence
#        =
#        left (sequence, []);
#
#
#
#    # Given an ordering on sequence values,
#    # return an ordering on sequences:
#    #
#    fun compare_sequences compare_vals
#        =
#        {   fun compare (tree1, tree2)
#                =
#                case (next tree1, next tree2)
#
#                    ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) =>  EQUAL;
#                    ((IMPLICIT_NULL, _), _                  ) =>  LESS;
#                    (_,                   (IMPLICIT_NULL, _)) =>  GREATER;
#
#                    ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
#                       (IMPLICIT_NODE(_, _, _, val2, _), r2)
#                     )
#                         =>
#                        case (compare_vals (val1, val2))
#                             EQUAL =>  compare (r1, r2);
#                             order =>  order;
#                        esac;
#                  esac;
#
#       
#           fn  ( IMPLICIT_SEQUENCE tree1,
#                  IMPLICIT_SEQUENCE tree2
#                )
#                =
#                compare (start tree1, start tree2);
#       };
#
#
#
#    # Support for constructing red-black trees
#    # in linear time from increasing ordered
#    # sequences.
#    #
#    # Based on a description by Ralf Hinze
#    #   http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
#    # which represents tree structures
#    # via binary numbers using only the digits
#    # 1 and 2.  (0 is used only for the empty tree.)
#    #
#    # Note that the elements in the digits
#    # are ordered with the largest on the left,
#    # whereas the elements of the trees
#    # are ordered with the largest on the right.
#    #
#    Digit X
#      = ZERO
#      | ONE  ((Int, X, Explicit_Tree(X), Digit(X)) )
#      | TWO  ((Int, X, Explicit_Tree(X), Int, X, Explicit_Tree(X), Digit(X)) );
#
#    # Add a keyval whose key is guaranteed
#    # to be larger than any in 'digits':
#    #
#    fun add_item (key, val, digits)
#        =
#       incr (key, val, EXPLICIT_EMPTY, digits)
#        where
#            fun incr (key, val, tree, ZERO)                    # Incrementing ZERO produces ONE.
#                   =>
#                   ONE (key, val, tree, ZERO);
#
#               incr (       key1, val1, tree1,                 # Incrementing a ONE digit produces a TWO digit.
#                       ONE ( key2, val2, tree2,
#                             rest
#                           )
#                     )
#                   =>
#                   TWO ( key1, val1, tree1,
#                          key2, val2, tree2,
#                          rest
#                        );
#
#               incr (       key1, val1, tree1,                 # Incrementing a TWO digit produces a ONE digit -- plus a carry.
#                       TWO ( key2, val2, tree2,
#                             key3, val3, tree3,
#                             rest
#                           )
#                     )
#                   =>
#                   ONE (       key1, val1, tree1,
#                         incr ( key2, val2, EXPLICIT_NODE (BLACK, tree3, key3, val3, tree2),
#                                rest
#                              )
#                        );
#            end;
#       end;
#
#    # Link the digits into a tree:
#    #
#    fun digits_to_explicit_tree  digits
#        =
#       link (digits, EXPLICIT_EMPTY)
#        where
#            # We consume digits from our first argument and
#            # accumulate our eventual result in our second argument:
#            #
#            fun link (ZERO, result_tree)
#                   =>
#                   result_tree;
#
#               link ( ONE (key, val, tree, rest),
#                       result_tree
#                     )
#                   =>
#                   link ( rest,
#                           EXPLICIT_NODE (BLACK, tree, key, val, result_tree)
#                         );
#
#               link (  TWO ( key1, val1, tree1,
#                              key2, val2, tree2,
#                              rest
#                            ),
#
#                        result_tree
#                     )
#                   =>
#                   link ( rest,
#
#                           EXPLICIT_NODE
#                               ( BLACK,
#                                 EXPLICIT_NODE (RED, tree2, key2, val2, tree1),
#                                 key1, val1,
#                                 result_tree
#                               )
#                         );
#            end;
#       end;
#
#
#    fun digits_to_implicit_tree  digits
#        =
#        explicit_tree_to_implicit_tree
#            (digits_to_explicit_tree  digits);
#
#
#    fun digits_to_sequence  digits
#        =
#       IMPLICIT_SEQUENCE  (digits_to_implicit_tree  digits);
#
#
#    fun explicit_from_list  list
#        =
#       loop (ZERO, 0, list)
#        where
#            fun loop (result, index, [])
#                    =>
#                    EXPLICIT_SEQUENCE (index, digits_to_explicit_tree result);
#
#                loop (result, index, this . rest)
#                    =>
#                    loop (add_item (index, this, result), index + 1, rest );
#           end;                
#        end; 
#
#    fun implicit_from_list  list
#        =
#        explicit_sequence_to_implicit_sequence (explicit_from_list list);
#
#
#    from_list = implicit_from_list;
#
#
#    stipulate
#
#       #
#       fun wrap
#                f
#                ( IMPLICIT_SEQUENCE m1,
#                  IMPLICIT_SEQUENCE m2
#                )
#            =
#            {   my (n, digits)
#                    =
#                    f (start m1, start m2, 0, ZERO);
#           
#               digits_to_sequence  digits;
#           };
#
#       #
#       fun insert'' ((IMPLICIT_NULL, _), n, digits)
#               =>
#               (n, digits);
#
#           insert'' ((IMPLICIT_NODE(_, _, _, val, _), r), n, digits)
#               =>
#               insert'' (next r, n+1, add_item (n, val, digits));
#        end;
#    of
#
#       # Return a map whose domain is the union
#        # of the domains of the two input maps,
#        # using 'merge_fn' to select the vals
#        # for keys that are in both domains.
#       #
#       fun union_with  merge_fn
#            =
#           wrap union
#            where
#                fun union (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#
#                        ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) =>                  (n, result);
#                        ((IMPLICIT_NULL, _), tree2              ) =>  insert'' (tree2, n, result);
#                        (tree1,               (IMPLICIT_NULL, _)) =>  insert'' (tree1, n, result);
#
#                        (   (IMPLICIT_NODE(_, _, _, val1, _), rest1),
#                            (IMPLICIT_NODE(_, _, _, val2, _), rest2)
#                        )
#                             =>
#                            union (rest1, rest2, n+1, add_item (n, merge_fn (val1, val2), result));
#                    esac;
#           end;
#
#       #
#       fun keyed_union_with  merge_fn
#            =
#            {   fun union (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#                   
#                        ((IMPLICIT_NULL, _), (IMPLICIT_NULL, _)) =>                  (n, result);
#                        ((IMPLICIT_NULL, _), tree2              ) =>  insert'' (tree2, n, result);
#                        (tree1,               (IMPLICIT_NULL, _)) =>  insert'' (tree1, n, result);
#
#                        ( (IMPLICIT_NODE(_, _, _, val1, _), rest1),
#                           (IMPLICIT_NODE(_, _, _, val2, _), rest2)
#                         )
#                             =>
#                            union (rest1, rest2, n+1, add_item (n, merge_fn (n, val1, val2), result));
#                    esac;
#           
#               wrap union;
#           };
#
#       # Return a map whose domain is
#        # the intersection of the domains
#        # of the two input maps, using the
#        # supplied function to define the range.
#       #
#       fun intersect_with  merge_fn
#            =
#            {   fun intersect (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#                   
#                        ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
#                           (IMPLICIT_NODE(_, _, _, val2, _), r2)
#                         )
#                             =>
#                            intersect (r1, r2, n+1, add_item (n, merge_fn (val1, val2), result));
#
#                        _ => (n, result);
#                    esac;
#
#           
#               wrap intersect;
#           };
#       #
#       fun keyed_intersect_with  merge_fn
#            =
#            {   fun intersect (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#                   
#                         (   (IMPLICIT_NODE(_, _, _, val1, _), r1),
#                             (IMPLICIT_NODE(_, _, _, val2, _), r2)
#                         )
#                             =>
#                            intersect (r1, r2, n+1, add_item (n, merge_fn (n, val1, val2), result));
#
#                           _ => (n, result);
#                    esac;
#           
#               wrap intersect;
#           };
#
#       #
#       fun merge_with  merge_fn
#            =
#           wrap merge
#            where
#                fun merge (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#                   
#                        ( (IMPLICIT_NULL, _),
#                           (IMPLICIT_NULL, _)
#                         )
#                             =>
#                             (n, result);
#
#                        ((IMPLICIT_NULL, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
#                             =>
#                            mergef (n, NULL, THE val2, tree1, r2, n, result);
#
#                        ((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_NULL, _))
#                             =>
#                            mergef (n, THE val1, NULL, r1, tree2, n, result);
#
#                        (   (IMPLICIT_NODE(_, _, _, val1, _), r1),
#                             (IMPLICIT_NODE(_, _, _, val2, _), r2)
#                         )
#                             =>
#                            mergef (n, THE val1, THE val2, r1,    r2, n, result);
#                    esac
#
#               also
#               fun mergef (k, x1, x2, r1, r2, n, result)
#                    =
#                    case (merge_fn (x1, x2))
#                        THE val2 =>   merge (r1, r2, n+1, add_item (n, val2, result));
#                        NULL     =>   merge (r1, r2, n,                      result );
#                    esac;
#           end;
#
#       #
#       fun keyed_merge_with  merge_fn
#            =
#           wrap merge
#            where
#                fun merge (tree1, tree2, n, result)
#                    =
#                    case ( next tree1,
#                           next tree2
#                         )
#                   
#                        ( (IMPLICIT_NULL, _),
#                           (IMPLICIT_NULL, _)
#                         )
#                             =>
#                             (n, result);
#
#                        ((IMPLICIT_NULL, _), (IMPLICIT_NODE(_, _, _, val2, _), r2))
#                             =>
#                            mergef (n, NULL, THE val2, tree1, r2, n, result);
#
#                        ((IMPLICIT_NODE(_, _, _, val1, _), r1), (IMPLICIT_NULL, _))
#                             =>
#                            mergef (n, THE val1, NULL, r1, tree2, n, result);
#
#                        ( (IMPLICIT_NODE(_, _, _, val1, _), r1),
#                           (IMPLICIT_NODE(_, _, _, val2, _), r2)
#                         )
#                             =>
#                            mergef (n, THE val1, THE val2, r1, r2, n, result);
#                    esac
#
#               also
#               fun mergef (k, x1, x2, r1, r2, n, result)
#                    =
#                    case (merge_fn (k, x1, x2))
#                        THE val2   =>   merge (r1, r2, n+1, add_item (n, val2, result));
#                        NULL       =>   merge (r1, r2, n,                      result);
#                    esac;
#           end;
#    end;                            #  stipulate
#
#    #
#    fun apply f
#        =
#        {   fun appf IMPLICIT_NULL
#                    =>
#                    ();
#
#               appf (IMPLICIT_NODE(_, left_subtree, _, val, right_subtree))
#                    =>
#                    {   appf  left_subtree;
#                        f val;
#                        appf right_subtree;
#                    };
#            end;
#       
#           fn (IMPLICIT_SEQUENCE m)
#                =
#                appf m;
#       };
#
#    #
#    fun keyed_apply  f
#        =
#        {   fun appf (n, IMPLICIT_NULL)
#                    =>
#                    n;
#
#               appf (n, IMPLICIT_NODE(_, left, key, val, right))
#                    =>
#                    {   n = appf (n, left);
#                        f (n, val);
#                        appf (n+1, right);
#                    };
#            end;
#       
#           fn (IMPLICIT_SEQUENCE (m))
#                =
#                {   appf (0, m);
#                    ();
#                };
#       };
#
#    #
#    fun map f
#        =
#        {   fun mapf IMPLICIT_NULL
#                    =>
#                    IMPLICIT_NULL;
#
#               mapf (IMPLICIT_NODE (color, left, val_count, val, right))
#                    =>
#                   IMPLICIT_NODE (color, mapf left, val_count, f val, mapf right);
#            end;
#       
#           fn (IMPLICIT_SEQUENCE m)
#                =
#                IMPLICIT_SEQUENCE (mapf m);
#       };
#
#    #
#    fun keyed_map  f
#        =
#        {   fun mapf (n, IMPLICIT_NULL)
#                     =>
#                     (n, IMPLICIT_NULL);
#
#               mapf (n, IMPLICIT_NODE (color, left_subtree, val_count, val, right_subtree))
#                    =>
#                    {   my (n, left_subtree' ) = mapf (n,    left_subtree);
#
#                        val' = f (n, val);
#
#                        my (n, right_subtree') = mapf (n+1, right_subtree);
#
#                        (n, IMPLICIT_NODE (color, left_subtree', val_count, val', right_subtree'));
#                    };
#            end;
#       
#           fn (IMPLICIT_SEQUENCE tree)
#                =
#                IMPLICIT_SEQUENCE (#2 (mapf (0, tree)));
#       };
#
#
#
#    # Construct a new sequence containing
#    # only those values satisfying 'predicate':
#    #
#    # The filtering is done in sequence order:
#    #
#    fun filter predicate (IMPLICIT_SEQUENCE t)
#        =
#       digits_to_sequence  digits
#        where
#            fun walk (IMPLICIT_NULL, n, digits)
#                   =>
#                   digits;
#
#               walk (IMPLICIT_NODE(_, left, _, val, right), n, digits)
#                   =>
#                   {   digits
#                            =
#                            walk (left, n, digits);
#
#                       if   predicate val
#                       then walk (right, n+1, add_item (n, val, digits));
#                       else walk (right, n, digits);   fi;
#                   };
#            end;
#
#           digits
#                =
#                walk (t, 0, ZERO);
#       end;
#
#    #
#    fun keyed_filter predicate (IMPLICIT_SEQUENCE t)
#        =
#       digits_to_sequence  digits
#        where
#            fun walk (IMPLICIT_NULL, n, result)
#                   =>
#                   result;
#
#               walk (IMPLICIT_NODE(_, a, _, val, b), n, result)
#                   =>
#                   {   my result
#                            =
#                            walk (a, n, result);
#
#                       if   predicate (n, val)
#                       then walk (b, n+1, add_item (n, val, result));
#                       else walk (b, n, result);  fi;
#                   };
#            end;
#
#           digits
#                =
#                walk (t, 0, ZERO);
#       end;
#
#    # Map a partial function 
#    # over the elements of a map
#    # in increasing map order:
#    #
#    fun map'  f
#        =
#       fold_forward f' empty
#        where
#            fun f' (val, result)
#                =
#               case (f val)
#                    THE val' =>  push (result, val');
#                    NULL     =>  result;
#               esac;
#       end;
#
#    #
#    fun keyed_map'  f
#        =
#       keyed_fold_forward f' empty
#        where
#            fun f' (key, val, result)
#                =
#               case (f (key, val))
#                    NULL  =>  result;
#                    THE val' =>  push (result, val');
#               esac;
#       end;

};











Comments and suggestions to: bugs@mythryl.org

PreviousUpNext