15.4.781  src/lib/graph/node-priority-queue-g.pkg

## node-priority-queue-g.pkg
#
# This implements a priority queue for nodes in a graph
# 
# -- Allen Leung

# Compiled by:
#     src/lib/graph/graphs.lib

stipulate
    package odg =  oop_digraph;                                 # oop_digraph   is from   src/lib/graph/oop-digraph.pkg
herein
                                                                # Rw_Vector             is from   src/lib/std/src/rw-vector.api
    generic package node_priority_queue_g (
        vec:  Rw_Vector
    )
    : (weak)  Node_Priority_Queue                               # Node_Priority_Queue   is from   src/lib/graph/node-priority-queue.api
    {

        exception EMPTY_PRIORITY_QUEUE;

        Node_Priority_Queue
            = 
            PQ  { less:  (odg::Node_Id, odg::Node_Id) -> Bool,
                   heap:  vec::Rw_Vector( odg::Node_Id ), 
                   pos:   vec::Rw_Vector( Int ), 
                   size:  Ref( Int )
                 };

        fun create n less
            =
            PQ { less, 
                 heap => vec::make_rw_vector (n, 0),
                 pos  => vec::make_rw_vector (n, 0),
                 size => REF 0
               };

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

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

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

        fun decrease_weight (PQ { size, heap, pos, less }, x)
            =
            {   fun siftup 0 =>  0;

                    siftup i
                        =>
                        {   j =  (i - 1) / 2;
                            y =  vec::get (heap, j);
                            #
                            if (less (x, y))
                                #
                                vec::set (heap, i, y);
                                vec::set (pos, y, i);
                                siftup j;
                            else
                                i;
                            fi;
                        };
                end; 

                x_pos =  siftup (vec::get (pos, x));

                vec::set (heap, x_pos, x);
                vec::set (pos, x, x_pos);
            };

        fun set (q as PQ { size, heap, pos, ... }, x)
            =
            {   nnn =  *size;

                vec::set (heap, nnn, x);
                vec::set (pos, x, nnn);

                size :=  nnn + 1;

                decrease_weight (q, x);
            };

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

            delete_min (PQ { size, heap, pos, less } )
                =>
                {   nnn = *size - 1;

                    fun siftdown (i, x)
                        = 
                        {   j =  i + i + 1;
                            k =  j + 1;

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

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

                    min   =  vec::get (heap, 0);
                    x     =  vec::get (heap, nnn);
                    x_pos =  siftdown (0, x);

                    vec::set (heap, x_pos, x);
                    vec::set (pos, x, x_pos); 

                    size := nnn;
                    min;
                };
        end;                            # fun delete_min

        fun from_graph less (odg::DIGRAPH ggg)
            =
            {   nnn  = ggg.order ();
                heap = vec::make_rw_vector (nnn, 0); 
                pos  = vec::make_rw_vector (ggg.capacity (), 0); 

                fun siftdown (i, x)
                    = 
                    {   j = i*2 + 1;
                        k = j + 1;

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

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

                fun make_heap -1
                        =>
                        ();

                    make_heap i
                        =>
                        {   siftdown (i, vec::get (heap, i));
                            make_heap (i - 1);
                        };
                end;

                i =  REF 0; 

                ggg.forall_nodes
                    (\\ (u, _)
                        =
                        {   i' = *i;
                            vec::set (heap, i', u);
                            i := i'+1;
                        });

                make_heap ((nnn+1) / 2);

                vec::keyed_apply
                    (\\ (i, x) =  vec::set (pos, x, i))
                    heap;

                PQ { less, heap, pos, size => REF nnn }; 

            };                  # fun from_graph
    };
end;