Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/Libraries/DBL Pascal Library/Queues/PriorityQueue

Text File | 1993-03-29 | 4.5 KB | 162 lines | [TEXT/PJMM]

unit PriorityQueue;

{This unit implements a priority queue. This is cribbed from "Data Structures and}
{Algorithms", Aho, Hopcroft, and Ullman, Addison-Wesley, 1983 (corrected 1987 edition).}

interface

    type
        PriorityQueueItem = record
                data: Longint;
                priority: Longint;
            end;
        PriorityQueue = record
                Qsize, Qlast: Integer;
                Qelts: array[1..1] of PriorityQueueItem;
            end;
        PriorityQueuePtr = ^PriorityQueue;
        PriorityQueueHandle = ^PriorityQueuePtr;

    procedure NewPriorityQueue (itsSize: Integer;
                                    var theQueue: PriorityQueueHandle);
    procedure DisposePriorityQueue (theQueue: PriorityQueueHandle);
    procedure FlushPriorityQueue (theQueue: PriorityQueueHandle);

    function PriorityQueueFull (theQueue: PriorityQueueHandle): Boolean;
    function PriorityQueueEmpty (theQueue: PriorityQueueHandle): Boolean;

    procedure PriorityQueueInsert (item: univ Longint;
                                    itemPriority: Longint;
                                    theQueue: PriorityQueueHandle);
    procedure PriorityQueueDeleteMin (var item: univ Longint;
                                    var itemPriority: Longint;
                                    theQueue: PriorityQueueHandle);


implementation

{Array implementation of priority queue implements balanced tree as a heap (not to be}
{confused with the Mac's memory space). If we call array A, the root of the tree is at}
{A[1], and for i > 1, the parent of A[i] is A[i div 2]. The priority of a given node is no}
{greater than the priority of both its children.}

{Using a heap rather than a real tree costs us a slight overhead in integer multiplication}
{and division, but saves us a lot of time in creating and deleting nodes. The complexity}
{is O(log n) regardless of representation.}

    procedure FlushPriorityQueue (theQueue: PriorityQueueHandle);
    begin
        theQueue^^.Qlast := 0;
    end;

    procedure NewPriorityQueue (itsSize: Integer;
                                    var theQueue: PriorityQueueHandle);
    begin
        theQueue := PriorityQueueHandle(NewHandle(SIZEOF(PriorityQueue) + (itsSize - 1) * SIZEOF(PriorityQueueItem)));
        theQueue^^.Qsize := itsSize;
        FlushPriorityQueue(theQueue);
    end;

    procedure DisposePriorityQueue (theQueue: PriorityQueueHandle);
    begin
        DisposHandle(Handle(theQueue));
    end;

    function PriorityQueueFull (theQueue: PriorityQueueHandle): Boolean;
    begin
        with theQueue^^ do
            PriorityQueueFull := Qlast = Qsize;
    end;

    function PriorityQueueEmpty (theQueue: PriorityQueueHandle): Boolean;
    begin
        PriorityQueueEmpty := theQueue^^.Qlast = 0;
    end;

    procedure Swap (var a, b: PriorityQueueItem);
        var
            temp: PriorityQueueItem;
    begin
        temp := a;
        a := b;
        b := temp;
    end;

    procedure PriorityQueueInsert (item: univ Longint;
                                    itemPriority: Longint;
                                    theQueue: PriorityQueueHandle);

        var
            i: Integer;
    begin
        if not PriorityQueueFull(theQueue) then
            with theQueue^^ do
                begin
                    Qlast := Qlast + 1;
{$PUSH}
{$R-}
                    with Qelts[Qlast] do    {start with new element at bottom left of tree}
{$POP}
                        begin
                            data := item;
                            priority := itemPriority;
                        end;
                    i := Qlast;
{$PUSH}
{$R-}
                    while (i > 1) & (Qelts[i].priority < Qelts[i div 2].priority) do
                        begin    {repeatedly swap the new element with its parent to maintain the invariant}
                            Swap(Qelts[i], Qelts[i div 2]);
                            i := i div 2;
                        end;
{$POP}
                end;
    end;

    procedure PriorityQueueDeleteMin (var item: univ Longint;
                                    var itemPriority: Longint;
                                    theQueue: PriorityQueueHandle);
        var
            i, j: Integer;
            min: PriorityQueueItem;
    begin
        if not PriorityQueueEmpty(theQueue) then
            with theQueue^^ do
                begin
                    with Qelts[1] do {the easy part - minimum is in a known place}
                        begin
                            item := data;
                            itemPriority := priority;
                        end;
{$PUSH}
{$R-}
                    Qelts[1] := Qelts[Qlast]; {replace the root with the bottom left element}
{$POP}
                    Qlast := Qlast - 1;
                    i := 1; {the old last element is in the wrong place now, so let's track it}
                    while i <= Qlast div 2 do
                        begin {push the old last element down the tree to its proper place}
{$PUSH}
{$R-}
                            if (Qelts[2 * i].priority < Qelts[2 * i + 1].priority) or (2 * i = Qlast) then
{$POP}
                                j := 2 * i
                            else
                                j := 2 * i + 1;
                        {j is either the child of i having the lower priority,}
                        {or is last and the only child of i}
{$PUSH}
{$R-}
                            if Qelts[i].priority > Qelts[j].priority then
                                begin {swap old last element with its lower priority child…}
                                    Swap(Qelts[i], Qelts[j]);
                                    i := j;
                                end
                            else
                                Leave; {…or, leave if the priority is now correct}
{$POP}
                        end;
                end;
    end;

end.