with Ada.Unchecked_Deallocation;
--with Ada.Text_IO;
--use Ada.Text_IO;
with GPL;
---------------------------------------------------------------------------=--
-- Copyright (C) 2000 Chad R. Meiners <crmeiners@hotmail.com> --
-- <v025@truman.edu> --
-- --
-- This package is free software; See the package GPL for further details --
------------------------------------------------------------------------------
package body Miams.Libraries.Segmented.Arrays is
procedure Initialize(Item : in out Object) is
begin
Set(Item,(Index'First,Index'Last),Default_Value);
Item.Empty := True;
end Initialize;
procedure Finalize (Item : in out Object) is
begin
if not Item.Empty then
Set(Item,(Index'First,Index'Last),Default_Value);
Item.Empty := True;
end if;
end Finalize;
function Width(Item : Depth_Index) return Index;
Strip_Choice : constant Natural := 32 - Partition_Bit_Size;
function Allocate return Node_Ptr is
begin
return new Node;
end Allocate;
procedure Deallocate is new Ada.Unchecked_Deallocation(Node,Node_Ptr);
procedure Get(From : in Object;
Where : in Index;
Item : out Element) is
begin
if From.Empty then
Item := Default_Value;
return ;
end if;
if Where in From.Contains.Min..From.Contains.Max then
-- Where is inside the range covered by the head.
declare
Current_Node : Node_Value := From.Tree; -- Get the Head of the tree
Location_Bits : Index := Shift_Left(Where,Natural(From.Depth) * Partition_Bit_Size);
Choice : Child_Index;
begin
loop
if Current_Node.Kind = Value then
Item := Current_Node.Data;
return ; -- Found the value in the tree
elsif Current_Node.Ptr = null then
Item := Default_Value;
return ; -- Could not find the value in the tree
else
Choice := Shift_Right(Location_Bits,Strip_Choice);
Location_Bits := Shift_Left (Location_Bits,Partition_Bit_Size);
Current_Node := Current_Node.Ptr.Child(Choice);
-- Value is not at this depth so code must dive deeper
-- into the structure.
end if;
end loop;
end;
else
-- Where is not inside the the range covered by the head..
Item := Default_Value;
return ;
end if;
end Get;
pragma Inline(Get);
procedure Set(To : in out Object;
Where : in Index;
Item : in Element) is
begin
Set(To,(Where,Where),Item);
end Set;
pragma Inline(Set);
procedure Depth_Calculations(Where : in Location; Depth : out Depth_Index; Mask : out Index) is
-- Calulates the highest node depth that can contain both min and max.
Temp : Index := not ( Where.Min xor Where.Max); -- Bit field of alike aligned bits
Check : Index := Shift_Right (Index'Last, 1);
--Shift : Integer := 32;
--Field : Natural;
Shifts : Natural := 0;
begin
-- Finding the location of the first zero bit
while (Shifts < 32 ) and then Temp <= Check loop
Temp := Shift_Left(Temp,1);
Shifts := Shifts + 1;
end loop;
Depth := Depth_Index (Shifts / Partition_Bit_Size); -- Setting the depth.
Mask := Where.Min and Shift_Left( Index'Last, Index'Size - (Natural (Depth) * Partition_Bit_Size) );
end Depth_Calculations;
pragma Inline(Depth_Calculations);
procedure Adjust_Tree(Item : in out Object; Where : Location) is
-- Makes sure that the tree is tall enough for Where to fit inside of it.
begin
if Where.Min < Item.Contains.Min or else Where.Max > Item.Contains.Max then
-- Where is not in the range of the the tree
-- so the tree needs adjusting.
declare
Current_Node : Node_Value := Item.Tree;
Current_Choice : Child_Index := Shift_Right(
Shift_Left( Item.Mask,
Partition_Bit_Size *
Natural(Item.Depth - 1) ),
32-Partition_Bit_Size);
Loop_Counter : Child_Index := Child_Index'First;
begin
-- Raise the tree one level by allocating a new tree node
-- and set the old tree node properly within its childern.
Item.Tree := (Dereference,Allocate);
while Loop_Counter /= Current_Choice loop
Item.Tree.Ptr.Child(Loop_Counter) := Null_Child;
Loop_Counter := Loop_Counter + 1;
end loop;
Item.Tree.Ptr.Child(Loop_Counter) := Current_Node;
while Loop_Counter < Child_Index'Last loop
Loop_Counter := Loop_Counter + 1;
Item.Tree.Ptr.Child(Loop_Counter) := Null_Child;
end loop;
end;
declare
Temp : Natural;
begin
-- Raise the head's depth since it was just raised.
Item.Depth := Item.Depth - 1;
-- Clean up Mask
-- May not be necessary.
Temp := Natural(Item.Depth) * Partition_Bit_Size;
Item.Mask := Shift_Left(Shift_Right(Item.Mask,Temp),Temp);
Item.Contains := (Min => Item.Mask, Max => Item.Mask + Width(Item.Depth));
-- Warning Possible bit-cleansing code atrocities in the above code.
-- Nope. This step is necessary.
end;
--Check if location is in range.
Adjust_Tree(Item,Where);
else
-- Tree does not need adjusting since where is within the
-- head's range.
null;
end if;
end Adjust_Tree;
pragma Inline(Adjust_Tree);
function Width(Item : Depth_Index) return Index is
-- returns the 'real' width of a depth
Full : constant Index := Index'Last;
begin
return Shift_Right(Full, Natural(Item) * Partition_Bit_Size);
end Width;
pragma Inline(Width);
procedure Decend(Mask : in out Index;
Depth : in out Depth_Index;
Child : in Child_Index) is
-- Depth := Depth + 1.
-- Mask is adjusted to reflect this.
function Modifier(Depth : Depth_Index; Child : Child_Index) return Index is
Temp : constant Index := Shift_Left(Index(Child), 32 - Partition_Bit_Size);
-- Temp is now defined for depth 1.
begin
if Depth = 0 then
return 0; -- This is a silent failure since the
-- function is undefined for depth 0.
end if;
return Shift_Right(Temp, Natural(Depth-1) * Partition_Bit_Size);
end Modifier;
pragma Inline(Modifier);
procedure Clease_Mask(Mask : in out Index;
Depth : in Depth_Index) is
Shift_Amount : constant Natural := Natural(Depth_Index'Last - Depth)
* Partition_Bit_Size;
begin
Mask := Shift_Left(Shift_Right(Mask,Shift_Amount),Shift_Amount);
end Clease_Mask;
pragma Inline(Clease_Mask);
begin
if Depth /= Depth_Index'Last then -- if you can't decend then don't
Clease_Mask(Mask,Depth);
Depth := Depth + 1;
Mask := Mask or Modifier(Depth, Child);
end if;
end Decend;
function Mask_To_Location(Mask : in Index;
Depth : in Depth_Index)
return Location is
Shift_Amount : constant Natural := Natural(Depth)
* Partition_Bit_Size;
Max_Mask : constant Index := Shift_Right(Index'Last, Shift_Amount);
begin
return Location'( Min => Mask,
Max => Mask or Max_Mask);
end Mask_To_Location;
pragma Inline(Mask_To_Location);
procedure Write(Item : in out Node_Value;
Data : in Element;
Bitmask : in Index;
Depth : in Depth_Index) is
-- Performs a write that deallocates (deletes) any
-- nodes that would be overwritten.
procedure Delete(Item : in out Node_Ptr;
Data : in Element;
Bitmask : in Index;
Depth : in Depth_Index) is
-- This recursive decent procedure deletes all the childern
-- of Item and then Item.
begin
for I in Child_Index loop
declare
New_Mask : Index := Bitmask;
New_Depth : Depth_Index := Depth;
begin
Decend(Mask => New_Mask,
Depth => New_Depth,
Child => I);
if Item.Child(I).Kind = Dereference and then Item.Child(I).Ptr /= null then
Delete(Item.Child(I).Ptr,
Data,
New_mask,
New_Depth);
else
begin
if Item.Child(I).Kind = Value and then Item.Child(I).Data /= Data then
Deallocation_Notification( Mask_To_Location(Mask => New_Mask,
Depth => New_Depth),
Item.Child(I).Data,
Data
);
end if;
exception
when others => -- Notification is not vital.
null; -- Ignores any exceptions raised
-- so that the tree structure is not
-- corrupted.
end;
end if;
end;
end loop;
Deallocate(Item);
end Delete;
begin
if Item.Kind = Value then
if Item.Data /= Data then
begin
Deallocation_Notification( Mask_To_Location(Mask => Bitmask,
Depth => Depth),
Item.Data,
Data);
exception
when others => -- Notification is not vital.
null; -- Ignores any exceptions raised
-- so that the tree structure is not
-- corrupted.
end;
end if;
Item.Data := Data;
elsif Item.ptr = null then
Item := (Kind => Value, Data => Data);
else
Delete(Item.Ptr,
Data,
Bitmask,
Depth);
Item := (Kind => Value, Data => Data);
end if;
-- exception
-- when others =>
-- Put_Line ("In Write.");
-- raise;
end Write;
pragma Inline(Write);
procedure Expand(From : in out Node_Value) is
-- Guaruntees that From is a pointer to a node containing childern.
-- Preserves all semantics values.
Temp : Node_Value;
begin
if From.Kind = Value then
Temp := (Kind => Dereference, Ptr => Allocate);
Temp.Ptr.Child := (others => From);
From := Temp;
elsif From.Ptr = null then
From.Ptr := Allocate;
From.Ptr.Child := (others => Null_Child);
end if;
end Expand;
pragma Inline(Expand);
procedure Compress(Parent : in out Node_Value; Child : in out Node;
Bitmask : in Index; Depth : in Depth_Index) is
Test : Node_Value := Child.Child(Node_Array'First);
begin
if Test.Kind = Value then
for I in (Node_Array'First + 1)..(Node_Array'Last) loop
if Test /= Child.Child(I) then
return;
end if;
end loop;
Write(Parent,Test.Data,Bitmask,Depth);
end if;
end Compress;
pragma Inline(Compress);
procedure Set(To : in out Object;
Where : in Location;
Item : in Element) is
begin
if To.Empty then -- Create the tree
-- Depth_Calculations(Where,To.Depth,To.Mask);
-- To.Contains := (To.Mask,To.Mask + Width(To.Depth));
To.Depth := 0;
To.Mask := 0;
To.Contains := (Index'First,Index'Last);
To.Empty := False;
end if;
Adjust_Tree(To,Where);
declare
--At_Head : Boolean := True;
Current_Node : Node_ptr ;
Current_Child : Child_Index := 0;
Current_Depth : Depth_Index := To.Depth;
Bitmask : Index := To.Mask;
Parent_Node : Node_Ptr ;
Parent_Child : Child_Index := 0;
Parent_Head : Boolean ;
Temp_bits : Natural := Partition_Bit_Size * Natural(To.Depth);
Min_bits : Index := Shift_Left(Where.Min,Temp_bits);
Max_Bits : Index := Shift_Left(Where.Max,Temp_bits);
Temp_Choice : constant Natural := 32 - Partition_Bit_Size;
Min_Choice : Child_Index := Shift_Right(Min_Bits,Temp_Choice);
Max_Choice : Child_Index := Shift_Right(Max_Bits,Temp_Choice);
Middle_Choice : Child_Index ;
Min_Remainder : Index ;
Max_Remainder : Index ;
-- Far_Remainder is set to all one's and then shifted so that
-- it can be meaningfully compared to Max_Remainder
Far_Remainder : Index := Shift_Left(Index'Last,Temp_Bits);
Mod_Debug : Character := '0';
begin
--Put_Line(Index'Image(Current_Depth) & Index'Image(Bitmask));
-- Operate on the root
if Min_bits = Index'First and then Max_Bits = Far_Remainder then
Write(To.Tree, Item,Bitmask,Current_Depth);
return;
else
Expand(To.Tree);
-- Set up the Parent node
Parent_Node := To.Tree.ptr; --ignore this value.
Parent_Head := True;
-- Set up the current node.
Current_Node := To.Tree.Ptr;
end if;
while (Min_Choice = Max_Choice) loop
Current_Child := Min_Choice;
Decend( Mask => Bitmask,
Depth => Current_Depth,
Child => Current_Child);
Min_Remainder := Shift_Left(Min_Bits,Partition_Bit_Size);
Max_Remainder := Shift_Left(Max_Bits,Partition_Bit_Size);
Far_Remainder := Shift_Left(Far_Remainder,Partition_Bit_Size);
Temp_Bits := Temp_Bits + Partition_Bit_Size;
if Min_Remainder = Index'First and then Max_Remainder = Far_Remainder then
-- Range is a perfect fit for this segment
Write(Current_Node.Child(Current_Child),Item,Bitmask,Current_Depth);
-- Compress tree.
if Parent_Head then
Compress(To.Tree,Current_Node.all,Bitmask,Current_Depth);
else
Compress(Parent_Node.Child(Parent_Child),Current_Node.all,Bitmask,Current_Depth);
end if;
return; -- All done.
end if;
-- Range is inside the range so decend.
Expand(Current_Node.Child(Current_Child));
-- Update parent pointer
Parent_Node := Current_Node;
Parent_Child := Current_Child;
Parent_Head := False;
-- Update Current pointer
Current_Node := Current_Node.Child(Current_Child).Ptr;
-- Promote Remainders to bits remaining.
Min_Bits := Min_Remainder;
Max_Bits := Max_Remainder;
-- Find the childern from the bits remaining.
Min_Choice := Shift_Right(Min_Bits,Temp_Choice);
Max_Choice := Shift_Right(Max_Bits,Temp_Choice);
end loop;
-- Current_Mask is correct upon leaving this loop
-- Current_Depth is correct upon leaving this loop
Middle_Choice := Min_Choice + 1;
-- handle the left side
declare
C_Bitmask : Index := Bitmask;
C_Depth : Child_Index := Current_Depth;
T_Bitmask : Index ;
T_Depth : Child_Index ;
T_Flag : Boolean := true;
The_Node : Node_Ptr := Current_Node;
Remainder : Index := Shift_Left(Min_Bits,Partition_Bit_Size);
Choice : Child_Index := Min_Choice;
Bits : Index := Min_Bits;
Parent : Node_Ptr := Parent_Node;
PChoice : Child_Index := Parent_Child;
begin
--C_Bitmask :=Bitmask or Modifier(Child => Min_Choice,Depth => Current_Depth);
while Remainder /= Index'First loop
Expand(The_Node.Child(Choice));
-- Depth and Bitmask must go down the tree
if T_Flag then
Decend( Mask => C_Bitmask,
Depth => C_Depth,
Child => Choice);
else
T_Flag := True; -- This is to properly stagger the depth.
end if;
-- Adjust Parent
Parent := The_Node;
PChoice := Choice;
-- Adjust current
The_Node := The_Node.Child(Choice).Ptr;
Choice := Shift_Right(Remainder,Temp_Choice);
-- Fill all childern to the right.
if Choice /= Child_Index'Last then
for Index_Bar in (Choice+1)..Child_Index'Last loop
-- Adjust depth for the current node being written
T_Bitmask := C_Bitmask;
T_Depth := C_Depth;
Decend( Mask => T_Bitmask,
Depth => T_Depth,
Child => Index_Bar);
Write(The_Node.Child(Index_Bar),
Item,
T_Bitmask,
T_Depth);
end loop;
end if;
Bits := Remainder;
Remainder := Shift_Left(Bits,Partition_Bit_Size);
end loop;
T_Bitmask := C_Bitmask;
T_Depth := C_Depth;
Decend( Mask => T_Bitmask,
Depth => T_Depth,
Child => Choice);
Write(The_Node.Child(Choice),
Item,
T_Bitmask,
T_Depth);
Compress(Parent.Child(Choice),
The_Node.all,
T_Bitmask,
T_Depth);
end;
-- handle the middle
while Middle_Choice < Max_Choice loop
declare
T_Bitmask : Index := Bitmask;
T_Depth : Index := Current_Depth;
begin
Decend( Mask => T_Bitmask,
Depth => T_Depth,
Child => Middle_Choice);
Write(Current_Node.Child(Middle_Choice),
Item,
T_Bitmask,
T_Depth);
Middle_Choice := Middle_Choice + 1;
end;
end loop;
-- handle the right
declare
C_Bitmask : Index := Bitmask;
C_Depth : Child_Index := Current_Depth;
T_Bitmask : Index ;
T_Depth : Child_Index ;
T_Flag : Boolean := True;
The_Node : Node_Ptr := Current_Node;
Remainder : Index := Shift_Left(Max_Bits,Partition_Bit_Size);
Choice : Child_Index := Max_Choice;
Bits : Index := Max_Bits;
Complete : Index := Shift_Left(Far_Remainder,Partition_Bit_Size);
Parent : Node_Ptr := Parent_Node;
PChoice : Child_Index := Parent_Child;
begin
while Remainder /= Complete loop
Expand(The_Node.Child(Choice));
-- Depth and Bitmask must go down the tree
if T_Flag then
Decend( Mask => C_Bitmask,
Depth => C_Depth,
Child => Choice);
else
T_Flag := True; -- This is to properly stagger the depth.
end if;
-- Adjust Parent
Parent := The_Node;
PChoice := Choice;
-- Adjust current
The_Node := The_Node.Child(Choice).Ptr;
Choice := Shift_Right(Remainder,Temp_Choice);
-- Fill all childern to the left
if Choice /= Child_Index'First then
for Index_Bar in Child_Index'First..(Choice - 1) loop
-- Adjust depth for the current node being written
T_Bitmask := C_Bitmask;
T_Depth := C_Depth;
Decend( Mask => T_Bitmask,
Depth => T_Depth,
Child => Index_Bar);
Write(The_Node.Child(Index_Bar),
Item,
T_Bitmask,
T_Depth);
end loop;
end if;
Bits := Remainder;
Remainder := Shift_Left(Bits,Partition_Bit_Size);
Complete := Shift_Left(Complete,Partition_Bit_Size);
end loop;
T_Bitmask := C_Bitmask;
T_Depth := C_Depth;
Decend( Mask => T_Bitmask,
Depth => T_Depth,
Child => Choice);
Write(The_Node.Child(Choice),
Item,
T_Bitmask,
T_Depth);
Compress(Parent.Child(Choice),
The_Node.all,
T_Bitmask,
T_Depth);
end;
end;
end Set;
pragma Inline(Set);
end Miams.Libraries.Segmented.Arrays;
