From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me
X-Spam-Level: 
X-Spam-Status: No, score=-0.8 required=5.0 tests=BAYES_00,INVALID_DATE
	autolearn=no autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,43d7d94ae0906b7d
X-Google-Attributes: gid103376,public
X-Google-ArrivalTime: 1994-11-14 19:44:26 PST
Newsgroups: comp.lang.ada
Path: 
 nntp.gmd.de!xlink.net!howland.reston.ans.net!math.ohio-state.edu!uwm.edu!news.alpha.net!news.mathworks.com!noc.near.net!inmet!spock!stt
From: stt@spock.camb.inmet.com (Tucker Taft)
Subject: Re: binary heap
Message-ID: <CzA7FF.K7s@inmet.camb.inmet.com>
Sender: news@inmet.camb.inmet.com
Organization: Intermetrics, Inc.
References: <39qese$kcm@columbia.acc.brad.ac.uk>
Date: Mon, 14 Nov 1994 23:47:39 GMT
Date: 1994-11-14T23:47:39+00:00
List-Id: <comp.lang.ada>

In article <39qese$kcm@columbia.acc.brad.ac.uk>,
JC <J.Coates@bradford.ac.uk> wrote:

>I am looking for a fully working priority queue bibary heap package
>including functions find_min and is_empty etc , any help would be great so I
>can implement a program i am writing to emulate priority interupts. Cheers.
>
>
>                                                     JC

Here is some Ada 83 code for a binary heap used to implement a priority 
queue (FIFO within priority); this code (or a slight variation of it)
has been used successfully for many years.

Hope you find it useful.
-Tucker Taft   stt@inmet.com
Intermetrics, Inc.
Cambridge, MA  02138

-------------------------------------------------
package Priority_Queue is
  -- Provide a priority queue; greater priority means more urgent.

  -- Copyright (C) 1994 Intermetrics, Inc. Cambridge, MA  02138
  -- May be freely copied so long as this copyright notice is retained

    Min_Prio : constant := 0;
    Max_Prio : constant := 100;

    type Priority is range Min_Prio .. Max_Prio;

    type Queue_Entry_Record;
    type Queue_Entry is access Queue_Entry_Record;

    type Queue_Entry_Record is
      record
        Prio : Priority;
	Next : Queue_Entry;
        Other_Info : Integer; -- Or whatever
      end record;

    procedure Add_Entry(Ent : Queue_Entry);
      -- Add Ent to priority queue

    procedure Remove_Top_Prio(Ent : out Queue_Entry);
      -- Remove and return an entry with the highest priority
      -- Ent set to null if queue is empty.

    function Top_Prio return Queue_Entry;
      -- Return pointer to entry with highest priority (leave in queue)
      -- Returns null if queue is empty.

    function Is_Empty return Boolean;
      -- Return True if queue is empty
end Priority_Queue;

package body Priority_Queue is
  -- Implement a priority queue; greater priority means more urgent.
  -- Internal representation is a binary heap, 
  -- plus an array of FIFO queues.

  -- Copyright (C) 1994 Intermetrics, Inc. Cambridge, MA  02138
  -- May be freely copied so long as this copyright notice is retained

    type FIFO_Queue_Header is
      record
        First, Last : Queue_Entry := null;
      end record;
    FIFO_Queues : array(Priority) of FIFO_Queue_Header;
      -- Array of singly-linked FIFO queues

    Num_Prio : constant := Max_Prio - Min_Prio + 1;
    type Heap_Count is range 0 .. Num_Prio;
    subtype Heap_Index is Heap_Count range 1 .. Num_Prio;

    Heap : array(Heap_Index) of Priority := (Heap_Index => Min_Prio);
      -- Heap of priority values, Heap(Heap'First) is highest priority
      -- with non-empty FIFO queue;
      -- Heap preinitialized to Min_Prio to simplify removal.

    -- Binary heap condition is: Heap(N) > Max(Heap(2*N), Heap(2*N+1))
    Num_In_Heap : Heap_Count := 0;  -- Count of number in heap

    procedure Add_Entry(Ent : Queue_Entry) is
      -- Add Ent to priority queue

      -- Algorithm:
      --   Add new entry to its FIFO queue.  If its FIFO queue was empty,
      --   add its priority to bottom of heap, and then "sift" it up
      --   until binary heap condition is restored.

	Parent, Child : Heap_Index;
	Prio_To_Add : constant Priority := Ent.Prio;
	FIFO_Queue : FIFO_Queue_Header renames FIFO_Queues(Prio_To_Add);
    begin
	Ent.Next := null;

	if FIFO_Queue.Last /= null then
	    -- There are already elements for this priority;
	    -- Just add to end of its FIFO queue and return.
	    FIFO_Queue.Last.Next := Ent;

	    return;

	end if;

	-- This is a new priority, add to binary heap
	Num_In_Heap := Num_In_Heap + 1;
	    
        -- Start at end of heap
        Child := Num_In_Heap;

	-- Loop until reach top of heap, or parent greater than new prio
	while Child > 1 loop
	    Parent := Child / 2;  -- Find slot which should be greater
	    exit when Heap(Parent) >= Prio_To_Add;
		-- All done if parent now greater

	    -- Parent smaller, move it down to child's slot
	    Heap(Child) := Heap(Parent);

	    -- Advance up to parent slot and iterate
	    Child := Parent;
	end loop;

	-- ASSERT: Prio_To_Add < Heap(Child/2) or reached top-of-heap
	Heap(Child) := Prio_To_Add;
        
	-- Now initialize FIFO queue header to point to new entry
	FIFO_Queue.First := Ent;
	FIFO_Queue.Last := Ent;
      
    end Add_Entry;

    procedure Remove_Top_Prio(Ent : out Queue_Entry) is
      -- Remove and return an entry with the highest priority
      -- Ent set to null if FIFO queue is empty.

      -- Algorithm:
      --   Retrieve highest priority in heap.  Remove first element
      --   from corresponding FIFO queue.  If FIFO queue now empty,
      --   remove corresponding priority from heap, and "sift"
      --   priority at bottom of heap down from top of heap,
      --   until binary heap condition is restored.

	Top_Prio : Priority;
	Prio_To_Sift : Priority;
	Parent, Child : Heap_Index;
	Parent_Limit : Heap_Index;
	Top : Queue_Entry;   -- Temp needed since Ent is "out" param
			     -- (not needed in Ada 9X).
    begin
	if Num_In_Heap = 0 then
	    -- Priority queue is empty
	    Ent := null;
	    return;
	end if;

	Top_Prio := Heap(Heap'First);  -- Get highest priority

	-- Remove first element from appropriate FIFO queue
	Top := FIFO_Queues(Top_Prio).First;
	FIFO_Queues(Top_Prio).First := Top.Next;

	Ent := Top;

	if Top.Next /= null then
	    -- There are more in same FIFO queue, just return now
	    Top.Next := null;
	    return;
	end if;

	-- This is only entry in this FIFO queue, set Last to null
	-- and remove its priority from binary heap
	FIFO_Queues(Top_Prio).Last := null;

	-- Get priority from bottom of heap to sift down
	Prio_To_Sift := Heap(Num_In_Heap);

	-- Replace it with min-prio to allow us to ignore
	-- special case when parent has exactly one child.
	Heap(Num_In_Heap) := Min_Prio;

	-- Shorten the heap
	Num_In_Heap := Num_In_Heap - 1;
	if Num_In_Heap = 0 then

	    -- All done if heap now empty	
	    return;

	end if;

	-- Start at top of heap
	Parent := 1;

	-- Calculate limit on parent (to avoid overflow on
	-- child calculation).
	Parent_Limit := Num_In_Heap / 2;

	-- Loop until reach bottom of heap, 
	-- or prio-to-sift > both children
	while Parent <= Parent_Limit loop

	    -- Determine larger "child"
	    Child := Parent * 2;
	    if Heap(Child + 1) > Heap(Child) then
		-- 2*N+1 child is larger than 2*N child
		Child := Child + 1;
	    end if;

	    exit when Prio_To_Sift >= Heap(Child);
		-- All done when found slot for prio-to-sift

	    -- Move larger child up, and iterate
	    Heap(Parent) := Heap(Child);
	    Parent := Child;
	end loop;

	-- ASSERT: Prio_To_Sift > both children (2*Parent, 2*Parent+1)
	-- or slot has no children

	-- Put prio in its new slot
	Heap(Parent) := Prio_To_Sift;

    end Remove_Top_Prio;
	
    function Top_Prio return Queue_Entry is
      -- Return pointer to entry with highest priority (leave in queue)
      -- Returns null if queue is empty.
    begin
	if Num_In_Heap = 0 then
	    return null;
	else
	    return FIFO_Queues(Heap(Heap'First)).First;
	end if;
    end Top_Prio;

    function Is_Empty return Boolean is
      -- Return true if queue is empty
    begin
	return Num_In_Heap = 0;
    end Is_Empty;

end Priority_Queue;