15.4.894  src/lib/src/heap-priority-queue.pkg

# heap-priority-queue.pkg
#
# This implements a priority queue using a heap
# 
# -- Allen Leung

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

###              "A hacker on a roll may be able to produce,
###               in a period of a few months, something that
###               a small development group (say, 7-8 people)
###               would have a hard time getting together
###               over a year.
###
###              "IBM used to report that certain programmers
###               might be as much as 100 times as productive
###               as other workers, or more."
###
###                                  -- Peter Seebach



stipulate
    package rwv = rw_vector;                    # rw_vector             is from   src/lib/std/src/rw-vector.pkg
herein

    package heap_priority_queue
    :            Priority_Queue                 # Priority_Queue        is from   src/lib/src/priority-queue.api
    {
        exception EMPTY_PRIORITY_QUEUE;
        exception UNIMPLEMENTED;

        Priority_Queue(X)
            = 
            HEAP  { less:  (X, X) -> Bool,
                    heap:  rwv::Rw_Vector(X),
                    size:  Ref( Int )
                  };

        fun make_priority_queue' (less, n, dummy)
            = 
            HEAP { less,
                   heap => rwv::make_rw_vector (n, dummy),
                   size => REF 0
                 };

        fun unimplemented() =   raise exception UNIMPLEMENTED;

        fun make_priority_queue _       =   unimplemented();            # XXX SUCKO FIXME this is the opposite of typesafe -- it will compile fine and die at runtime. Either implement everything or else define a separate API, dammit.
        fun merge _                     =   unimplemented();
        fun merge_into _                =   unimplemented();
        fun to_list _                   =   unimplemented();


        fun is_empty (HEAP { size => REF 0, ... } ) => TRUE;
            is_empty _ => FALSE;
        end;


        fun clear (HEAP { size, ... } )
            =
            size := 0;


        fun min (HEAP { size => REF 0, ... } ) =>  raise exception EMPTY_PRIORITY_QUEUE;
            #
            min (HEAP { heap,          ... } ) =>  rwv::get (heap, 0);
        end;


        fun set (HEAP { size, heap, less, ... } ) x
            =
            {   nnn = *size;

                fun siftup 0 => 0;

                    siftup i
                        =>
                        {   j = (i - 1) / 2;
                            y = rwv::get (heap, j);

                            if (less (x, y))
                                #
                                rwv::set (heap, i, y);
                                siftup j;
                            else
                                i;
                            fi;
                        };
                end;

                size := nnn + 1;
                rwv::set (heap, siftup nnn, x);
            };


        fun sift_down (heap, less, nnn, i, x)
            =
            {   fun siftdown (i, x)
                    = 
                    {   j = i + i + 1;
                        k = j + 1;

                        if (j >= nnn)
                            #
                            i;
                        else
                            y = rwv::get (heap, j);

                            if (k >= nnn)
                                #
                                if (less (y, x))        go (i, x, j, y); else i;fi; 
                            else 
                                z = rwv::get (heap, k);

                                if (less (y, x))
                                     #
                                     if (less (z, y))   go (i, x, k, z); 
                                     else               go (i, x, j, y);
                                     fi;
                                elif (less (z, x))      go (i, x, k, z);
                                else                    i;
                                fi;
                            fi;
                        fi;
                    }

                also
                fun go (i, x, j, y)
                    =
                    {   rwv::set (heap, i, y);
                        siftdown (j, x);
                    };

                pos_x = siftdown (i, x); 
                rwv::set (heap, pos_x, x); 
                pos_x; 
            };


        fun delete_min (HEAP { size => REF 0, ... } )
                =>
                raise exception EMPTY_PRIORITY_QUEUE;

            delete_min (HEAP { size, heap, less, ... } )
                =>
                {   nnn   =  *size - 1;
                    #
                    min   =  rwv::get (heap, 0);
                    x     =  rwv::get (heap, nnn);
                  
                    x_pos =  sift_down (heap, less, nnn, 0, x);

                    size :=  nnn;

                    min;
                };
        end;


        fun from_list less data
            =
            {   heap =  rwv::from_list  data;
                nnn  =  rwv::length     heap;


                fun make_heap -1 =>   ();
                    #
                    make_heap i
                        => 
                        {   sift_down (heap, less, nnn, i, rwv::get (heap, i));
                            make_heap (i - 1);
                        };
                end;

                if (nnn >= 2)   make_heap ((nnn+1) / 2);   fi;

                HEAP { less, heap,   size => REF nnn }; 
            };
    };
end;