PreviousUpNext

15.4.898  src/lib/src/leftist-tree-priority-queue.pkg

# leftist-tree-priority-queue.pkg
# Priority queues implemented as leftist trees

# -- Allen Leung

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

###          "Progress is made by lazy men looking
###           for easier ways to do things."
###
###                       -- Robert Heinlein



package   leftist_tree_priority_queue
:                      Priority_Queue                                           # Priority_Queue        is from   src/lib/src/priority-queue.api
{
    # A leftist tree is a binary tree with priority ordering
    # with the invariant that the left branch is always the taller one         

    Leftist(X)
      = NODE    (X, Int, Leftist(X), Leftist(X))
      | EMPTY
      ;

    Priority_Queue(X)
        =
        PRIORITY_QUEUE
          {
            less:  (X, X) -> Bool, 
            root:  Ref(  Leftist(X) ) 
          };

    exception EMPTY_PRIORITY_QUEUE;

    # Assume a is smaller than b:
    #
    fun merge_trees less (a, b)
        =
        {   fun dist EMPTY              =>  0;
                dist (NODE(_, d, _, _)) =>  d;
            end;

            fun m (EMPTY, a) =>  a;
                m (a, EMPTY) =>  a;

                m (a as NODE (x, d, l, r), b as NODE (y, d', l', r'))
                =>
                    {   my (root, l, r)
                            = 
                            if   (less (x, y)   )   (x, l,  m (r,  b));
                                               else   (y, l', m (r', a));   fi; 

                        d_l =   dist l;
                        d_r =   dist r;

                        my (l, r)
                            =
                            if   (d_l  >=  d_r   )   (l, r);
                                                else   (r, l);   fi;

                        NODE (root, 1+int::max (d_l, d_r), l, r); 
                    };
            end;

            m (a, b); 
       };


    fun make_priority_queue  less
        =
        PRIORITY_QUEUE { less, root => REF EMPTY };


    fun make_priority_queue' (less, _, _)
      = make_priority_queue   less;


    fun min (PRIORITY_QUEUE { root => REF (NODE (x, _, _, _)), ... } ) =>   x;
        min _                                                          =>   raise exception EMPTY_PRIORITY_QUEUE;
    end;


    fun is_empty (PRIORITY_QUEUE { root => REF EMPTY, ... } ) =>   TRUE;
        is_empty _                                            =>   FALSE;
    end;


    fun clear (PRIORITY_QUEUE { root, ... } )
        =
        root := EMPTY;


    fun delete_min (PRIORITY_QUEUE { root => root as REF (NODE (x, _, l, r)), less } )
            =>
            {   root := merge_trees less (l, r);
                x;
            };

        delete_min _
            =>
            raise exception EMPTY_PRIORITY_QUEUE;
    end;


    fun merge (PRIORITY_QUEUE { root => r1, less }, PRIORITY_QUEUE { root => r2, ... } )
        =
        PRIORITY_QUEUE
          { root => REF (merge_trees less (*r1,*r2)),
            less
          };


    fun merge_into { src => PRIORITY_QUEUE { root =>      REF t1, less }, 
                     dst => PRIORITY_QUEUE { root => r as REF t2, ...  }
                   }
        =
        r := merge_trees less (t1, t2);


    fun merge_elems (less, q, elements)
        =
        m (q, elements)
        where
            fun m (q,[])      =>  q;
                m (q, e ! es) =>  m (merge_trees less (q, NODE (e, 1, EMPTY, EMPTY)), es);
            end;
        end;


    fun set   (PRIORITY_QUEUE { root => r as REF t1,  less })   x
        =
        r := merge_trees less (t1, NODE (x, 1, EMPTY, EMPTY)); 


    fun from_list  less  list
        =
        PRIORITY_QUEUE { root => REF (merge_elems (less, EMPTY, list)),
                         less
                       };


    fun collect (EMPTY,             e) =>   e;
        collect (NODE (x, _, l, r), e) =>   collect (l, collect (r, x ! e));
    end;


    fun to_list (PRIORITY_QUEUE { root => REF t, ... } )
        =
        collect (t, []);

};



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext