-- $Date: 2003/12/28 07:08:46 $
-- $Revision: 1.7 $
-- $Author: jcrocholl $

with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada;

package body Heaps is

   -----------------------
   -- Heap size management
   -----------------------

   -- Release memory for a heap.
   procedure Free is
     new Ada.Unchecked_Deallocation(Heap_Record, Heap);

   -- Explicitly empty a heap and release associated memory.
   procedure Deallocate
     (This : in out Heap) is -- Empty this heap.
   begin
      Free(This);
      This := null;
   end Deallocate;

   -- Grow or shrink a heap. If the new size is smaller than the
   -- number of items in the heap, some items will be cut off at the
   -- end without warning.
   procedure Resize
     (This     : in out Heap-- Resize this heap.
      New_Size : in Positive-- New size of the heap.
   is
      New_Heap : Heap;
   begin
      New_Heap := new Heap_Record(New_Size);

      if This = null
      then New_Heap.Count := 0;
      else New_Heap.Count := This.Count;
      end if;

      if New_Heap.Count > New_Heap.Size then
         New_Heap.Count := New_Heap.Size;
      end if;

      for Index in 1 .. New_Heap.Count loop
         New_Heap.Items(Index) := This.Items(Index);
      end loop;

      Free(This);
      This := New_Heap;
   end Resize;

   -- Increase the size of a heap.
   procedure Grow
     (This : in out Heap) is -- Grow this heap.
   begin
      if This = null
      then Resize(This, 8);
      else Resize(This, 2 * This.Size);
      end if;
   end Grow;

   --------------------
   -- State information
   --------------------

   -- How many items in the heap?
   function Count
     (This : in Heap)  -- Read count from this heap.
     return Natural is -- Item count of this heap.
   begin
      if This = null
      then return 0;
      else return This.Count;
      end if;
   end Count;

   -- Print the heap's contents.
   procedure Debug
     (This : in Heap) is -- Debug this heap.
   begin
      if This = null then
         Text_IO.Put_Line("null");
      else
         for Index in 1 .. This.Count loop
            if Index > 1 then Text_IO.Put(','); end if;
            Text_IO.Put(To_String(This.Items(Index)));
         end loop;
         Text_IO.New_Line;
      end if;
   end Debug;

   ----------------------
   -- Writing and reading
   ----------------------

   procedure Swap
     (This : in Heap;
      A, B : in Positive)
   is
      Temp : Content_Type;
   begin
      Temp := This.Items(A);
      This.Items(A) := This.Items(B);
      This.Items(B) := Temp;
   end Swap;

   -- Raise the last item to restore the heap property.
   procedure Rise
     (This  : in Heap;     -- Restore this heap.
      Index : in Positive-- Raise this item.
   is
      Compare : Positive;
   begin
      -- pragma Debug(Text_IO.Put("Rise" & Positive'Image(Index) & ":"));
      -- pragma Debug(Debug(This));
      if Index = 1 then return; end if;
      Compare := Index / 2;
      if This.Items(Index) < This.Items(Compare) then
         Swap(This, Compare, Index);
         Rise(This, Compare);
      end if;
   end Rise;

   -- Insert an item into the heap.
   procedure Insert
     (This : in out Heap;     -- Insert into this heap.
      Item : in Content_Type-- The item to insert.
   is
   begin
      if This = null or else This.Count = This.Size then
         Grow(This);
      end if;
      This.Count := This.Count + 1;
      This.Items(This.Count) := Item;
      Rise(This, This.Count);
   end Insert;

   -- Lower the first item to restore the heap property.
   procedure Sink
     (This  : in Heap;     -- Restore this heap.
      Index : in Positive-- Sink this item.
   is
      Compare : Positive := Index * 2;
   begin
      -- pragma Debug(Text_IO.Put("Sink" & Positive'Image(Index) & ":"));
      -- pragma Debug(Debug(This));
      if Compare > This.Count then return; end if;
      if This.Items(Compare) < This.Items(Index) then
         if Compare + 1 <= This.Count
           and then This.Items(Compare + 1) < This.Items(Compare)
         then Compare := Compare + 1;
         end if;
         Swap(This, Compare, Index);
         Sink(This, Compare);
         return;
      end if;
      Compare := Compare + 1;
      if Compare > This.Count then return; end if;
      if This.Items(Compare) < This.Items(Index) then
         Swap(This, Compare, Index);
         Sink(This, Compare);
      end if;
   end Sink;

   -- Extract the lightest item from the heap.
   function Extract
     (This : in Heap)    -- Extract from this heap.
     return Content_Type -- The lightest item.
   is
      Result : Content_Type := This.Items(1);
   begin
      This.Items(1) := This.Items(This.Count);
      This.Count := This.Count - 1;
      Sink(This, 1);
      return Result;
   end Extract;

end Heaps;