PreviousUpNext

15.4.963  src/lib/src/red-black-numbered-set-g.pkg

## red-black-numbered-set-g.pkg

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

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

# This package implements the converse idea to
#
#     src/lib/src/red-black-numbered-list.pkg

# Here we store an arbitrary set of ordered values into
# a red-black tree, and then use per-node subtree-size
# fields to answer in O(log(N)) time the question
# "How many keys come before this key in sequence order?"

# This code is based on Chris Okasaki's implementation of
# red-black trees.  The linear-time tree construction code is
# based on the paper "Constructing red-black trees" by Ralf Hinze,
#   http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
# and the delete function is based on the description in Cormen,
# Leiserson, and Rivest.
#
# A red-black tree should satisfy the following two invariants:
#
#   Red Invariant:    Each red node has a black parent.
#
#   Black Condition:  Each path from the root to an empty node
#                     has the same number of black nodes
#                     (the tree's black height).
#
# The Red condition implies that the root is always black and the Black
# condition implies that any node with only one child will be black and
# its child will be a red leaf.





generic package red_black_numbered_set_g (k:  Key)              # Key           is from   src/lib/src/key.api
:
Numbered_Set                                                    # Numbered_Set  is from   src/lib/src/numbered-set.api
    where key == k
{
    package key = k;

    Color
        =
        RED | BLACK;

    # Internal tree node:
    #
    Tree
        = EMPTY
        | TREE_NODE  ( ( Color,
                         Tree,                  # Left subtree.
                         key::Key,              # Key.
                         Int,                   # keycount -- number of keys/nodes in this subtree.
                         Tree                   # Right subtree.
                     ) );

    # Header node.  Every complete
    # map is represented by one:
    #
    Numbered_Set
        =
        NUMBERED_SET (
            ( Tree                              # Tree containing one node per key pair in numbering.
            )
        );

    #
    fun is_empty (NUMBERED_SET EMPTY) =>  TRUE;
        is_empty _                 =>  FALSE;
    end;


    empty =  NUMBERED_SET EMPTY;

    #
    fun singleton key
        =
        NUMBERED_SET (TREE_NODE (RED, EMPTY, key, 1, EMPTY));


    # Check invariants:
    #
    fun all_invariants_hold (NUMBERED_SET EMPTY)
            =>
            TRUE;

        all_invariants_hold (NUMBERED_SET (TREE_NODE (RED,_,_,_,_) ) )
            =>
            FALSE;      # RED root is not ok.

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

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

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

                                check_blackdepth_on_all_paths (n, TREE_NODE (BLACK, left_subtree,_,_, right_subtree))
                                    =>
                                    check_blackdepth_on_all_paths (n+1,  left_subtree)
                                    and
                                    check_blackdepth_on_all_paths (n+1, right_subtree);


                                check_blackdepth_on_all_paths (n, TREE_NODE (RED,   left_subtree,_,_, right_subtree))
                                    =>
                                    check_blackdepth_on_all_paths (n,  left_subtree)
                                    and
                                    check_blackdepth_on_all_paths (n, right_subtree);
                            end;
                        end;
                    }
                    where
                        fun leftmost_blackdepth (n, EMPTY)                             =>  n;
                            leftmost_blackdepth (n, TREE_NODE (RED,   left_subtree, _,_,_)) =>  leftmost_blackdepth (n,   left_subtree);
                            leftmost_blackdepth (n, TREE_NODE (BLACK, left_subtree, _,_,_)) =>  leftmost_blackdepth (n+1, left_subtree);
                        end;
                    end;

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

                    red_invariant_ok  (parent_was_black, TREE_NODE (RED,   left_subtree, _,_, right_subtree))
                        =>
                        parent_was_black
                        and
                        red_invariant_ok  (FALSE,  left_subtree)
                        and
                        red_invariant_ok  (FALSE, right_subtree);

                    red_invariant_ok  (parent_was_black, TREE_NODE (BLACK, left_subtree, _,_, right_subtree))
                        =>
                        red_invariant_ok  (TRUE,  left_subtree)
                        and
                        red_invariant_ok  (TRUE, right_subtree);

                end;

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

                            child_count   (TREE_NODE (_, left_subtree, _, key_count, right_subtree))
                                =>
                                {    left_count  =  child_count   left_subtree;
                                     right_count =  child_count  right_subtree;

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

                                     if   (key_count != total   )   raise exception DOMAIN;   fi;

                                     total;
                                };
                        end;
                    end;
            end;                        # where
    end;                                # fun all_invariants_hold

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

                     TREE_NODE (color, left, key, key_count, right)
                         =>
                         {   count = debug_print_tree' (left, indent+5, count);

                             print (do_indent (indent0, []));

                             printf "%4d: %4d"  count   key_count;
                             print "   ";
                             print_key key;
                             print " key";
                             print  "    "; 

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

                             print "\n";

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

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

    fun keys_in  EMPTY                         =>  0;
        keys_in (TREE_NODE  (_,_, _, keys, _)) =>  keys;
    end;

    fun tree_node (color, left, key, right)
        =
        {   keys =  keys_in  left
                 +  keys_in  right
                 +  1;

            TREE_NODE (color, left, key, keys, right);
        };

    #
    fun set (NUMBERED_SET m, key1)
        =
        {   m = case (set'' m)
                  
                     TREE_NODE (RED, left_subtree, key, keys, right_subtree)
                         =>
                         # Enforce invariant that root is always BLACK.
                         #      (It is always safe to change the root from
                         # RED to BLACK.)
                         #      
                         #      Since the well-tested SML/NJ code returns
                         # trees with RED roots, this may not be necessary.
                         #      
                         TREE_NODE (BLACK, left_subtree, key, keys, right_subtree);

                     other => other;
                esac;
        
            NUMBERED_SET m;
        }
        where 
            #
            fun set'' EMPTY
                    =>
                    TREE_NODE (RED, EMPTY, key1, 1, EMPTY);


                set'' (s as TREE_NODE (s_color, a, key2, _, b))
                    =>
                    case (key::compare (key1, key2))
                      
                         LESS
                             =>
                             case a
                               
                                  TREE_NODE (RED, c, key3, _, d)
                                      =>
                                      case (key::compare (key1, key3))
                                                
                                           LESS
                                               =>
                                               case (set'' c)
                                                 
                                                    TREE_NODE (RED, e, wk, _, f)
                                                        =>
                                                        tree_node (RED, tree_node (BLACK, e, wk, f), key3, tree_node (BLACK, d, key2, b));

                                                    c
                                                        =>
                                                        tree_node (BLACK, tree_node (RED, c, key3, d), key2, b);
                                               esac;

                                           EQUAL
                                               =>
                                               tree_node (s_color, tree_node (RED, c, key1, d), key2, b);

                                           GREATER
                                               =>
                                               case (set'' d)
                                                 
                                                    TREE_NODE (RED, e, wk, _, f)
                                                        =>
                                                        tree_node (RED, tree_node (BLACK, c, key3, e), wk, tree_node (BLACK, f, key2, b));

                                                    d
                                                        =>
                                                        tree_node (BLACK, tree_node (RED, c, key3, d), key2, b);
                                               esac;

                                      esac;

                                  _ => tree_node (BLACK, set'' a, key2, b);
                             esac;

                         EQUAL
                             =>
                             tree_node (s_color, a, key1, b);

                         GREATER
                             =>
                             case b
                               
                                  TREE_NODE (RED, c, key3, _, d)
                                      =>
                                      case (key::compare (key1, key3))
                                        
                                           LESS
                                               =>
                                               case (set'' c)
                                                 
                                                    TREE_NODE (RED, e, wk, _, f)
                                                        =>
                                                        tree_node (RED, tree_node (BLACK, a, key2, e), wk, tree_node (BLACK, f, key3, d));

                                                    c
                                                        =>
                                                        tree_node (BLACK, a, key2, tree_node (RED, c, key3, d) );
                                               esac;


                                           EQUAL
                                               =>
                                               tree_node (s_color, a, key2, tree_node (RED, c, key1, d));

                                           GREATER
                                               =>
                                               case (set'' d)
                                                 
                                                    TREE_NODE (RED, e, wk, _, f)
                                                        =>
                                                        tree_node (RED, tree_node (BLACK, a, key2, c), key3, tree_node (BLACK, e, wk, f));

                                                    d
                                                        =>
                                                        tree_node (BLACK, a, key2, tree_node (RED, c, key3, d));
                                               esac;

                                      esac;

                                 _ => tree_node (BLACK, a, key2, set'' b);

                              esac;
                    esac;
            end;
        end;

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

    #
    fun set' (key1, m)
        =
        set (m, key1);



    #  Is a key in the domain of the map? 
    #
    fun contains_key (NUMBERED_SET t, k)
        =
        find' t
        where
            fun find' EMPTY
                    =>
                    FALSE;

                find' (TREE_NODE(_, a, key2, _, b))
                    =>
                    case (key::compare (k, key2))
                      
                         LESS    => find' a;
                         EQUAL   => TRUE;
                         GREATER => find' b;
                    esac;
            end;
        end;


    # Return (THE ordinal) corresponding to a key 'k',
    # where 'ordinal' the number of keys preceding
    # 'k' in the overall Numbered_Set.
    #
    # Return NULL if the key is not present.
    #
    fun find (NUMBERED_SET t, k)
        =
        find' (0, t)
        where
            fun find' (_, EMPTY)
                    =>
                    NULL;

                find' (n, TREE_NODE(_, left_subtree, key, _, right_subtree))
                    =>
                    case (key::compare (k, key))
                      
                         LESS    =>  find' (n, left_subtree);
                         EQUAL   =>  THE   (n + keys_in left_subtree);
                         GREATER =>  find' (n + keys_in left_subtree + 1, right_subtree);
                    esac;

            end;
        end;


    # Remove a keyval, returning new map and value removed.
    # Raise lib_base::NOT_FOUND if not found.
    #
    stipulate

        Descent_Path
            = TOP
            | LEFT   ((Color, key::Key, Tree, Descent_Path) )
            | RIGHT  ((Color, Tree, key::Key, Descent_Path) );
    herein
        fun remove (input as NUMBERED_SET input_tree, key_to_remove)
            =
            {
                # We produce our result tree by copying
                # our descent path nodes one by one,
                # starting at the leafward end and proceeding
                # to the root.
                #
                # We have two copying cases to consider:
                #
                # 1)  Initially, our deletion may have produced
                #     a violation of the RED/BLACK invariants
                #     -- specifically, a BLACK deficit -- forcing
                #     us to do on-the-fly rebalancing as we go.
                #
                # 2)  Once the BLACK deficit is resolved (or immediately,
                #     if none was created), copying cannot produce any
                #     additional invariant violations, so path copying
                #     becomes an utterly trivial matter of node duplication.
                #
                # We have two separate routines to handle these two cases:
                #
                #   copy_path   Handles the trivial case.
                #   copy_path'  Handles the rebalancing-needed case.
                #
                fun copy_path (TOP, t) => t;
                    copy_path (LEFT  (color, key, b, rest_of_path), a) => copy_path (rest_of_path, tree_node (color, a, key, b));
                    copy_path (RIGHT (color, a, key, rest_of_path), b) => copy_path (rest_of_path, tree_node (color, a, key, b));
                end;


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


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

                    #
                    #    1B              2B                Wikipedia Case 2
                    #   / \         ->  /  d
                    #  a   2R          1R
                    #     c  d        a  c
                    #         
                    #
                    copy_path' (LEFT (BLACK, key1, TREE_NODE (RED, c, key2, _, d), path), a)                                    # Case 1L 
                        =>
                        copy_path' (LEFT (RED, key1, c, LEFT (BLACK, key2, d, path)), a);
                        # 
                        # We ('a') now have a RED parent and BLACK sibling, so case 4, 5 or 6 will apply.


                    #     1               1           Wikipedia Case 5
                    #    / \             / \
                    #   a  3B       ->  a  2B
                    #     2R e            c  3R
                    #    c d                d  e
                    #
                    copy_path' (LEFT (color, key1, TREE_NODE (BLACK, TREE_NODE (RED, c, key2, _, d), key3, _, e), path), a)     # Case 3L 
                        =>
                        copy_path' (LEFT (color, key1, tree_node (BLACK, c, key2, tree_node (RED, d, key3, e)), path), a);


                    #     1X                  2X       Wikipedia Case 6
                    #    /  \                /  \
                    #   a    2B      ->    1B    3B
                    #       c  3R         a  c  d  e
                    #         d  e 
                    #
                    copy_path' (LEFT (color, key1, TREE_NODE (BLACK, c, key2, _, TREE_NODE (RED, d, key3, _, e)), path), a)     # Case 4L 
                        =>
                        (FALSE, copy_path (path, tree_node (color, tree_node (BLACK, a, key1, c), key2, tree_node (BLACK, d, key3, e))));


                    #      1R              1B         Wikipedia Case 4 
                    #     /  \            /  \
                    #    a    2B    ->   a    2R
                    #        c  d            c  d
                    #
                    copy_path' (LEFT (RED, key1, TREE_NODE (BLACK, c, key2, _, d), path), a)                                    # Case 2L 
                        =>
                        (FALSE, copy_path (path, tree_node (BLACK, a, key1, tree_node (RED, c, key2, d))));
                        #
                        # BLACK sib has exchanged color with RED parent;
                        # this makes up the BLACK deficit on our side
                        # without affecting black path counts on sib's side,
                        # so we're done rebalancing and can revert to
                        # simple path copying for the rest of the way back
                        # to the root.


                    #      1B              1B         Wikipedia Case 3
                    #     /  \            /  \
                    #    a    2B    ->   a    2R
                    #        c  d            c  d
                    #
                    copy_path' (LEFT (BLACK, key1, TREE_NODE (BLACK, c, key2, _, d), path), a)                                  # Case 2L 
                        =>
                        copy_path' (path, tree_node (BLACK, a, key1, tree_node (RED, c, key2, d)));
                        #
                        # Changing BLACK sib to RED locally rebalances in the
                        # sense that paths through us ('a') and our sib (2)
                        # both have the same number of BLACK nodes, but our
                        # subtree as a whole has a BLACK pathcount one lower
                        # than initially, so we continue the rebalancing
                        # act in our parent.



                    #         1B            2B        Wikipidia Case 2  (Mirrored)
                    #        / \          /  \
                    #      2R   b  ->    c   1R        
                    #     c  d              d  b
                    #                  _____
                    copy_path' (RIGHT (BLACK, TREE_NODE (RED, c, key2, _, d), key1, path), b)                                   # Case 1R 
                        =>
                        copy_path' (RIGHT (RED, d, key1, RIGHT (BLACK, c, key2, path)), b);
                        #
                        # We ('b') now have a RED parent and BLACK sibling, so mirrored case 4, 5 or 6 will apply.


                    #         1X              2X       Wikipedia Case 6 (Mirrored)
                    #        /  \            /  \
                    #      2B    b    ->   3B    1B
                    #    3R  e            c  d  e  b
                    #   c  d
                    #
                    copy_path' (RIGHT (color, TREE_NODE (BLACK, TREE_NODE (RED, c, key3, _, d), key2, _, e), key1, path), b)    # Case 3R 
                        =>
                        (FALSE, copy_path (path, tree_node (color, tree_node (BLACK, c, key3, d), key2, tree_node (BLACK, e, key1, b))));


                    #         1               1           Wikipedia Case 5 (Mirrored)
                    #        / \             / \
                    #      2B   b    ->    3B   b
                    #     c  3R          2R  e
                    #       d  e        c  d
                    #
                    copy_path' (RIGHT (color, TREE_NODE (BLACK, c, key2, _, TREE_NODE (RED, d, key3, _, e)), key1, path), b)    # Case 4R 
                        =>
                        copy_path' (RIGHT (color, tree_node (BLACK, tree_node (RED, c, key2, d), key3, e), key1, path), b);


                    #         1R             1B         Wikipedia Case 4 (Mirrored)
                    #        /  \           /  \
                    #      2B    b    ->   2R   b
                    #     c  d            c  d
                    #
                    copy_path' (RIGHT (RED, TREE_NODE (BLACK, c, key2, _, d), key1, path), b)                                   # Case 2R 
                        =>
                        (FALSE, copy_path (path, tree_node (BLACK, tree_node (RED, c, key2, d), key1, b)));
                        #
                        # BLACK sib has exchanged color with RED parent;
                        # this makes up the BLACK deficit on our side
                        # without affecting black path counts on sib's side,
                        # so we're done rebalancing and can revert to
                        # simple path copying for the rest of the way back
                        # to the root.
                    

                    #         1B             1B         Wikipedia Case 3 (Mirrored)
                    #        /  \           /  \
                    #      2B    b    ->   2R   b
                    #     c  d            c  d
                    #
                    copy_path' (RIGHT (BLACK, TREE_NODE (BLACK, c, key2, _, d), key1, path), b)                                 # Case 2R 
                        =>
                        copy_path' (path, tree_node (BLACK, tree_node (RED, c, key2, d), key1, b));


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

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

                    descend (key_to_delete, TREE_NODE (color, left_subtree, key, _, right_subtree),  descent_path)
                        =>
                        case (key::compare (key_to_delete, key))
                          
                             LESS    =>  descend (key_to_delete,   left_subtree, LEFT  (color, key, right_subtree, descent_path));
                             GREATER =>  descend (key_to_delete,  right_subtree, RIGHT (color, left_subtree,  key, descent_path));

                             EQUAL   =>  join (color, left_subtree, right_subtree, descent_path);
                        esac;

                end

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

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

                            # Replace deleted key with
                            # key from first node in our
                            # right subtree:
                            #
                            replacement_key = min_key right_subtree;

                            # Now, act as though the delete never happened:
                            # just continue our descent, with replacement_key in
                            # right subtree as our new delete target:
                            #
                            descend( replacement_key, right_subtree, RIGHT (color, left_subtree, replacement_key, descent_path) );
                        }
                        where
                            #
                            fun min_key (TREE_NODE (_, EMPTY,         key, _, _)) =>  key;
                                min_key (TREE_NODE (_, left_subtree,  _,   _, _)) =>  min_key left_subtree;

                                min_key  EMPTY                                    =>  raise exception MATCH;    # "Impossible"
                            end;
                        end;
                end;

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

                new_tree
                    =
                    case (descend (key_to_remove, input_tree, TOP))
                      
                         # Enforce the invariant that
                         # the root node is always BLACK:
                         #
                         TREE_NODE     (RED,   left_subtree, key, keys, right_subtree)
                             =>
                             TREE_NODE (BLACK, left_subtree, key, keys, right_subtree);

                         ok  => ok;
                    esac;

            
                (NUMBERED_SET new_tree, removed_value);
            };
    end;                #  stipulate

    fun first_key_else_null (NUMBERED_SET t)
        =
        f t
        where
            fun f EMPTY => NULL;
                f (TREE_NODE(_, EMPTY, key1, _, _)) => THE key1;
                f (TREE_NODE(_, a, _, _, _)) => f a;
            end;
        end;

    # Return the number of items in the map:
    #
    fun vals_count (NUMBERED_SET (TREE_NODE (_,_,_, keys, _))) => keys;
        vals_count (NUMBERED_SET EMPTY)                        => 0;
    end;
        

# XXX BUGGO FIXME  The stuff below here is probably mostly broken;
#                  it isn't clear if it even makes sense to have
#                  this stuff in this package.  Needs inspection,
#                  thinking and testing.

    #
    fun fold_forward f
        =
        {   fun foldf (EMPTY, accum)
                    =>
                    accum;

                foldf (TREE_NODE(_, a, key, _, b), accum)
                    =>
                    foldf (b, f (key, foldf (a, accum)));
            end;
        
            fn init
                =
                fn (NUMBERED_SET m)
                    =
                    foldf (m, init);
        };

    #
    fun keyed_fold_forward f
        =
        {   fun foldf (EMPTY, accum)
                    =>
                    accum;

                foldf (TREE_NODE(_, a, key, keys, b), accum)
                    =>
                    foldf (b, f (key, keys, foldf (a, accum)));
            end;
        
            fn init
                =
                fn (NUMBERED_SET m)
                    =
                    foldf (m, init);
        };

    #
    fun fold_backward f
        =
        {   fun foldf (EMPTY, accum)
                    =>
                    accum;

                foldf (TREE_NODE(_, a, key, _, b), accum)
                    =>
                    foldf (a, f (key, foldf (b, accum)));
            end;
        
            fn init
                =
                fn (NUMBERED_SET m)
                    =
                    foldf (m, init);
        };

    #
    fun keyed_fold_backward f
        =
        {   fun foldf (EMPTY, accum)
                    =>
                    accum;

                foldf (TREE_NODE(_, a, key, keys, b), accum)
                    =>
                    foldf (a, f (key, keys, foldf (b, accum)));
            end;
        
            fn init
                =
                fn (NUMBERED_SET m)
                    =
                    foldf (m, init);
        };

    # Return an ordered list of the keys in the map:
    #
    fun keys_list m
        =
        keyed_fold_backward (fn (k, _, l) = k ! l) [] m;

    # Functions for walking the tree
    # while keeping a stack of parents
    # to be visited:
    #
    fun next ((t as TREE_NODE(_, _, _, _, b)) ! rest) =>  (t, left (b, rest));
        next _                                        =>  (EMPTY, []);
    end 

    also
    fun left (EMPTY, rest)
            =>
            rest;

        left (t as TREE_NODE(_, a, _, _, _), rest)
            =>
            left (a, t ! rest);
    end;

    #
    fun start m
        =
        left (m, []);



    # Support for constructing red-black trees
    # in linear time from increasing ordered
    # sequences.
    #
    # Based on a description by Ralf Hinze
    #   http://www.eecs.usma.edu/webs/people/okasaki/waaapl99.pdf#page=95
    # which represents tree structures
    # via binary numbers using only the digits
    # 1 and 2.  (0 is used only for the empty tree.)
    #
    # Note that the elements in the digits
    # are ordered with the largest on the left,
    # whereas the elements of the trees
    # are ordered with the largest on the right.
    #
    Digit
      = ZERO
      | ONE  ((key::Key, Tree, Digit) )
      | TWO  ((key::Key, Tree, key::Key, Tree, Digit) );

    # Add a keyval that is guaranteed
    # to be larger than any in l:
    #
    fun add_item (key, l)
        =
        incr (key, EMPTY, l)
        where
            fun incr (key, tree, ZERO)
                    =>
                    ONE (key, tree, ZERO);

                incr (       key1, tree1,
                       ONE ( key2, tree2,
                             rest
                           )
                     )
                    =>
                    TWO ( key1, tree1,
                          key2, tree2,
                          rest
                        );

                incr (       key1, tree1,
                       TWO ( key2, tree2,
                             key3, tree3,
                             rest
                           )
                     )
                    =>
                    ONE (       key1, tree1,
                         incr ( key2, tree_node (BLACK, tree3, key3, tree2),
                                rest
                              )
                        );
            end;
        end;

    # Link the digits into a tree:
    #
    fun link_all  digits
        =
        link (EMPTY, digits)
        where
            # We consume digits from our second argument and
            # accumulate our eventual result in our first argument:
            #
            fun link (result_tree, ZERO)
                    =>
                    result_tree;

                link (result_tree, ONE (key, tree, rest))
                    =>
                    link (tree_node (BLACK, tree, key, result_tree), rest);

                link (  result_tree,
                        TWO ( key1, tree1,
                              key2, tree2,
                              rest
                            )
                     )
                    =>
                    link ( tree_node (BLACK, tree_node (RED, tree2, key2, tree1), key1, result_tree),
                           rest
                         );
            end;
        end;


    stipulate

        #
        fun wrap f (NUMBERED_SET map1, NUMBERED_SET map2)
            =
            {   my (n, result)
                    =
                    f (start map1, start map2, 0, ZERO);
            
                NUMBERED_SET (link_all result);
            };

        #
        fun set'' ((EMPTY, _), n, result)
                =>
                (n, result);

            set'' ((TREE_NODE(_, _, key1, _, _), r), n, result)
                =>
                set'' (next r, n+1, add_item (key1, result));
        end;
    herein

        # Return a map whose domain is the union
        # of the domains of the two input maps,
        # using 'merge_fn' to select the vals
        # for keys that are in both domains.
        #
# XXX BUGGO FIXME merge_fn does nothing
        fun union_with  merge_fn
            =
            wrap union
            where
                fun union (tree1, tree2, n, result)
                    =
                    case ( next tree1,
                           next tree2
                         )
                      
                         ((EMPTY, _), (EMPTY, _)) =>                  (n, result);
                         ((EMPTY, _), tree2     ) =>  set'' (tree2, n, result);
                         (tree1,      (EMPTY, _)) =>  set'' (tree1, n, result);

                         (   (TREE_NODE(_, _, key1, _, _), rest1),
                             (TREE_NODE(_, _, key2, _, _), rest2)
                         )
                             =>
                             case (key::compare (key1, key2))
                               
                                  LESS      =>   union (rest1, tree2, n+1, add_item (key1, result));
                                  EQUAL     =>   union (rest1, rest2, n+1, add_item (key1, result));
                                  GREATER   =>   union (tree1, rest2, n+1, add_item (key2, result));
                             esac;

                    esac;
            end;

        #
# XXX BUGGO FIXME merge_fn does nothing
        fun keyed_union_with  merge_fn
            =
            {   fun union (tree1, tree2, n, result)
                    =
                    case ( next tree1,
                           next tree2
                         )
                      
                         ((EMPTY, _), (EMPTY, _)) =>                  (n, result);
                         ((EMPTY, _), tree2     ) =>  set'' (tree2, n, result);
                         (tree1,      (EMPTY, _)) =>  set'' (tree1, n, result);

                         ( (TREE_NODE(_, _, key1, _, _), rest1),
                           (TREE_NODE(_, _, key2, _, _), rest2)
                         )
                             =>
                             case (key::compare (key1, key2))
                               
                                  LESS    =>   union (rest1, tree2, n+1, add_item (key1, result));
                                  EQUAL   =>   union (rest1, rest2, n+1, add_item (key1, result));
                                  GREATER =>   union (tree1, rest2, n+1, add_item (key2, result));
                             esac;
                    esac;
            
                wrap union;
            };

        # Return a map whose domain is
        # the intersection of the domains
        # of the two input maps, using the
        # supplied function to define the range.
        #
# XXX BUGGO FIXME merge_fn does nothing
        fun intersect_with  merge_fn
            =
            {   fun intersect (tree1, tree2, n, result)
                    =
                    case ( next tree1,
                           next tree2
                         )
                      
                         ( (TREE_NODE(_, _, key1, _, _), r1),
                           (TREE_NODE(_, _, key2, _, _), r2)
                         )
                             =>
                             case (key::compare (key1, key2))
                               
                                  LESS    =>  intersect (r1, tree2, n,                result);
                                  EQUAL   =>  intersect (r1, r2, n+1, add_item (key1, result));
                                  GREATER =>  intersect (tree1, r2, n,                result);
                             esac;

                         _ => (n, result);
                    esac;

            
                wrap intersect;
            };
        #
# XXX BUGGO FIXME merge_fn does nothing
        fun keyed_intersect_with  merge_fn
            =
            {   fun intersect (tree1, tree2, n, result)
                    =
                    case ( next tree1,
                           next tree2
                         )
                      
                         (   (TREE_NODE(_, _, key1, _, _), r1),
                             (TREE_NODE(_, _, key2, _, _), r2)
                         )
                             =>
                             case (key::compare (key1, key2))
                               
                                  LESS      =>   intersect (r1, tree2, n,                result);
                                  EQUAL     =>   intersect (r1, r2, n+1, add_item (key1, result));
                                  GREATER   =>   intersect (tree1, r2, n,                result);
                             esac;

                            _ => (n, result);
                    esac;
            
                wrap intersect;
            };

    #
    fun apply f
        =
        {   fun appf EMPTY
                    =>
                    ();

                appf (TREE_NODE(_, a, key, _, b))
                    =>
                    {   appf a;
                        f key;
                        appf b;
                    };
            end;
        
            fn (NUMBERED_SET m)
                =
                appf m;
        };

    #
    fun keyed_apply  f
        =
        {   fun appf EMPTY
                    =>
                    ();

                appf (TREE_NODE(_, a, key, keys, b))
                    =>
                    {   appf a;
                        f (key, keys);
                        appf b;
                    };
            end;
        
            fn (NUMBERED_SET m)
                =
                appf m;
        };

    # Filter out those elements of the map
    # that do not satisfy given predicate.
    #
    # The filtering is done in increasing map order:
    #
    fun filter predicate (NUMBERED_SET t)
        =
        NUMBERED_SET (link_all result)
        where
            fun walk (EMPTY, n, result)
                    =>
                    (n, result);

                walk (TREE_NODE(_, a, key1, _, b), n, result)
                    =>
                    {   my (n, result)
                            =
                            walk (a, n, result);

                        if   (predicate key1)   walk (b, n+1, add_item (key1, result));
                        else                    walk (b, n, result);                fi;
                    };
            end;

            my (n, result)
                =
                walk (t, 0, ZERO);
        end;

    #
    fun keyed_filter predicate (NUMBERED_SET t)
        =
        NUMBERED_SET (link_all result)
        where
            fun walk (EMPTY, n, result)
                    =>
                    (n, result);

                walk (TREE_NODE(_, a, key, keys, b), n, result)
                    =>
                    {   my (n, result)
                            =
                            walk (a, n, result);

                        if   (predicate (key, keys))   walk (b, n+1, add_item (key, result));
                        else                           walk (b, n, result);               fi;
                    };
            end;

            my (n, result)
                =
                walk (t, 0, ZERO);
        end;
    end;


    fun from_list  list
        =
        loop (ZERO, list)
        where
            fun loop (result, [])
                    =>
                    NUMBERED_SET (link_all result);

                loop (result, this ! rest)
                    =>
                    loop (add_item (this, result), rest );
            end;                
        end; 
};











Comments and suggestions to: bugs@mythryl.org

PreviousUpNext