Hosted by
 |
with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada;
package body Heaps is
procedure Free is
new Ada.Unchecked_Deallocation(Heap_Record, Heap);
procedure Deallocate
(This : in out Heap) is
begin
Free(This);
This := null;
end Deallocate;
procedure Resize
(This : in out Heap;
New_Size : in Positive)
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;
procedure Grow
(This : in out Heap) is
begin
if This = null
then Resize(This, 8);
else Resize(This, 2 * This.Size);
end if;
end Grow;
function Count
(This : in Heap)
return Natural is
begin
if This = null
then return 0;
else return This.Count;
end if;
end Count;
procedure Debug
(This : in Heap) is
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;
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;
procedure Rise
(This : in Heap;
Index : in Positive)
is
Compare : Positive;
begin
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;
procedure Insert
(This : in out Heap;
Item : in Content_Type)
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;
procedure Sink
(This : in Heap;
Index : in Positive)
is
Compare : Positive := Index * 2;
begin
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;
function Extract
(This : in Heap)
return Content_Type
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;
|