PreviousUpNext

15.4.998  src/lib/src/unt-red-black-set.pkg

## unt-red-black-set.pkg

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

# 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 Hinze,
# 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.

###                 "History will be kind to me
###                  for I intend to write it."
###
###                          -- Winston Churchill


package unt_red_black_set : Set         # Set   is from   src/lib/src/set.api
where
    key::Key == Unt
=
package {

    package key {
         Key = Unt;
        compare = unt::compare;
    };

    Item = Unt;

    Color = RED | BLACK;

    Tree
      = EMPTY
      | TREE_NODE  ((Color, Tree, Item, Tree));

    Set = SET  ((Int, Tree));

#    fun all_invariants_hold set = TRUE;                # Placeholder.

    # Check invariants:
    #
    fun all_invariants_hold (SET (nodecount, EMPTY))
            =>
            nodecount == 0;

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

        all_invariants_hold (SET (nodecount, tree))
            =>
            (   black_invariant_ok  tree
                and
                red_invariant_ok   (TRUE, tree)
                and
                nodecount_ok   (nodecount, 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;

                # The count field in the header must
                # equal the number of nodes in the tree:
                #
                fun nodecount_ok (nodecount, tree)
                    =
                    nodecount == count_nodes tree
                    where
                        fun count_nodes   EMPTY
                                =>
                                0;

                            count_nodes  (TREE_NODE (_, left_subtree, _, right_subtree))
                                =>
                                count_nodes  left_subtree
                                +
                                count_nodes right_subtree
                                +
                                1;
                        end;
                    end;

            end;
    end;

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

    empty = SET (0, EMPTY);

    #
    fun singleton x
        =
        SET (1, TREE_NODE (RED, EMPTY, x, EMPTY));
    #
    fun add (SET (n_items, m), x)
        =
        {   m = case (ins m)
                  
                     TREE_NODE (RED, left_subtree, key, 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, right_subtree);

                     other => other;
                esac;
        

              SET(*n_items', m);
        }
        where

            n_items' = REF n_items;

            fun ins EMPTY
                    =>
                    {   n_items' := n_items+1;
                        TREE_NODE (RED, EMPTY, x, EMPTY);
                    };

                ins (s as TREE_NODE (color, a, y, b))
                    =>
                    if   (x < y)
                    
                         case a
                           
                              TREE_NODE (RED, c, z, d)
                                  =>
                                  if  (x < z)
                                  
                                       case (ins c)
                                         
                                            TREE_NODE (RED, e, w, f)
                                                =>
                                                TREE_NODE (RED, TREE_NODE (BLACK, e, w, f), z, TREE_NODE (BLACK, d, y, b));

                                            c   =>
                                                TREE_NODE (BLACK, TREE_NODE (RED, c, z, d), y, b);
                                       esac;

                                  else
                                       if   (x == z)
                                       
                                            TREE_NODE (color, TREE_NODE (RED, c, x, d), y, b);
                                       else
                                            case (ins d)
                                              
                                                 TREE_NODE (RED, e, w, f)
                                                     =>
                                                     TREE_NODE (RED, TREE_NODE (BLACK, c, z, e), w, TREE_NODE (BLACK, f, y, b));

                                                  d  =>
                                                     TREE_NODE (BLACK, TREE_NODE (RED, c, z, d), y, b);
                                            esac;
                                       fi;
                                  fi;

                              _   => TREE_NODE (BLACK, ins a, y, b);
                          esac;

                    else
                          if   (x == y)
                          
                               TREE_NODE (color, a, x, b);
                          else
                               case b
                                 
                                    TREE_NODE (RED, c, z, d)
                                        =>
                                        if   (x < z)
                                        
                                             case (ins c)
                                               
                                                  TREE_NODE (RED, e, w, f)
                                                      =>
                                                      TREE_NODE (RED, TREE_NODE (BLACK, a, y, e), w, TREE_NODE (BLACK, f, z, d));

                                                  c   =>
                                                      TREE_NODE (BLACK, a, y, TREE_NODE (RED, c, z, d));
                                             esac;

                                        else
                                             if   (x == z)
                                             
                                                  TREE_NODE (color, a, y, TREE_NODE (RED, c, x, d));
                                             else
                                                  case (ins d)
                                                    
                                                       TREE_NODE (RED, e, w, f)
                                                           =>
                                                           TREE_NODE (RED, TREE_NODE (BLACK, a, y, c), z, TREE_NODE (BLACK, e, w, f));

                                                       d   =>
                                                           TREE_NODE (BLACK, a, y, TREE_NODE (RED, c, z, d));
                                                  esac;
                                             fi;
                                        fi;

                                    _   =>
                                        TREE_NODE (BLACK, a, y, ins b);
                               esac;
                          fi;
                    fi;
            end;
        end;

    #
    fun add' (x, m)
        =
        add (m, x);

    #
    fun add_list (s, [])
            =>
            s;

        add_list (s, x ! r)
            =>
            add_list (add (s, x), r);
    end;

    # Remove an item.  Raises LibBase::NOT_FOUND if not found. 
    #
    stipulate

       Descent_Path
        = TOP
        | LEFT   ((Color, Item, Tree, Descent_Path))
        | RIGHT  ((Color, Tree, Item, Descent_Path));
    herein
        fun delete (input as SET (n_items, 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))));


                                # OLD BROKEN CODE       copy_path' (RIGHT (color, TREE_NODE (BLACK, c, key3, TREE_NODE (RED, d, key2, e)), key1, path), 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);

                                # OLD BROKEN CODE   (FALSE, copy_path (path, TREE_NODE (color, c, key2, TREE_NODE (BLACK, TREE_NODE (RED, d, key3, e), key1, 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 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;

                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, right_subtree)
                             =>
                             TREE_NODE (BLACK, left_subtree, key, right_subtree);

                         ok  => ok;
                    esac;

                SET (n_items - 1, new_tree);



            };
    end;                # stipulate

    # Return TRUE if and only if item is an element in the set:
    # 
    fun member (SET(_, t), k)
        =
        {   fun find' EMPTY => FALSE;

                find' (TREE_NODE(_, a, y, b))
                   =>
                   (k == y)                  or
                   ((k < y) and find' a)     or
                   find' b;
            end;
          
            find' t;
        };

    # Return the number of items in the map
    #
    fun vals_count (SET (n, _)) = n;
    #
    fun fold_forward f
        =
        {
            fun foldf (EMPTY, accum)
                    =>
                    accum;

                foldf (TREE_NODE(_, a, x, b), accum)
                    =>
                    foldf (b, f (x, foldf (a, accum)));
            end;

            fn init
                =
                fn (SET(_, m))
                    =
                    foldf (m, init);
        };
    #
    fun fold_backward f
        =
        {   fun foldf (EMPTY, accum)
                    =>
                    accum;

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

    # Return an ordered list of the items in the set:
    #
    fun vals_list s
        =
        fold_backward
            (fn (x, l) =  x ! l)
            []
            s;

    # 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, []);

    # Return TRUE if and only if the two sets are equal 
    #
    fun equal (SET(_, s1), SET(_, s2))
        =
        compare (start s1, start s2)
        where
            fun compare (t1, t2)
                =
                case (next t1, next t2)
                  
                     ((EMPTY, _), (EMPTY, _)) => TRUE;
                     ((EMPTY, _), _         ) => FALSE;
                     (_,          (EMPTY, _)) => FALSE;

                     ((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
                         =>
                         x == y
                         and
                         compare (r1, r2);
                esac;
        end;

    # Return the lexical order of two sets 
    #
    fun compare (SET(_, s1), SET(_, s2))
        =
        {   fun compare (t1, t2)
                =
                case (next t1, next t2)
                  
                     ((EMPTY, _), (EMPTY, _)) => EQUAL;
                     ((EMPTY, _), _         ) => LESS;
                     (_,          (EMPTY, _)) => GREATER;

                     ( (TREE_NODE(_, _, x, _), r1),
                       (TREE_NODE(_, _, y, _), r2)
                     )
                         =>
                         if   (x == y)
                          compare (r1, r2);
                         else
                              if   (x < y)
                               LESS;
                              else GREATER;  fi;
                         fi;
                 esac;

          
            compare (start s1, start s2);
          };

    #  Return TRUE if and only if the first set is a subset of the second 
    #
    fun is_subset (SET(_, s1), SET(_, s2))
        =
        {   fun compare (t1, t2)
                =
                case (next t1, next t2)
                  
                     ((EMPTY, _), (EMPTY, _)) => TRUE;
                     ((EMPTY, _), _) => TRUE;
                     (_, (EMPTY, _)) => FALSE;

                     ((TREE_NODE(_, _, x, _), r1), (TREE_NODE(_, _, y, _), r2))
                         =>
                         (x == y  and  compare (r1, r2))
                         or
                         (x >  y  and  compare (t1, r2));
                esac;

          
            compare (start s1, start s2);
        };

    # Support for constructing red-black trees in linear time from increasing
    # ordered sequences (based on a description by RED. Hinze).  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  ((Item, Tree, Digit))
      | TWO  ((Item, Tree, Item, Tree, Digit));

    # Add an item that is guaranteed
    # to be larger than any in l:
    # 
    fun add_item (a, l) = {
          fun incr (a, t, ZERO) => ONE (a, t, ZERO);
             incr (a1, t1, ONE (a2, t2, r)) => TWO (a1, t1, a2, t2, r);
             incr (a1, t1, TWO (a2, t2, a3, t3, r)) =>
                ONE (a1, t1, incr (a2, TREE_NODE (BLACK, t3, a3, t2), r)); end;
          
            incr (a, EMPTY, l);
          };

    # Link the digits into a tree:
    #
    fun link_all t
        =
        {   fun link (t, ZERO) => t;
                link (t1, ONE (a, t2, r)) => link (TREE_NODE(BLACK, t2, a, t1), r);
                link (t, TWO (a1, t1, a2, t2, r)) =>
                   link (TREE_NODE(BLACK, TREE_NODE (RED, t2, a2, t1), a1, t), r);
            end;
          
            link (EMPTY, t);
        };

    # Set union
    #
    fun union (SET(_, s1), SET(_, s2))
        =
        {
          fun ins ((EMPTY, _), n, result)
                  =>
                  (n, result);

              ins ((TREE_NODE(_, _, x, _), r), n, result)
                  =>
                  ins (next r, n+1, add_item (x, result));
          end;

          fun union' (t1, t2, n, result)
              =
              case (next t1, next t2)
                
                   ((EMPTY, _), (EMPTY, _)) =>  (n, result);
                   ((EMPTY, _), t2        ) =>  ins (t2, n, result);
                   (t1,         (EMPTY, _)) =>  ins (t1, n, result);

                   ( (TREE_NODE(_, _, x, _), r1),
                     (TREE_NODE(_, _, y, _), r2)
                   )
                       =>
                       if   (x < y)
                        union' (r1, t2, n+1, add_item (x, result));
                       else
                            if   (x == y)
                             union' (r1, r2, n+1, add_item (x, result));
                            else union' (t1, r2, n+1, add_item (y, result));  fi;
                       fi;
              esac;

            my (n, result)
                =
                union' (start s1, start s2, 0, ZERO);
          
            SET (n, link_all result);
        };

    # Set intersection
    #
    fun intersection (SET(_, s1), SET(_, s2))
        =
        {   fun intersect (t1, t2, n, result)
                =
                case (next t1, next t2)
                  
                     ( (TREE_NODE(_, _, x, _), r1),
                       (TREE_NODE(_, _, y, _), r2)
                     )
                         =>
                         if   (x < y)
                          intersect (r1, t2, n, result);
                         else
                              if   (x == y)
                                   intersect (r1, r2, n+1, add_item (x, result));
                              else intersect (t1, r2, n, result);   fi;
                         fi;

                     _   =>
                         (n, result);
                esac;

            my (n, result)
                =
                intersect (start s1, start s2, 0, ZERO);
          
            SET (n, link_all result);
        };

    # Set difference 
    #
    fun difference (SET(_, s1), SET(_, s2))
        =
        {   fun ins ((EMPTY, _), n, result)
                    =>
                    (n, result);

                ins ((TREE_NODE(_, _, x, _), r), n, result)
                    =>
                    ins (next r, n+1, add_item (x, result));
             end;

            fun diff (t1, t2, n, result)
                =
                case (next t1, next t2)
                  
                     ((EMPTY, _), _) => (n, result);
                     (t1, (EMPTY, _)) => ins (t1, n, result);

                     ( (TREE_NODE(_, _, x, _), r1),
                       (TREE_NODE(_, _, y, _), r2)
                     )
                         =>
                         if   (x < y)
                              diff (r1, t2, n+1, add_item (x, result));
                         else
                              if   (x == y)
                                   diff (r1, r2, n, result);
                              else diff (t1, r2, n, result);   fi;
                         fi;
                esac;

          my (n, result) = diff (start s1, start s2, 0, ZERO);
          
            SET (n, link_all result);
          };
    #
    fun apply f
        =
        {   fun appf EMPTY => ();

                appf (TREE_NODE(_, a, x, b))
                    =>
                    {   appf a;
                        f x;
                        appf b;
                    };
            end;

            fn (SET(_, m)) = appf m;
        };
    #
    fun map f
        =
        {   fun addf (x, m)
                =
                add (m, f x);
          
            fold_forward addf empty;
        };

    # Filter out those elements of the set that do not satisfy the
    # predicate.  The filtering is done in increasing map order.
    #
    fun filter prior (SET(_, t))
        =
        {
            fun walk (EMPTY, n, result)
                    =>
                    (n, result);

                walk (TREE_NODE(_, a, x, b), n, result)
                  =>
                  {   my (n, result)
                          =
                          walk (a, n, result);
                
                      if   (prior x)
                           walk (b, n+1, add_item (x, result));
                      else walk (b, n, result);fi;
                  };
            end;

            my (n, result)
                =
                walk (t, 0, ZERO);
          
            SET (n, link_all result);
        };

    #
    fun partition prior (SET(_, t))
        =
        {   fun walk (EMPTY, n1, result1, n2, result2)
                    =>
                    (n1, result1, n2, result2);

                walk (TREE_NODE(_, a, x, b), n1, result1, n2, result2)
                    =>
                    {   my (n1, result1, n2, result2)
                            =
                            walk (a, n1, result1, n2, result2);
                
                        if   (prior x)
                             walk (b, n1+1, add_item (x, result1), n2, result2);
                        else walk (b, n1, result1, n2+1, add_item (x, result2));  fi;
                    };
            end;

            my (n1, result1, n2, result2)
                =
                walk (t, 0, ZERO, 0, ZERO);
          
            (SET (n1, link_all result1), SET (n2, link_all result2));
        };

    #
    fun exists prior
        =
        {   fun test EMPTY => FALSE;

                test (TREE_NODE(_, a, x, b))
                    =>
                    test a
                    or
                    prior x
                    or
                    test b;
            end;
          
            fn (SET(_, t))
                =
                test t;
        };

    #
    fun all prior
        =
        {   fun test EMPTY => TRUE;

                test (TREE_NODE(_, a, x, b))
                    =>
                    test a
                    and
                    prior x
                    and
                    test b;
            end;

            fn (SET(_, t))
                =
                test t;
        };

    #
    fun find prior
        =
        {   fun test EMPTY => NULL;

                test (TREE_NODE(_, a, x, b))
                    =>
                    case (test a)
                      
                         NULL
                             =>
                             if   (prior x   )   THE x;
                                           else   test b;   fi;

                         some_item
                             =>
                             some_item;
                    esac;
            end;
          
            fn (SET(_, t)) = test t;
        };
};









Comments and suggestions to: bugs@mythryl.org

PreviousUpNext