Jan 11 16:18 1996  binary_heap.ads Page 1


-- Generic Package Specification for Binary_Heap
--     Implements a priority queue
-- Requires:
--     Instantiated with any private type and
--     ">" function defined for that type and
--     a value of negative infinity for that type
-- Types defined:
--     Priority_Queue( Integer )    limited private type
-- Exceptions defined:
--     Overflow            raised for Insert on a full priority queue
--     Underflow           raised for Delete_Min or Find_Min
--                         on empty priority queue
-- Operations defined:
--     Delete_Min          delete and show minimum element in priority queue
--     Find_Min            return minimum element in priority queue
--     Insert              add a new element to priority queue
--     Is_Empty            returns true if priority queue is empty
--     Is_Full             returns true if priority queue is full
--     Make_Empty          make a priority queue empty

generic
    type Element_Type is private;
    with function ">" ( Left, Right: Element_Type ) return Boolean;
    Min_Element : in Element_Type;
package Binary_Heap is
    type Priority_Queue( Max_Size: Positive ) is limited private;

    procedure Delete_Min ( X: out Element_Type; H: in out Priority_Queue );
    function  Find_Min ( H: Priority_Queue ) return Element_Type;
    procedure Insert ( X: Element_Type; H: in out Priority_Queue );
    function  Is_Empty ( H: Priority_Queue ) return Boolean;
    function  Is_Full  ( H: Priority_Queue ) return Boolean;
    procedure Make_Empty( H: out Priority_Queue );

    Overflow : exception;
    Underflow: exception;

private
    type Array_Of_Element_Type is array( Natural range <> ) of Element_Type;
    type Priority_Queue( Max_Size : Positive ) is
      record
        Size	: Natural := 0;
        Element	: Array_Of_Element_Type( 0..Max_Size ) := ( others => Min_Element );
      end record;

end Binary_Heap;

















Dec  9 14:57 1995  binary_heap.adb Page 1


-- Implementation of Binary_Heap

package body Binary_Heap is

    -- Remove minimum item from Priority_Queue H
    -- Place it in X; raise Item_Not_Found if empty
    procedure Delete_Min( X: out Element_Type; H: in out Priority_Queue ) is
        I, Child     : Integer := 1;
        Last_Element : Element_Type := H.Element( H.Size );
    begin
        if Is_Empty( H ) then
            raise Underflow;
        end if;

        X := H.Element( 1 );
        H.Size := H.Size - 1;

        loop
                -- Find smaller child
            Child := I * 2;
            exit when Child > H.Size;
            if Child /= H.Size and then
                    H.Element( Child ) > H.Element( Child + 1 ) then
                Child := Child + 1;
            end if;

                -- Push down one level if needed
            exit when not ( Last_Element > H.Element( Child ) );
            H.Element( I ) := H.Element( Child );
            I := Child;
        end loop;

        H.Element( I ) := Last_Element;
    end Delete_Min;

    -- Return minimum item in Priority_Queue H
    -- Raise Item_Not_Found if empty
    function Find_Min( H: Priority_Queue ) return Element_Type is
    begin
        if Is_Empty( H ) then
            raise Underflow;
        else
            return H.Element( 1 );
        end if;
    end Find_Min;

    -- Return true if Priority_Queue H is empty, false otherwise
    function Is_Empty( H : Priority_Queue ) return Boolean is
    begin
        return H.Size = 0;
    end Is_Empty;

    -- Return true if Priority_Queue H is full, false otherwise
    function Is_Full( H : Priority_Queue ) return Boolean is
    begin
        return H.Size = H.Element'Last;







Dec  9 14:57 1995  binary_heap.adb Page 2


    end Is_Full;

    -- Insert item X into priority queue H
    -- Uses the fact that H.Element( 0 ) is the sentinel Min_Element 
    -- Raises Over_Flow if already full
    procedure Insert( X: Element_Type; H: in out Priority_Queue ) is
        I: Natural;
    begin
        if Is_Full( H ) then
            raise Overflow;
        end if;

        H.Size := H.Size + 1;
        I := H.Size;

        while H.Element( I/2 ) > X loop
            H.Element( I ) := H.Element( I/2 );
            I := I/2;
        end loop;

        H.Element( I ) := X;
    end Insert;

    -- Make priority queue H empty
    procedure Make_Empty( H: out Priority_Queue ) is
    begin
        H.Size := 0;
    end Make_Empty;

end Binary_Heap;	

































Jan 11 16:18 1996  leftist_heap.ads Page 1


-- Generic Package Specification for Leftist_Heap
--     Implements a mergeable priority queue
-- Requires:
--     Instantiated with any private type and
--     ">" function defined for that type and
-- Types defined:
--     Priority_Queue      limited private type
-- Exceptions defined:
--     Illegal_Merge       Raised on Merge(X,X,Y), Merge( X,Y,Y), etc.
--     Underflow           raised for Delete_Min or Find_Min
--                         on empty priority queue
-- Operations defined:
--     Initialize and Finalize are defined
--     Delete_Min          delete and show minimum element in priority queue
--     Find_Min            return minimum element in priority queue
--     Insert              add a new element to priority queue
--     Is_Empty            returns true if priority queue is empty
--     Make_Empty          make a priority queue empty
--     Merge               combines two priority queues into a third
--                         it destroys the originals

with Ada.Finalization;

generic
    type Element_Type is private;
    with function ">" ( Left, Right: Element_Type ) return Boolean;
package Leftist_Heap is
    type Priority_Queue is new Ada.Finalization.Limited_Controlled with private;

    procedure Initialize( H: in out Priority_Queue );
    procedure Finalize( H: in out Priority_Queue );

    procedure Delete_Min ( X: out Element_Type; H: in out Priority_Queue );
    function Find_Min ( H: Priority_Queue ) return Element_Type;
    procedure Insert ( X: Element_Type; H: in out Priority_Queue );
    function Is_Empty ( H: Priority_Queue ) return Boolean;
    procedure Make_Empty( H: in out Priority_Queue );
    procedure Merge( H1: in out Priority_Queue; H2: in out Priority_Queue;
                     Result: in out Priority_Queue );

    Underflow: exception;
    Illegal_Merge: exception;  -- Raised when aliasing is detected

private
    type Tree_Node;
    type Tree_Ptr is access Tree_Node;

    type Tree_Node is
      record
        Element : Element_Type;
        Left	: Tree_Ptr;
        Right	: Tree_Ptr;
        Npl	: Natural := 0;
      end record;

    type Priority_Queue is new Ada.Finalization.Limited_Controlled with







Jan 11 16:18 1996  leftist_heap.ads Page 2


      record
        Root : Tree_Ptr;
      end record;

end Leftist_Heap;


























































Jan 11 16:19 1996  leftist_heap.adb Page 1


-- Implementation of Leftist_Heap

with Unchecked_Deallocation;
package body Leftist_Heap is

    procedure Initialize( H: in out Priority_Queue ) is
    begin
        null;
    end Initialize;

    procedure Finalize( H: in out Priority_Queue ) is
    begin
        Make_Empty( H );
    end Finalize;

    procedure Dispose is new Unchecked_Deallocation( Tree_Node, Tree_Ptr );
    function Merge( H1, H2: Tree_Ptr ) return Tree_Ptr;
    function Merge1( H1, H2: Tree_Ptr ) return Tree_Ptr;
    procedure Swap( A, B: in out Tree_Ptr );

    -- VISIBLE ROUTINES

    -- Remove minimum item from Priority_Queue H
    -- Place it in X; raise Underflow if H was empty
    procedure Delete_Min( X: out Element_Type; H: in out Priority_Queue ) is
        Left_Heap, Right_Heap : Tree_Ptr;
    begin
        if Is_Empty( H ) then
            raise Underflow;
        end if;

        X := H.Root.Element;
        Left_Heap := H.Root.Left;
        Right_Heap := H.Root.Right;
        Dispose( H.Root );
        H.Root := Merge( Left_Heap, Right_Heap );
    end Delete_Min;

    -- Return minimum item in Priority_Queue H
    -- Raise Underflow if H was empty
    function Find_Min( H: Priority_Queue ) return Element_Type is
    begin
        if Is_Empty( H ) then
            raise Underflow;
        end if;

        return H.Root.Element;
    end Find_Min;

    -- Insert new item X into Priority_Queue H
    procedure Insert( X: Element_Type; H: in out Priority_Queue ) is
    begin
        H.Root := Merge( new Tree_Node'( X, null, null, 0 ), H.Root );
    end Insert;

    -- Return true if Priority_Queue H is empty, false otherwise







Jan 11 16:19 1996  leftist_heap.adb Page 2


    function Is_Empty( H : Priority_Queue ) return Boolean is
    begin
        return H.Root = null;
    end Is_Empty;

    -- Make Priority_Queue H empty, and dispose nodes
    -- Calls hidden recursive routine
    procedure Make_Empty( H: in out Priority_Queue ) is
        procedure Make_Empty( T: in out Tree_Ptr ) is
        begin
            if T /= null then
                Make_Empty( T.Left );
                Make_Empty( T.Right );
                Dispose( T );
            end if;
        end Make_Empty;
    begin
        Make_Empty( H.Root );
    end Make_Empty;

    -- Merge two Priority_Queues H1 and H2 into Result
    -- H1 and H2 are set to be empty after the Merge
    -- Former items in Result are reclaimed
    -- Aliasing tests are performed to make sure all
    -- three Priority_Queue objects are distinct.
    -- Note that this test will also disallow a
    -- Merge in which two of the three objects are empty
    procedure Merge( H1: in out Priority_Queue;
                     H2: in out Priority_Queue;
                 Result: in out Priority_Queue ) is
    begin
        if H1.Root = H2.Root or else H1.Root = Result.Root or else
                                     H2.Root = Result.Root then
            raise Illegal_Merge;
        else
            Make_Empty( Result );
            Result.Root := Merge( H1.Root, H2.Root );
            H1.Root := null;
            H2.Root := null;
        end if;
    end Merge;
	
    -- PRIVATE routines that do most of the work

    -- Return the result of merging two leftist heaps rooted at
    -- H1 and H2. H1 has smaller root, H1 and H2 are not null 
    function Merge1( H1, H2: Tree_Ptr ) return Tree_Ptr is
    begin
        if H1.Left = null then	-- Single node.  other fields 
            H1.Left := H2;	-- Already correctly set 
        else
            H1.Right := Merge( H1.Right, H2 );
            if H1.Left.Npl < H1.Right.Npl then
                Swap( H1.Left, H1.Right );
            end if;








Jan 11 16:19 1996  leftist_heap.adb Page 3


            H1.Npl := H1.Right.Npl + 1;
        end if;

        return H1;
    end Merge1;

    -- Return the result of merging two leftist heaps rooted at
    -- H1 and H2. Calls Merge1 after handling degenerate cases
    -- and ensuring that H1 has smaller root
    function Merge( H1, H2: Tree_Ptr ) return Tree_Ptr is
    begin
        if H1 = null then
            return H2;
        elsif H2 = null then
            return H1;
        elsif H2.Element > H1.Element then
            return Merge1( H1, H2 );
        else
            return Merge1( H2, H1 );
        end if;
    end Merge;

    -- Swap two pointers
    procedure Swap( A, B: in out Tree_Ptr ) is
        Tmp : Tree_Ptr := A;
    begin
        A := B;
        B := Tmp;
    end Swap;

end Leftist_Heap;	
































Dec  9 15:30 1995  priority_queue_test.adb Page 1


-- Minimal test program for Priority Queues
-- Binary_Heap instantiation requires a third parameter for the Sentinel
-- Binary_Heap.Priority_Queue may have a discriminant that specifies capacity

with Leftist_Heap;
with Ada.Text_IO, Ada.Integer_Text_IO;
use  Ada.Text_IO, Ada.Integer_Text_IO;

procedure Priority_Queue_Test is
    package Heap is new Leftist_Heap( Integer, ">" ); use Heap;
    Queue_Of_Integers: Priority_Queue;
    Top_E : Integer;
    J : Integer := 1;
begin
    for Loop_Counter in reverse 1..10_000 loop
     Insert( Loop_Counter, Queue_Of_Integers );
    end loop;

    while not Is_Empty( Queue_Of_Integers ) loop
        Delete_Min( Top_E, Queue_Of_Integers );
        if Top_E /= J then
            Put_Line( "Oops!!" );
        end if;
        J := J + 1;
    end loop;
    Delete_Min( Top_E, Queue_Of_Integers );

exception
    when Underflow => Put_Line( "Underflow" );
end Priority_Queue_Test;