-- The Ada Structured Library - A set of container classes and general -- tools for use with Ada95. -- Copyright (C) 1998-1999 Corey Minyard (minyard@acm.org) -- -- This library is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by the -- Free Software Foundation; either version 2 of the License, or (at your -- option) any later version. -- -- This library is distributed in the hope that it will be useful, but -- WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License along -- with this library; if not, write to the Free Software Foundation, Inc., -- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA -- -- As a special exception, if other files instantiate generics from this -- unit, or you link this unit with other files to produce an executable, -- this unit does not by itself cause the resulting executable to be -- covered by the GNU General Public License. This exception does not -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. -- with Ada.Unchecked_Deallocation; package body Asgc.Btree.DynamicMANAGED is procedure Free_Node is new Ada.Unchecked_Deallocation(Node, Node_Ptr); procedure Free_Iterator is new Ada.Unchecked_Deallocation(Iterator, Iterator_Ptr); ------------------------------------------------------------------------ -- Check that an object is valid, that is has not been freed. This is -- not a perfect check, but will hopefully help find some bugs. procedure Check_Object (O : in Object'Class) is begin if (O.Is_Free) then raise Object_Free; end if; end Check_Object; ------------------------------------------------------------------------ -- Check that an iterator is valid. It must not have been freed, it -- must be initialized, its object must be valid, and it must not have -- been modified since the last time the iterator was positioned. procedure Check_Iterator (Iter : in Iterator'Class) is begin if (Iter.Is_Free) then raise Iterator_Free; end if; if (Iter.Robj = null) then raise Invalid_Iterator; end if; Check_Object(Iter.Robj.all); if (Iter.Update /= Iter.Robj.Update) then raise Object_Updated; end if; end Check_Iterator; ------------------------------------------------------------------------ -- Check an iterator, but don't bother checking its positions. This is -- primarily for methods that set some the position of the iterator. procedure Check_Iterator_No_Pos (Iter : in Iterator'Class) is begin if (Iter.Is_Free) then raise Iterator_Free; end if; if (Iter.Robj = null) then raise Invalid_Iterator; end if; Check_Object(Iter.Robj.all); end Check_Iterator_No_Pos; ------------------------------------------------------------------------ -- Return the number of elements in the node. function Node_Count (Node : in Node_Ptr) return Positive is begin if (Node.First <= Node.Last) then return Node.Last - Node.First + 1; else return (Node.Size - Node.First) + Node.Last + 1; end if; end Node_Count; ------------------------------------------------------------------------ -- Return the item position (ie, the Nth item in the node) of the index. -- The index is assumed to be valid, no check is done. function Node_Item_Pos (Node : in Node_Ptr; Index : in Positive) return Positive is begin if (Node.First <= Index) then return Index - Node.First + 1; else return (Node.Size - Node.First) + Index + 1; end if; end Node_Item_Pos; ------------------------------------------------------------------------ -- Return the next value in the node, wrapping around if at the end of -- the array. function Next (Node : in Node_Ptr; Curr : in Positive) return Positive is begin if (Curr /= Node.Vals'Last) then return Curr + 1; else return 1; end if; end Next; ------------------------------------------------------------------------ -- Return the previous value in the node, wrapping around if at the -- beginning of the array. function Prev (Node : in Node_Ptr; Curr : in Positive) return Positive is begin if (Curr /= 1) then return Curr - 1; else return Node.Vals'Last; end if; end Prev; ------------------------------------------------------------------------ -- Return the first value in the Btree. This is the first value in the -- leftmost node. procedure Local_First (O : in Object'Class; Pos : out Node_Ptr; Index : out Positive; Is_End : out End_Marker) is Retval_Pos : Node_Ptr; begin if (O.Count = 0) then Is_End := Past_End; else Is_End := Not_Past_End; Retval_Pos := O.Root; while (not Retval_Pos.Leaf) loop Retval_Pos := Retval_Pos.Children(Retval_Pos.First); end loop; Pos := Retval_Pos; Index := Retval_Pos.First; end if; end Local_First; ------------------------------------------------------------------------ -- Return the last value in the Btree. This is the first value in the -- leftmost node. procedure Local_Last (O : in Object'Class; Pos : out Node_Ptr; Index : out Positive; Is_End : out End_Marker) is Retval_Pos : Node_Ptr; begin if (O.Count = 0) then Is_End := Past_End; else Is_End := Not_Past_End; Retval_Pos := O.Root; while (not Retval_Pos.Leaf) loop Retval_Pos := Retval_Pos.Right_Child; end loop; Pos := Retval_Pos; Index := Retval_Pos.Last; end if; end Local_Last; ------------------------------------------------------------------------ -- Move to the next item in the Btree. This moves the position and -- index to the next item of an in order traversal of the Btree. procedure Local_Next (O : in Object'Class; Pos : in out Node_Ptr; Index : in out Positive; Is_End : out End_Marker) is Tmp_Pos : Node_Ptr; begin if (Index /= Pos.Last) then -- Not the last item in the current node. if (Pos.Leaf) then -- We just go to the next on leaf nodes. Is_End := Not_Past_End; Index := Next(Pos, Index); else -- Not a leaf, follow the child to my right and then go to the -- leftmost node. Is_End := Not_Past_End; Tmp_Pos := Pos.Children(Next(Pos, Index)); while (not Tmp_Pos.Leaf) loop Tmp_Pos := Tmp_Pos.Children(Tmp_Pos.First); end loop; Pos := Tmp_Pos; Index := Pos.First; end if; else if (Pos.Leaf) then -- At the end of a leaf node. Go back up until we hit the root -- or we hit a node that we are not the right child of. Tmp_Pos := Pos; while ((Tmp_Pos /= O.Root) and then (Tmp_Pos.Parent_Index = (Tmp_Pos.Parent.Size + 1))) loop Tmp_Pos := Tmp_Pos.Parent; end loop; if (Tmp_Pos = O.Root) then Is_End := Past_End; else Is_End := Not_Past_End; Index := Tmp_Pos.Parent_Index; Pos := Tmp_Pos.Parent; end if; else -- Not a leaf not, follow the right child down and then go to -- its left subtree. Is_End := Not_Past_End; Tmp_Pos := Pos.Right_Child; while (not Tmp_Pos.Leaf) loop Tmp_Pos := Tmp_Pos.Children(Tmp_Pos.First); end loop; Pos := Tmp_Pos; Index := Pos.First; end if; end if; end Local_Next; ------------------------------------------------------------------------ -- Move to the previous item in the Btree. This moves the position and -- index to the previous item of an in order traversal of the Btree. procedure Local_Prev (O : in Object'Class; Pos : in out Node_Ptr; Index : in out Positive; Is_End : out End_Marker) is Tmp_Pos : Node_Ptr; begin if (Index /= Pos.First) then -- Not the first item in the current node. if (Pos.Leaf) then -- We just go to the previous on leaf nodes. Is_End := Not_Past_End; Index := Prev(Pos, Index); else -- Not a leaf, follow the child to my left and then go to the -- rightmost node. Is_End := Not_Past_End; Tmp_Pos := Pos.Children(Index); while (not Tmp_Pos.Leaf) loop Tmp_Pos := Tmp_Pos.Right_Child; end loop; Pos := Tmp_Pos; Index := Pos.Last; end if; else if (Pos.Leaf) then -- At the end of a leaf node. Go back up until we hit the root -- or we hit a node that we are not the left child of. Tmp_Pos := Pos; while ((Tmp_Pos /= O.Root) and then (Tmp_Pos.Parent_Index = Tmp_Pos.Parent.First)) loop Tmp_Pos := Tmp_Pos.Parent; end loop; if (Tmp_Pos = O.Root) then Is_End := Past_End; else Is_End := Not_Past_End; if (Tmp_Pos.Parent_Index > Tmp_Pos.Parent.Size) then -- We are a right child, use the rightmost value in the -- array. Index := Tmp_Pos.Parent.Last; else Index := Prev(Tmp_Pos.Parent, Tmp_Pos.Parent_Index); end if; Pos := Tmp_Pos.Parent; end if; else -- Not a leaf not, follow the left child down and then go to -- its right subtree. Is_End := Not_Past_End; Tmp_Pos := Pos.Children(Pos.First); while (not Tmp_Pos.Leaf) loop Tmp_Pos := Tmp_Pos.Right_Child; end loop; Pos := Tmp_Pos; Index := Pos.Last; end if; end if; end Local_Prev; ------------------------------------------------------------------------ -- Search for the given value in the container. This will return the -- the Pos (a pointer to the node), the Index (the array position in -- the node) and Found, which is True if the value was found and False -- if not. procedure Local_Search (O : in Object'Class; Val : in Contained_Type; Pos : out Node_Ptr; Index : out Positive; Found : out Boolean) is Retval_Pos : Node_Ptr; Retval_Index : Positive; begin if (O.Count = 0) then Found := False; return; end if; Retval_Pos := O.Root; Retval_Index := Retval_Pos.First; while (Retval_Pos.Vals(Retval_Index) /= Val) loop if (Retval_Pos.Vals(Retval_Index) > Val) then -- Not in this node, go down the left subtree of the current -- node. if (Retval_Pos.Leaf) then -- No left subtree, the node is not in the tree. Found := False; return; end if; Retval_Pos := Retval_Pos.Children(Retval_Index); Retval_Index := Retval_Pos.First; elsif (Retval_Index = Retval_Pos.Last) then -- Not in this node, it is to the right. Follow the rightmost -- subtree. if (Retval_Pos.Leaf) then -- No left subtree, the node is not in the tree. Found := False; return; end if; Retval_Pos := Retval_Pos.Right_Child; Retval_Index := Retval_Pos.First; else -- Keep going in the current node. Retval_Index := Next(Retval_Pos, Retval_Index); end if; end loop; Pos := Retval_Pos; Index := Retval_Index; Found := True; end Local_Search; ------------------------------------------------------------------------ -- Return the node directly to the left of this node with the same -- parent. So, for instance if 17 nodes are layed out like: -- -- 1 -- 2 3 4 5 -- 6 7 8 9 10 11 12 13 14 15 16 17 -- -- where 2, 3, 4, and 5 are the children of 1 and 6, 7, 8 are the -- children of 2, etc., then left is directly to the left as this -- picture shows. So 2 is to the left of 3, 9 is to the left of 10, -- etc. If a node is at the leftmost position (1, 2, 6, 9, 12, and 15 -- in this example) then this function will return null for it. function Left_Node (O : in Object'Class; Pos : in Node_Ptr) return Node_Ptr is Retval : Node_Ptr; Prev_Index : Positive; begin if (Pos.Parent = null) then Retval := null; elsif (Pos.Parent_Index = Pos.Parent.First) then Retval := null; else if (Pos.Parent_Index = (Pos.Parent.Size + 1)) then -- This is a right child. Prev_Index := Pos.Parent.Last; else Prev_Index := Prev(Pos.Parent, Pos.Parent_Index); end if; Retval := Pos.Parent.Children(Prev_Index); end if; return Retval; end Left_Node; ------------------------------------------------------------------------ -- Like Left_Node, but returns the node to the right. function Right_Node (O : in Object'Class; Pos : in Node_Ptr) return Node_Ptr is Retval : Node_Ptr; Next_Index : Positive; begin if (Pos.Parent = null) then Retval := null; elsif (Pos.Parent_Index = (Pos.Parent.Size + 1)) then Retval := null; else if (Pos.Parent_Index = Pos.Parent.Last) then -- Need to pull the right child. Retval := Pos.Parent.Right_Child; else Next_Index := Next(Pos.Parent, Pos.Parent_Index); Retval := Pos.Parent.Children(Next_Index); end if; end if; return Retval; end Right_Node; ------------------------------------------------------------------------ -- There is a hole to the left of us that we must move every node one -- over to fill. So we will make a hole for the new value by removing -- the leftmost node from the passed in node and moving the data over. -- The we wull put the node we pulled out into the common parent with -- the node to the left of us and take the common parent and put it on -- the right side of the node to the left of us by pulling the left -- value out of that node. We do this till we hit the node that had -- some space, where we past the node we are holding into the rightmost -- place (swapping through the parent, too). Note that Pos and Index -- are returned with the exact place where the node was inserted. procedure Insert_Shift_Left (O : in out Object'Class; Pos : in out Node_Ptr; Index : in out Positive; Val : in Contained_Type; Child : in Node_Ptr; Rightmost : in Boolean) is Search_Node : Node_Ptr; Curr_Node : Node_Ptr := Pos; Hold_Val : Contained_Type; Hold_Child : Node_Ptr; Tmp_Val : Contained_Type; Tmp_Child : Node_Ptr; Curr_Index : Positive; Next_Index : Positive; Parent_Index : Positive; begin if (Rightmost) then -- The old first node will become the new last node, thus the -- funny insertions here. Hold_Val := Curr_Node.Vals(Curr_Node.First); Curr_Node.Vals(Curr_Node.First) := Val; if (Child /= null) then Hold_Child := Curr_Node.Children(Curr_Node.First); -- The right child is still to the right of the inserted node. Curr_Node.Children(Curr_Node.First) := Child; Curr_Node.Children(Curr_Node.First).Parent := Curr_Node; Curr_Node.Children(Curr_Node.First).Parent_Index := Curr_Node.First; end if; Curr_Node.First := Next(Curr_Node, Curr_Node.First); Curr_Node.Last := Next(Curr_Node, Curr_Node.Last); Index := Curr_Node.Last; Search_Node := Left_Node(O, Curr_Node); elsif (Index = Pos.First) then -- The new node is going into the leftmost position, so we will be -- pulling the value out from there. Hold_Val := Val; Hold_Child := Child; -- The new node will go in the right of the node to our left. Search_Node := Left_Node(O, Curr_Node); Pos := Search_Node; Index := Next(Search_Node, Search_Node.Last); else -- Move the values over and get the leftmost position into the -- hold value. Hold_Val := Curr_Node.Vals(Curr_Node.First); Curr_Index := Curr_Node.First; Next_Index := Next(Curr_Node, Curr_Index); while (Next_Index /= Index) loop Curr_Node.Vals(Curr_Index) := Curr_Node.Vals(Next_Index); Curr_Index := Next_Index; Next_Index := Next(Curr_Node, Next_Index); end loop; Curr_Node.Vals(Curr_Index) := Val; -- We put the new value in one position before the specified -- index, so modify it appropriately. if (Child /= null) then Hold_Child := Curr_Node.Children(Curr_Node.First); Curr_Index := Curr_Node.First; Next_Index := Next(Curr_Node, Curr_Index); while (Next_Index /= Index) loop Curr_Node.Children(Curr_Index) := Curr_Node.Children(Next_Index); Curr_Node.Children(Curr_Index).Parent_Index := Curr_Index; Curr_Index := Next_Index; Next_Index := Next(Curr_Node, Next_Index); end loop; Curr_Node.Children(Curr_Index) := Child; Curr_Node.Children(Curr_Index).Parent := Curr_Node; Curr_Node.Children(Curr_Index).Parent_Index := Curr_Index; end if; Index := Curr_Index; Search_Node := Left_Node(O, Curr_Node); end if; -- Now move stuff over until we can insert it. while (Next(Search_Node, Search_Node.Last) = Search_Node.First) loop -- We want the index whose right child we are. if (Curr_Node.Parent_Index = (Curr_Node.Parent.Size + 1)) then Parent_Index := Curr_Node.Parent.Last; else Parent_Index := Prev(Curr_Node.Parent, Curr_Node.Parent_Index); end if; -- Swap the hold value with the value in the parent. Tmp_Val := Curr_Node.Parent.Vals(Parent_Index); Curr_Node.Parent.Vals(Parent_Index) := Hold_Val; -- We don't swap the child because it will go to the right of the -- value just taken from the parent, which is the proper location. -- Now put the new hold value into the rightmost value in the node -- and shift everything over. We just move the circular list over -- by one. -- Note that the current First value will become the new last value. Hold_Val := Search_Node.Vals(Search_Node.First); Search_Node.Vals(Search_Node.First) := Tmp_Val; if (Child /= null) then Tmp_Child := Search_Node.Children(Search_Node.First); -- Move the right child into the array. Search_Node.Children(Search_Node.First) := Search_Node.Right_Child; Search_Node.Children(Search_Node.First).Parent_Index := Search_Node.First; -- Set the new right child. Search_Node.Right_Child := Hold_Child; Search_Node.Right_Child.Parent := Search_Node; Search_Node.Right_Child.Parent_Index := Search_Node.Right_Child.Size + 1; Hold_Child := Tmp_Child; end if; Search_Node.First := Next(Search_Node, Search_Node.First); Search_Node.Last := Next(Search_Node, Search_Node.Last); Curr_Node := Search_Node; Search_Node := Left_Node(O, Search_Node); end loop; -- For the final swap, again find the swap parent. while (Curr_Node.Parent_Index = Curr_Node.Parent.First) loop Curr_Node := Curr_Node.Parent; end loop; -- We want the index whose right child we are. if (Curr_Node.Parent_Index = (Curr_Node.Parent.Size + 1)) then Parent_Index := Curr_Node.Parent.Last; else Parent_Index := Prev(Curr_Node.Parent, Curr_Node.Parent_Index); end if; -- Swap the hold value with the value in the parent. Tmp_Val := Curr_Node.Parent.Vals(Parent_Index); Curr_Node.Parent.Vals(Parent_Index) := Hold_Val; -- Now we are at the insertion node, put the hold value into -- the rightmost position. Search_Node.Last := Next(Search_Node, Search_Node.Last); Search_Node.Vals(Search_Node.Last) := Tmp_Val; if (Child /= null) then -- Pull the right child in since we are adding a right node. Search_Node.Children(Search_Node.Last) := Search_Node.Right_Child; Search_Node.Children(Search_Node.Last).Parent_Index := Search_Node.Last; -- Now put the new right child in. Search_Node.Right_Child := Hold_Child; Search_Node.Right_Child.Parent_Index := Search_Node.Size + 1; Search_Node.Right_Child.Parent := Search_Node; end if; end Insert_Shift_Left; ------------------------------------------------------------------------ -- There is a hole to the right of us that we must move everything over -- to fill, the opposite of Insert_Shift_Left. procedure Insert_Shift_Right (O : in out Object'Class; Pos : in out Node_Ptr; Index : in out Positive; Rightmost : in Boolean; Val : in Contained_Type; Child : in Node_Ptr) is Search_Node : Node_Ptr; Curr_Node : Node_Ptr := Pos; Hold_Val : Contained_Type; Hold_Child : Node_Ptr; Tmp_Val : Contained_Type; Tmp_Child : Node_Ptr; Curr_Index : Positive; Prev_Index : Positive; begin -- First we insert the value into the Pos node. if (Rightmost) then -- The new node is going into the rightmost position, so we will be -- pushing it over to the next node. Hold_Val := Val; if (Child /= null) then Hold_Child := Curr_Node.Right_Child; Curr_Node.Right_Child := Child; Curr_Node.Right_Child.Parent := Curr_Node; Curr_Node.Right_Child.Parent_Index := Curr_Node.Size + 1; end if; -- We are moving it over to the other node, so return the right -- position. Search_Node := Right_Node(O, Curr_Node); Pos := Search_Node; Index := Prev(Search_Node, Search_Node.First); else -- Move the values over and get the rightmost position into the -- hold value. Curr_Index := Curr_Node.Last; Hold_Val := Curr_Node.Vals(Curr_Index); while (Curr_Index /= Index) loop Prev_Index := Prev(Curr_Node, Curr_Index); Curr_Node.Vals(Curr_Index) := Curr_Node.Vals(Prev_Index); Curr_Index := Prev_Index; end loop; Curr_Node.Vals(Index) := Val; if (Child /= null) then -- Move the children over, too. The code is a little different -- than the value case because of the special case of the right -- child. Hold_Child := Curr_Node.Right_Child; Curr_Index := Curr_Node.Last; Curr_Node.Right_Child := Curr_Node.Children(Curr_Index); Curr_Node.Right_Child.Parent_Index := Curr_Node.Size + 1; while (Curr_Index /= Index) loop Prev_Index := Prev(Curr_Node, Curr_Index); Curr_Node.Children(Curr_Index) := Curr_Node.Children(Prev_Index); Curr_Node.Children(Curr_Index).Parent_Index := Curr_Index; Curr_Index := Prev_Index; end loop; Curr_Node.Children(Index) := Child; Curr_Node.Children(Index).Parent_Index := Index; Curr_Node.Children(Index).Parent := Curr_Node; end if; Search_Node := Right_Node(O, Curr_Node); end if; -- Now move stuff over until we can insert it. while (Next(Search_Node, Search_Node.Last) = Search_Node.First) loop -- Swap the hold value with the value in the parent. Tmp_Val := Curr_Node.Parent.Vals(Curr_Node.Parent_Index); Curr_Node.Parent.Vals(Curr_Node.Parent_Index) := Hold_Val; -- We don't swap the child because it will go to the right of the -- value just taken from the parent, which is the proper location. -- Now put the new hold value into the leftmost value in the node -- and shift everything over. We just move the circular list over -- by one. -- Note that the current last value will be the new first value. Hold_Val := Search_Node.Vals(Search_Node.Last); Search_Node.Vals(Search_Node.Last) := Tmp_Val; if (Child /= null) then Tmp_Child := Search_Node.Right_Child; Search_Node.Right_Child := Search_Node.Children(Search_Node.Last); Search_Node.Right_Child.Parent := Search_Node; Search_Node.Right_Child.Parent_Index := Search_Node.Size + 1; Search_Node.Children(Search_Node.Last) := Hold_Child; Search_Node.Children(Search_Node.Last).Parent := Search_Node; Search_Node.Children(Search_Node.Last).Parent_Index := Search_Node.Last; Hold_Child := Tmp_Child; end if; Search_Node.First := Prev(Search_Node, Search_Node.First); Search_Node.Last := Prev(Search_Node, Search_Node.Last); Curr_Node := Search_Node; Search_Node := Right_Node(O, Search_Node); end loop; -- Once more, find the parent we are going to swap with. while (Curr_Node.Parent_Index = (Curr_Node.Parent.Size + 1)) loop Curr_Node := Curr_Node.Parent; end loop; -- Swap the hold value with the value in the parent. Tmp_Val := Curr_Node.Parent.Vals(Curr_Node.Parent_Index); Curr_Node.Parent.Vals(Curr_Node.Parent_Index) := Hold_Val; Hold_Val := Tmp_Val; -- Now we are at the insertion node, put the hold value into -- the leftmost position. Search_Node.First := Prev(Search_Node, Search_Node.First); Search_Node.Vals(Search_Node.First) := Hold_Val; if (Child /= null) then Search_Node.Children(Search_Node.First) := Hold_Child; Search_Node.Children(Search_Node.First).Parent := Search_Node; Search_Node.Children(Search_Node.First).Parent_Index := Search_Node.First; end if; end Insert_Shift_Right; ------------------------------------------------------------------------ -- Split a node into two nodes. This also involves inserting a new node -- (since an insertion causes this), Val and its left Child. The passed -- in node (Pos) must be full. A new node will be created to be to the -- left of the node passed in, and the items in the left side of the -- passed in node will be moved to the new node. There will be one item -- that will not be put into the either nodes, the middle item and its -- child will be returned as the new parent to insert into the parent -- node. procedure Split_Node (O : in out Object'Class; Pos : in out Node_Ptr; Index : in out Positive; Rightmost : in Boolean; Val : in Contained_Type; Child : in Node_Ptr; Parent_Val : out Contained_Type; Parent_Child : out Node_Ptr) is New_Node : Node_Ptr := new Node(Size => Pos.Size, Leaf => Pos.Leaf); J : Positive; Curr_Index : Positive; Prev_Index : Positive; begin if (Rightmost or (Node_Item_Pos(Pos, Index) > ((Pos.Size / 2) + 1))) then -- The index is on the right side, the value will be inserted into -- the old node. -- The copy into the new node is straightforward. Curr_Index := Pos.First; for I in 1 .. (Pos.Size / 2) loop New_Node.Vals(I) := Pos.Vals(Curr_Index); if (Child /= null) then New_Node.Children(I) := Pos.Children(Curr_Index); New_Node.Children(I).Parent := New_Node; New_Node.Children(I).Parent_Index := I; end if; Curr_Index := Next(Pos, Curr_Index); end loop; -- The right child is the left child of the item that is becoming -- the parent. if (Child /= null) then New_Node.Right_Child := Pos.Children(Curr_Index); New_Node.Right_Child.Parent := New_Node; New_Node.Right_Child.Parent_Index := New_Node.Size + 1; end if; Parent_Val := Pos.Vals(Curr_Index); Prev_Index := Curr_Index; Curr_Index := Next(Pos, Curr_Index); New_Node.First := 1; New_Node.Last := Pos.Size / 2; if (Rightmost) then Pos.First := Curr_Index; -- If we are adding on the right, just stick it in. Pos.Last := Next(Pos, Pos.Last); Pos.Vals(Pos.Last) := Val; if (Child /= null) then Pos.Children(Pos.Last) := Child; Pos.Children(Pos.Last).Parent := Pos; Pos.Children(Pos.Last).Parent_Index := Pos.Last; end if; Index := Pos.Last; else -- Move all the values forward until we get to the index point. Pos.First := Curr_Index; Pos.Last := Next(Pos, Pos.Last); Curr_Index := Pos.Last; while (Curr_Index /= Index) loop Prev_Index := Prev(Pos, Curr_Index); Pos.Vals(Curr_Index) := Pos.Vals(Prev_Index); if (Child /= null) then Pos.Children(Curr_Index) := Pos.Children(Prev_Index); Pos.Children(Curr_Index).Parent_Index := Curr_Index; end if; Curr_Index := Prev_Index; end loop; Pos.Vals(Index) := Val; if (Child /= null) then Pos.Children(Index) := Child; Pos.Children(Index).Parent := Pos; Pos.Children(Index).Parent_Index := Index; end if; end if; elsif (Node_Item_Pos(Pos, Index) = ((Pos.Size / 2) + 1)) then -- The new parent is the value passed in, so it doesn't go on -- either side. Parent_Val := Val; Curr_Index := Pos.First; for I in 1 .. (Pos.Size / 2) loop New_Node.Vals(I) := Pos.Vals(Curr_Index); if (Child /= null) then New_Node.Children(I) := Pos.Children(Curr_Index); New_Node.Children(I).Parent := New_Node; New_Node.Children(I).Parent_Index := I; end if; Curr_Index := Next(Pos, Curr_Index); end loop; if (Child /= null) then New_Node.Right_Child := Child; New_Node.Right_Child.Parent := New_Node; New_Node.Right_Child.Parent_Index := New_Node.Size + 1; end if; New_Node.First := 1; New_Node.Last := Pos.Size / 2; -- We just move the first position of Pos to remove the first -- nodes. Pos.First := Curr_Index; -- No position, have to get it from the next insert. Pos := null; else -- The index is on the left side, the value will be in the new node. -- Copy values into the new node, sticking the new value in its -- place when we get there. Curr_Index := Pos.First; J := 1; while (Curr_Index /= Index) loop New_Node.Vals(J) := Pos.Vals(Curr_Index); if (Child /= null) then New_Node.Children(J) := Pos.Children(Curr_Index); New_Node.Children(J).Parent := New_Node; New_Node.Children(J).Parent_Index := J; end if; Curr_Index := Next(Pos, Curr_Index); J := J + 1; end loop; New_Node.Vals(J) := Val; Index := J; if (Child /= null) then New_Node.Children(J) := Child; New_Node.Children(J).Parent := New_Node; New_Node.Children(J).Parent_Index := J; end if; J := J + 1; while (J <= (Pos.Size / 2)) loop New_Node.Vals(J) := Pos.Vals(Curr_Index); if (Child /= null) then New_Node.Children(J) := Pos.Children(Curr_Index); New_Node.Children(J).Parent := New_Node; New_Node.Children(J).Parent_Index := J; end if; Curr_Index := Next(Pos, Curr_Index); J := J + 1; end loop; -- The right child is the left child of the item that is becoming -- the parent. if (Child /= null) then New_Node.Right_Child := Pos.Children(Curr_Index); New_Node.Right_Child.Parent := New_Node; New_Node.Right_Child.Parent_Index := New_Node.Size + 1; end if; New_Node.First := 1; New_Node.Last := Pos.Size / 2; Parent_Val := Pos.Vals(Curr_Index); -- We just move the first position of Pos to remove the first -- nodes. Curr_Index := Next(Pos, Curr_Index); Pos.First := Curr_Index; Pos := New_Node; end if; -- The left node is returned as the child of the parent. Parent_Child := New_Node; end Split_Node; ------------------------------------------------------------------------ -- Always inserts into a leaf node. Inserts to the left of Index unless -- rightmost is set, then it will put the value in as the rightmost -- element and ignore the index. procedure Insert_Into_Node (O : in out Object'Class; Val : in Contained_Type; Pos : in out Node_Ptr; Index : in out Positive; Child : in Node_Ptr; Rightmost : in Boolean := False) is Left_Search_Node : Node_Ptr; Right_Search_Node : Node_Ptr; Done : Boolean := False; Parent_Val : Contained_Type := Val; Parent_Child : Node_Ptr := Child; Parent : Node_Ptr; Parent_Index : Positive; Curr_Node : Node_Ptr := Pos; Work_Index : Positive := Index; Curr_Index : Positive; Prev_Index : Positive; Next_Index : Positive; Local_Rightmost : Boolean := Rightmost; begin Pos := null; while (not Done) loop Next_Index := Next(Curr_Node, Curr_Node.Last); if (Next_Index /= Curr_Node.First) then -- Easy case, it will fit into the node. if (Local_Rightmost) then -- We are inserting a rightmost node, so some special work -- with the right child. Curr_Node.Vals(Next_Index) := Parent_Val; if (not Curr_Node.Leaf) then -- The right child will remain valid because the inserted -- node must be less than anything in the right child. Curr_Node.Children(Next_Index) := Parent_Child; Curr_Node.Children(Next_Index).Parent := Curr_Node; Curr_Node.Children(Next_Index).Parent_Index := Next_Index; end if; if (Pos = null) then Pos := Curr_Node; Index := Next_Index; end if; else -- Not the rightmost node, move stuff over. Curr_Index := Next_Index; Prev_Index := Curr_Node.Last; while (Curr_Index /= Work_Index) loop Curr_Node.Vals(Curr_Index) := Curr_Node.Vals(Prev_Index); if (not Curr_Node.Leaf) then Curr_Node.Children(Curr_Index) := Curr_Node.Children(Prev_Index); Curr_Node.Children(Curr_Index).Parent_Index := Curr_Index; end if; Curr_Index := Prev_Index; Prev_Index := Prev(Curr_Node, Prev_Index); end loop; Curr_Node.Vals(Work_Index) := Parent_Val; if (not Curr_Node.Leaf) then Curr_Node.Children(Work_Index) := Parent_Child; Curr_Node.Children(Work_Index).Parent_Index := Work_Index; Curr_Node.Children(Work_Index).Parent := Curr_Node; end if; Index := Work_Index; end if; Pos := Curr_Node; Curr_Node.Last := Next_Index; Done := True; else -- Hard case, we need to look around to see if it fits -- somewhere. Left_Search_Node := Left_Node(O, Curr_Node); Right_Search_Node := Right_Node(O, Curr_Node); while ((Left_Search_Node /= null) or (Right_Search_Node /= null)) loop if (Left_Search_Node /= null) then if (Next(Left_Search_Node, Left_Search_Node.Last) /= Left_Search_Node.First) then -- We found another node where we can fit to the left -- of us, shift stuff around. We find the value we -- want to move over to the tree to the left. Insert_Shift_Left(O, Curr_Node, Work_Index, Parent_Val, Parent_Child, Local_Rightmost); if (Pos = null) then Pos := Curr_Node; Index := Work_Index; end if; -- We are done. Done := True; exit; end if; Left_Search_Node := Left_Node(O, Left_Search_Node); end if; if (Right_Search_Node /= null) then if (Next(Right_Search_Node, Right_Search_Node.Last) /= Right_Search_Node.First) then -- We found another node where we can fit to the Right -- of us, shift stuff around. We find the value we -- want to move over to the tree to the Right. Insert_Shift_Right(O, Curr_Node, Work_Index, Local_Rightmost, Parent_Val, Parent_Child); if (Pos = null) then Pos := Curr_Node; Index := Work_Index; end if; -- We are done. Done := True; exit; end if; Right_Search_Node := Right_Node(O, Right_Search_Node); end if; end loop; if (not Done) then -- the leaves are all full. We need to do a split. if (Curr_Node = O.Root) then -- The root node is full, split it. -- Create a new root node to parent the two newly created -- nodes. The current node will be split and become the -- right child of the new node. Parent := new Node(Size => O.Root.Size, Leaf => False); Parent.Right_Child := Curr_Node; Parent.Right_Child.Parent := Parent; Parent.Right_Child.Parent_Index := Parent.Size + 1; -- Now split the node. The new node (with the left -- values) is returned in parent_child. The value to put -- into the new root is returned in parent_val. Split_Node(O, Curr_Node, Work_Index, Local_Rightmost, Parent_Val, Parent_Child, Parent_Val, Parent_Child); if (Pos = null) then if (Curr_Node = null) then Pos := Parent; Index := 1; else Pos := Curr_Node; Index := Work_Index; end if; end if; Parent.Vals(1) := Parent_Val; Parent.Children(1) := Parent_Child; Parent.Children(1).Parent := Parent; Parent.Children(1).Parent_Index := 1; O.Root := Parent; Parent.First := 1; Parent.Last := 1; Done := True; else Parent := Curr_Node.Parent; Parent_Index := Curr_Node.Parent_Index; Split_Node(O, Curr_Node, Work_Index, Local_Rightmost, Parent_Val, Parent_Child, Parent_Val, Parent_Child); if ((Curr_Node /= null) and (Pos = null)) then Pos := Curr_Node; Index := Work_Index; end if; Curr_Node := Parent; if (Parent_Index = (Curr_Node.Size + 1)) then -- We split a right node, we are inserting into the -- rightmost position now. Local_Rightmost := True; else Work_Index := Parent_Index; Local_Rightmost := False; end if; end if; end if; end if; end loop; end Insert_Into_Node; ------------------------------------------------------------------------ -- Add a value to the object. This will return the position that the -- item was added at. procedure Local_Add (O : in out Object'Class; Val : in Contained_Type; Added_Pos : out Node_Ptr; Added_Index : out Positive) is Pos : Node_Ptr; Index : Positive; begin Pos := O.Root; if (O.Count = 0) then Pos.First := 1; Pos.Last := 1; Pos.Vals(1) := Val; Index := 1; else Index := Pos.First; loop if (Val <= Pos.Vals(Index)) then if ((not O.Allow_Duplicates) and then (Val = Pos.Vals(Index))) then raise Item_Already_Exists; end if; if (Pos.Leaf) then -- It needs to go here. Insert_Into_Node(O, Val, Pos, Index, null); exit; else -- follow the left child Pos := Pos.Children(Index); Index := Pos.First; end if; elsif (Index = Pos.Last) then -- It goes to the right of me. if (Pos.Leaf) then -- It needs to go here. Insert_Into_Node(O, Val, Pos, Index, null, Rightmost => True); exit; else -- follow the rightmost child Pos := Pos.Right_Child; Index := Pos.First; end if; else Index := Next(Pos, Index); end if; end loop; end if; O.Count := O.Count + 1; O.Update := O.Update + 1; if (O.Cb /= null) then Added(O.Cb, O, Pos.Vals(Index)); end if; Added_Pos := Pos; Added_Index := Index; end Local_Add; ------------------------------------------------------------------------ -- Delete from the node. The deletes by shifting things from the first -- to the index. This avoids modifying the next item's position, making -- finding the next node a little easier. procedure Delete_From_Node (O : in out Object'Class; Pos : in Node_Ptr; Index : in Positive) is Curr_Index : Positive; Prev_Index : Positive; begin Curr_Index := Index; Prev_Index := Prev(Pos, Index); while (Curr_Index /= Pos.First) loop Pos.Vals(Curr_Index) := Pos.Vals(Prev_Index); if (not Pos.Leaf) then Pos.Children(Curr_Index) := Pos.Children(Prev_Index); Pos.Children(Curr_Index).Parent_Index := Curr_Index; end if; Curr_Index := Prev_Index; Prev_Index := Prev(Pos, Prev_Index); end loop; Pos.First := Next(Pos, Pos.First); end Delete_From_Node; ------------------------------------------------------------------------ -- Something has been deleted from the node and it is not full any more. -- If this is called, a node to our right has an extra item that can be -- shifted around to this node to balance this node out. This routine -- does the shifting. procedure Delete_Shift_Left (O : in out Object'Class; Pos : in Node_Ptr; Next_Pos : in out Node_Ptr; Next_Index : in out Positive) is Search_Node : Node_Ptr; Curr_Node : Node_Ptr := Pos; Parent_Node : Node_Ptr; begin loop Search_Node := Right_Node(O, Curr_Node); -- Find the parent I need to swap with. We go up the tree until -- we are not a rightmost node. Parent_Node := Curr_Node; while (Parent_Node.Parent_Index = (Parent_Node.Parent.Size + 1)) loop Parent_Node := Parent_Node.Parent; end loop; -- Now do the swap by moving the parent into the right of the -- current node and the left node of our right sibling into the -- parent. Curr_Node.Last := Next(Curr_Node, Curr_Node.Last); if ((Parent_Node.Parent = Next_Pos) and (Parent_Node.Parent_Index = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Curr_Node; Next_Index := Curr_Node.Last; end if; if ((Search_Node = Next_Pos) and (Search_Node.First = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Parent_Node.Parent; Next_Index := Parent_Node.Parent_Index; end if; Curr_Node.Vals(Curr_Node.Last) := Parent_Node.Parent.Vals(Parent_Node.Parent_Index); Parent_Node.Parent.Vals(Parent_Node.Parent_Index) := Search_Node.Vals(Search_Node.First); if (not Curr_Node.Leaf) then Curr_Node.Children(Curr_Node.Last) := Curr_Node.Right_Child; Curr_Node.Children(Curr_Node.Last).Parent_Index := Curr_Node.Last; Curr_Node.Right_Child := Search_Node.Children(Search_Node.First); Curr_Node.Right_Child.Parent := Curr_Node; Curr_Node.Right_Child.Parent_Index := Curr_Node.Size + 1; end if; Search_Node.First := Next(Search_Node, Search_Node.First); exit when (Node_Count(Search_Node) >= (Search_Node.Size / 2)); Curr_Node := Search_Node; end loop; end Delete_Shift_Left; ------------------------------------------------------------------------ -- Like Delete_Shift_Left, but the item is to our left so we are -- shifting right. procedure Delete_Shift_Right (O : in out Object'Class; Pos : in Node_Ptr; Next_Pos : in out Node_Ptr; Next_Index : in out Positive) is Search_Node : Node_Ptr; Curr_Node : Node_Ptr := Pos; Parent_Node : Node_Ptr; Parent_Index : Positive; begin loop Search_Node := Left_Node(O, Curr_Node); -- Find the parent I need to swap with. We go up the tree until -- we are not a rightmost node. Parent_Node := Curr_Node; while (Parent_Node.Parent_Index = Parent_Node.Parent.First) loop Parent_Node := Parent_Node.Parent; end loop; -- Swap from the parent to the left of us. if (Parent_Node.Parent_Index = (Parent_Node.Parent.Size + 1)) then -- A right child get special handling. Parent_Index := Parent_Node.Parent.Last; else Parent_Index := Prev(Parent_Node.Parent, Parent_Node.Parent_Index); end if; -- Now do the swap by moving the parent into the left of the -- current node and the right node of our left sibling into the -- parent. Curr_Node.First := Prev(Curr_Node, Curr_Node.First); if ((Parent_Node.Parent = Next_Pos) and (Parent_Index = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Curr_Node; Next_Index := Curr_Node.First; end if; if ((Search_Node = Next_Pos) and (Search_Node.Last = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Parent_Node.Parent; Next_Index := Parent_Index; end if; Curr_Node.Vals(Curr_Node.First) := Parent_Node.Parent.Vals(Parent_Index); Parent_Node.Parent.Vals(Parent_Index) := Search_Node.Vals(Search_Node.Last); if (not Curr_Node.Leaf) then Curr_Node.Children(Curr_Node.First) := Search_Node.Right_Child; Curr_Node.Children(Curr_Node.First).Parent := Curr_Node; Curr_Node.Children(Curr_Node.First).Parent_Index := Curr_Node.First; Search_Node.Right_Child := Search_Node.Children(Search_Node.Last); Search_Node.Right_Child.Parent_Index := Search_Node.Size + 1; end if; Search_Node.Last := Prev(Search_Node, Search_Node.Last); exit when (Node_Count(Search_Node) >= (Search_Node.Size / 2)); Curr_Node := Search_Node; end loop; end Delete_Shift_Right; ------------------------------------------------------------------------ -- Move the data from node1 into node2, including node1's parent. procedure Combine_Nodes (O : in out Object'Class; Node1 : in Node_Ptr; Node2 : in Node_Ptr; Next_Pos : in out Node_Ptr; Next_Index : in out Positive) is begin -- First put in the parent. Node2.First := Prev(Node2, Node2.First); if ((Node1.Parent = Next_Pos) and (Node1.Parent_Index = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Node2; Next_Index := Node2.First; end if; Node2.Vals(Node2.First) := Node1.Parent.Vals(Node1.Parent_Index); if (not Node1.Leaf) then Node2.Children(Node2.First) := Node1.Right_Child; Node2.Children(Node2.First).Parent := Node2; Node2.Children(Node2.First).Parent_Index := Node2.First; end if; loop Node2.First := Prev(Node2, Node2.First); if ((Node1 = Next_Pos) and (Node1.Last = Next_Index)) then -- We are moving the current next position, so move our reference -- to it. Next_Pos := Node2; Next_Index := Node2.First; end if; Node2.Vals(Node2.First) := Node1.Vals(Node1.Last); if (not Node1.Leaf) then Node2.Children(Node2.First) := Node1.Children(Node1.Last); Node2.Children(Node2.First).Parent := Node2; Node2.Children(Node2.First).Parent_Index := Node2.First; end if; exit when (Node1.Last = Node1.First); Node1.Last := Prev(Node1, Node1.Last); end loop; end Combine_Nodes; ------------------------------------------------------------------------ -- Delete an item from the tree. The new position of the item following -- the deleted one is returned in New_Next_Pos and New_Next_Index. -- Is_End denotes if the last item in the Btree was deleted or not. procedure Local_Delete (O : in out Object'Class; Pos : in Node_Ptr; Index : in Positive; New_Next_Pos : out Node_Ptr; New_Next_Index : out Positive; Is_End : out End_Marker) is Hold_Val : Contained_Type; Node : Node_Ptr := Pos; Curr_Index : Positive := Index; Done : Boolean := False; Left_Search_Node : Node_Ptr; Right_Search_Node : Node_Ptr; Combine_Left_Node : Node_Ptr; Combine_Right_Node : Node_Ptr; Next_Index : Positive; Prev_Index : Positive; Return_Next_Pos : Node_Ptr := Pos; Return_Next_Index : Positive := Index; Local_Is_End : End_Marker; begin Hold_Val := Node.Vals(Index); -- Pull the rightmost value from the left children until we hit a -- leaf node. This will guarantee the ordering does not change -- without swapping any nodes around. if (not Node.Leaf) then Node := Node.Children(Curr_Index); while (not Node.Leaf) loop Node := Node.Right_Child; end loop; -- Pull the rightmost value out of the rightmost subtree of my -- left child and replace the removed value with it. Curr_Index := Node.Last; Pos.Vals(Index) := Node.Vals(Curr_Index); end if; -- Go ahead and find the next node. Local_Next(O, Return_Next_Pos, Return_Next_Index, Local_Is_End); Is_End := Local_Is_End; if (Local_Is_End = Past_End) then -- Set the next position null so it won't get updated. Return_Next_Pos := null; end if; -- Now we are guaranteed to be a leaf node, we can actually remove -- something. The following loop will go up the tree until it finds -- a level were a combination is not required. while (not Done) loop if (Node_Count(Node) > (Node.Size / 2)) then -- Easy case, just remove the index. Delete_From_Node(O, Node, Curr_Index); Done := True; else -- Our node is too empty. First try to steal from the left or -- right siblings. Left_Search_Node := Left_Node(O, Node); Right_Search_Node := Right_Node(O, Node); while ((Left_Search_Node /= null) or (Right_Search_Node /= null)) loop if (Left_Search_Node /= null) then if (Node_Count(Left_Search_Node) > (Left_Search_Node.Size / 2)) then -- Go ahead and delete the thing from the node before -- we rotate stuff around. Delete_From_Node(O, Node, Curr_Index); -- We found another node where we can fit to the left -- of us, shift stuff around. We find the value we -- want to move over to the tree to the left. Delete_Shift_Right(O, Node, Return_Next_Pos, Return_Next_Index); -- We are done. Done := True; exit; end if; Left_Search_Node := Left_Node(O, Left_Search_Node); end if; if (Right_Search_Node /= null) then if (Node_Count(Right_Search_Node) > (Right_Search_Node.Size / 2)) then -- Go ahead and delete the thing from the node before -- we rotate stuff around. Delete_From_Node(O, Node, Curr_Index); -- We found another node where we can pull from to the -- right of us, shift stuff around. We find the value we -- want to move over to the tree to the Right. Delete_Shift_Left(O, Node, Return_Next_Pos, Return_Next_Index); -- We are done. Done := True; exit; end if; Right_Search_Node := Right_Node(O, Right_Search_Node); end if; end loop; end if; if (not Done) then -- No leaf nodes have any leftover items, time to start -- combining nodes. if (Node = O.Root) then -- Root node does not have a minimum allowed count. -- However, we might have to promote our child to root if we -- are going to be empty. if (Node_Count(Node) = 1) then if (not Node.Leaf) then -- Promoting our one child to root. The algorithm -- leaves the left child to the right of the deleted -- position, so the left child is no longer valid. O.Root := Node.Right_Child; O.Root.Parent := null; O.Root.Parent_Index := 1; Free_Node(Node); end if; -- If root is a leaf not and deleting the last item, the -- count will become zero in the container and that is -- handled as a special case. else Delete_From_Node(O, Node, Curr_Index); end if; Done := True; else if (Node.Parent_Index = Node.Parent.First) then -- We are the leftmost node, combine with our right -- neighbor. Combine_Left_Node := Node; Next_Index := Next(Node.Parent, Node.Parent_Index); if (Node.Parent_Index = Node.Parent.Last) then -- We are the rightmost node, take the right child. Combine_Right_Node := Node.Parent.Right_Child; else Combine_Right_Node := Node.Parent.Children(Next_Index); end if; else -- We are not leftmost, combine with our left neighbor. Combine_Right_Node := Node; if (Node.Parent_Index = (Node.Parent.Size + 1)) then Prev_Index := Node.Parent.Last; else Prev_Index := Prev(Node.Parent, Node.Parent_Index); end if; Combine_Left_Node := Node.Parent.Children(Prev_Index); end if; -- Go ahead and delete the thing from the node before we -- combine. Delete_From_Node(O, Node, Curr_Index); Curr_Index := Combine_Left_Node.Parent_Index; Node := Node.Parent; Combine_Nodes(O, Combine_Left_Node, Combine_Right_Node, Return_Next_Pos, Return_Next_Index); Free_Node(Combine_Left_Node); end if; end if; end loop; New_Next_Pos := Return_Next_Pos; New_Next_Index := Return_Next_Index; O.Count := O.Count - 1; O.Update := O.Update + 1; if (O.Cb /= null) then Deleted(O.Cb, O, Hold_Val); end if; end Local_Delete; ------------------------------------------------------------------------ -- This is a controlled type, so we have those methods to handle. ------------------------------------------------------------------------ procedure Initialize (O : in out Object) is begin null; end Initialize; ------------------------------------------------------------------------ procedure Adjust (O : in out Object) is New_Tree : Node_Ptr; Curr_Node : Node_Ptr; Curr_Index : Positive; begin New_Tree := new Node'(O.Root.all); Curr_Node := New_Tree; if (O.Count = 0) then -- The tree is empty, nothing to do. null; elsif (Curr_Node.Leaf) then -- Only a root node, call copied for its children. if (O.Cb /= null) then Curr_Index := Curr_Node.First; loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; end if; else -- Call copied for the root node. if (O.Cb /= null) then Curr_Index := Curr_Node.First; loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; end if; Curr_Index := Curr_Node.First; -- Do an pre-order traversal of the tree, creating the nodes as we -- visit them. Main_Loop: loop -- Create the new node. Curr_Node.Children(Curr_Index) := new Node'(Curr_Node.Children(Curr_Index).all); Curr_Node.Children(Curr_Index).Parent := Curr_Node; if (not Curr_Node.Children(Curr_Index).Leaf) then -- Not a leaf node, move to the new node, call copied on its -- members, and process this node next. Curr_Node := Curr_Node.Children(Curr_Index); Curr_Index := Curr_Node.First; if (O.Cb /= null) then loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; end if; Curr_Index := Curr_Node.First; else -- A leaf node. Call copied on all the members and stay at -- the parent. if (O.Cb /= null) then Curr_Node := Curr_Node.Children(Curr_Index); Curr_Index := Curr_Node.First; loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; Curr_Index := Curr_Node.Parent_Index; Curr_Node := Curr_Node.Parent; end if; if (Curr_Index /= Curr_Node.Last) then Curr_Index := Next(Curr_Node, Curr_Index); else Curr_Node.Right_Child := new Node'(Curr_Node.Right_Child.all); Curr_Node.Right_Child.Parent := Curr_Node; if (not Curr_Node.Right_Child.Leaf) then -- Not a leaf node, move to the new node, call copied -- on its members, and process this node next. Curr_Node := Curr_Node.Right_Child; Curr_Index := Curr_Node.First; if (O.Cb /= null) then loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; end if; Curr_Index := Curr_Node.First; else -- A leaf node. Call copied on all the members and -- then we must go up. if (O.Cb /= null) then Curr_Node := Curr_Node.Right_Child; Curr_Index := Curr_Node.First; loop Copied(O.Cb, O, Curr_Node.Vals(Curr_Index)); exit when (Curr_Index = Curr_Node.Last); Curr_Index := Next(Curr_Node, Curr_Index); end loop; Curr_Index := Curr_Node.Parent_Index; Curr_Node := Curr_Node.Parent; end if; -- Time to go up the tree. if (Curr_Node = New_Tree) then -- If we are at the root of the tree, we are done. exit Main_Loop; end if; -- Go up while we are the right child, since the node -- is done at that point. while (Curr_Node.Parent_Index = (Curr_Node.Parent.Size + 1)) loop Curr_Node := Curr_Node.Parent; if (Curr_Node = New_Tree) then -- If we are at the root of the tree, we are done. exit Main_Loop; end if; end loop; -- Now we need to follow down the next right subtree -- of our parent. if (Curr_Node.Parent_Index = Curr_Node.Parent.Last) then -- We need to go down the right child. Curr_Node := Curr_Node.Parent.Right_Child; else Curr_Index := Next(Curr_Node.Parent, Curr_Node.Parent_Index); Curr_Node := Curr_Node.Parent.Children(Curr_Index); end if; Curr_Index := Curr_Node.First; end if; end if; end if; end loop Main_Loop; end if; O.Root := New_Tree; end Adjust; ------------------------------------------------------------------------ procedure Finalize (O : in out Object) is Curr_Node : Node_Ptr; Curr_Index : Positive; begin Curr_Node := O.Root; if (O.Count = 0) then Free_Node(O.Root); elsif (Curr_Node.Leaf) then -- Only a root node, delete it children. if (O.Cb /= null) then loop Deleted(O.Cb, O, Curr_Node.Vals(Curr_Node.First)); exit when (Curr_Node.First = Curr_Node.Last); Curr_Node.First := Next(Curr_Node, Curr_Node.First); end loop; end if; Free_Node(O.Root); else -- Do an in-order traversal of the tree, deleting the nodes as we -- visit them. -- Seek to the leftmost leaf node. while (not Curr_Node.Leaf) loop Curr_Node := Curr_Node.Children(Curr_Node.First); end loop; Main_Loop: loop if (O.Cb /= null) then loop Deleted(O.Cb, O, Curr_Node.Vals(Curr_Node.First)); exit when (Curr_Node.First = Curr_Node.Last); Curr_Node.First := Next(Curr_Node, Curr_Node.First); end loop; end if; Curr_Index := Curr_Node.Parent_Index; Curr_Node := Curr_Node.Parent; if (Curr_Index = (Curr_Node.Size + 1)) then -- Set up to delete the parent on the next time through the -- loop. Free_Node(Curr_Node.Right_Child); if (Curr_Node = O.Root) then Free_Node(O.Root); exit Main_Loop; end if; else -- Find the leftmost child of the node to the right of the -- one I am deleting. if (O.Cb /= null) then Deleted(O.Cb, O, Curr_Node.Vals(Curr_Index)); end if; Free_Node(Curr_Node.Children(Curr_Index)); if (Curr_Index = Curr_Node.Last) then Curr_Node := Curr_Node.Right_Child; else Curr_Index := Next(Curr_Node, Curr_Index); Curr_Node := Curr_Node.Children(Curr_Index); end if; -- Seek to the leftmost leaf node. while (not Curr_Node.Leaf) loop Curr_Node := Curr_Node.Children(Curr_Node.First); end loop; Curr_Index := Curr_Node.First; end if; end loop Main_Loop; end if; end Finalize; ------------------------------------------------------------------------ procedure Finalize (Iter : in out Iterator) is begin Iter.Is_Free := True; end Finalize; ------------------------------------------------------------------------ -- The functions that follow are defined as abstract in previous -- packages. See those packages for descriptions of what these -- methods do. ------------------------------------------------------------------------ procedure Add (O : in out Object; Val : in Contained_Type) is Pos : Node_Ptr; Index : Positive; begin Check_Object(O); Local_Add(O, Val, Pos, Index); end Add; ------------------------------------------------------------------------ procedure Delete (O : in out Object; Val : in Contained_Type) is Pos : Node_Ptr; Index : Positive; Found : Boolean; Next_Pos : Node_Ptr; Next_Index : Positive; Is_End : End_Marker; begin Check_Object(O); Local_Search(O, Val, Pos, Index, Found); if (not Found) then raise Item_Not_Found; end if; Local_Delete(O, Pos, Index, Next_Pos, Next_Index, Is_End); end Delete; ------------------------------------------------------------------------ function Value_Exists (O : in Object; Val : in Contained_Type) return Boolean is Pos : Node_Ptr; Index : Positive; Found : Boolean; begin Check_Object(O); Local_Search(O, Val, Pos, Index, Found); return Found; end Value_Exists; ------------------------------------------------------------------------ function "=" (O1, O2 : in Object) return Boolean is Pos1 : Node_Ptr; Index1 : Positive; Pos2 : Node_Ptr; Index2 : Positive; Is_End : End_Marker; begin Check_Object(O1); Check_Object(O2); if (O1.Count /= O2.Count) then return False; elsif ((O1.Count = 0) and (O2.Count = 0)) then return True; else Local_First(O1, Pos1, Index1, Is_End); Local_First(O2, Pos2, Index2, Is_End); while (Is_End = Not_Past_End) loop if (Pos1.Vals(Index1) /= Pos1.Vals(Index2)) then return False; end if; Local_Next(O1, Pos1, Index1, Is_End); Local_Next(O2, Pos2, Index2, Is_End); end loop; return True; end if; end "="; ------------------------------------------------------------------------ function Member_Count (O : in Object) return Natural is begin Check_Object(O); return O.Count; end Member_Count; ------------------------------------------------------------------------ function Recurse_Verify (O : in Object; Pos : in Node_Ptr; Use_Min : in Boolean; Min_Val : in Contained_Type; Use_Max : in Boolean; Max_Val : in Contained_Type; Parent : in Node_Ptr; Parent_Index : in Positive) return Natural is Index : Positive; Next_Index : Positive; Count : Natural := 0; begin if ((Pos.Parent /= Parent) or (Pos.Parent_Index /= Parent_Index)) then raise Internal_Btree_Error; end if; Count := Node_Count(Pos); if ((Pos /= O.Root) and (Count < (Pos.Size / 2))) then raise Internal_Btree_Error; end if; Index := Pos.First; if (not Pos.Leaf) then Count := Count + Recurse_Verify(O, Pos.Children(Pos.First), Use_Min, Min_Val, True, Pos.Vals(Pos.First), Pos, Pos.First); end if; if (Use_Min) then if (Min_Val > Pos.Vals(Pos.First)) then raise Internal_Btree_Error; end if; end if; while (Index /= Pos.Last) loop Next_Index := Next(Pos, Index); if (Pos.Vals(Index) > Pos.Vals(Next_Index)) then raise Internal_Btree_Error; end if; if (not Pos.Leaf) then Count := Count + Recurse_Verify(O, Pos.Children(Next_Index), True, Pos.Vals(Index), True, Pos.Vals(Next_Index), Pos, Next_Index); end if; Index := Next_Index; end loop; if (Use_Max) then if (Max_Val < Pos.Vals(Pos.Last)) then raise Internal_Btree_Error; end if; end if; if (not Pos.Leaf) then Count := Count + Recurse_Verify(O, Pos.Right_Child, True, Pos.Vals(Pos.Last), Use_Max, Max_Val, Pos, Pos.Size + 1); end if; return Count; end Recurse_Verify; ------------------------------------------------------------------------ procedure Verify_Integrity (O : in Object) is Count : Natural; begin Check_Object(O); if (O.Count = 0) then return; end if; Count := Recurse_Verify(O, O.Root, False, O.Root.Vals(O.Root.First), False, O.Root.Vals(O.Root.First), null, 1); if (Count /= O.Count) then raise Internal_Btree_Error; end if; end Verify_Integrity; ------------------------------------------------------------------------ function Copy (O : in Object) return Asgc.Object_Class is Retval : Object_Ptr; begin Retval := new Object(Allow_Duplicates => O.Allow_Duplicates, Node_Size => O.Node_Size); -- Adjust will take care of copying all the data. Retval.all := O; return Asgc.Object_Class(Retval); end Copy; ------------------------------------------------------------------------ function New_Iterator (O : access Object) return Asgc.Iterator_Class is Retval : Iterator_Ptr; begin Check_Object(O.all); Retval := new Iterator; Retval.Robj := Object_Class(O); return Asgc.Iterator_Class(Retval); end New_Iterator; ------------------------------------------------------------------------ function New_Iterator (O : in Object_Class) return Iterator is Retval : Iterator; begin Retval.Robj := O; return Retval; end New_Iterator; ------------------------------------------------------------------------ procedure Free (Iter : access Iterator) is To_Free : Iterator_Ptr := Iterator_Ptr(Iter); begin if (Iter.Is_Free) then raise Iterator_Free; end if; Free_Iterator(To_Free); end Free; ------------------------------------------------------------------------ procedure Set_Container (Iter : in out Iterator; O : in Asgc.Object_Class) is begin Check_Object(Object'Class(O.all)); Iter.Robj := Object_Class(O); Iter.Update := Invalid_Update; end Set_Container; ------------------------------------------------------------------------ procedure First (Iter : in out Iterator; Is_End : out End_Marker) is Local_Is_End : End_Marker; begin Check_Iterator_No_Pos(Iter); Local_First(Iter.Robj.all, Iter.Pos, Iter.Index, Local_Is_End); Is_End := Local_Is_End; if (Local_Is_End = Not_Past_End) then Iter.Update := Iter.Robj.Update; end if; end First; ------------------------------------------------------------------------ procedure Last (Iter : in out Iterator; Is_End : out End_Marker) is Local_Is_End : End_Marker; begin Check_Iterator_No_Pos(Iter); Local_Last(Iter.Robj.all, Iter.Pos, Iter.Index, Local_Is_End); Is_End := Local_Is_End; if (Local_Is_End = Not_Past_End) then Iter.Update := Iter.Robj.Update; end if; end Last; ------------------------------------------------------------------------ procedure Add (Iter : in out Iterator; Val : in Contained_Type) is Pos : Node_Ptr; Index : Positive; begin Check_Iterator_No_Pos(Iter); Local_Add(Iter.Robj.all, Val, Pos, Index); Iter.Pos := Pos; Iter.Index := Index; Iter.Update := Iter.Robj.Update; end Add; ------------------------------------------------------------------------ procedure Search (Iter : in out Iterator; Val : in Contained_Type; Found : out Boolean) is Pos : Node_Ptr; Index : Positive; Local_Found : Boolean; Tmp_Pos : Node_Ptr; Tmp_Index : Positive; Is_End : End_Marker; begin Check_Iterator_No_Pos(Iter); Local_Search(Iter.Robj.all, Val, Pos, Index, Local_Found); Found := Local_Found; if (Local_Found) then if (Iter.Robj.Allow_Duplicates) then -- if duplicates are allowed, this might not be the first -- element with the given value. Move to previous nodes until -- we find one that is not the specified value and return the -- first element with the specified value. Tmp_Pos := Pos; Tmp_Index := Index; Local_Prev(Iter.Robj.all, Tmp_Pos, Tmp_Index, Is_End); while ((Is_End = Not_Past_End) and then (Tmp_Pos.Vals(Tmp_Index) = Val)) loop Pos := Tmp_Pos; Index := Tmp_Index; Local_Prev(Iter.Robj.all, Tmp_Pos, Tmp_Index, Is_End); end loop; end if; Iter.Pos := Pos; Iter.Index := Index; Iter.Update := Iter.Robj.Update; end if; end Search; ------------------------------------------------------------------------ procedure Search_Again (Iter : in out Iterator; Found : out Boolean) is Pos : Node_Ptr := Iter.Pos; Index : Positive := Iter.Index; Is_End : End_Marker; begin Check_Iterator(Iter); Local_Next(Iter.Robj.all, Pos, Index, Is_End); if (Is_End = Past_End) then Found := False; elsif (Iter.Pos.Vals(Iter.Index) /= Pos.Vals(Index)) then Found := False; else Found := True; Iter.Pos := Pos; Iter.Index := Index; end if; end Search_Again; ------------------------------------------------------------------------ procedure Next (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator(Iter); Local_Next(Iter.Robj.all, Iter.Pos, Iter.Index, Is_End); end Next; ------------------------------------------------------------------------ procedure Prev (Iter : in out Iterator; Is_End : out End_Marker) is begin Check_Iterator(Iter); Local_Prev(Iter.Robj.all, Iter.Pos, Iter.Index, Is_End); end Prev; ------------------------------------------------------------------------ procedure Delete (Iter : in out Iterator; Is_End : out End_Marker) is Local_Is_End : End_Marker; begin Check_Iterator(Iter); Local_Delete(Iter.Robj.all, Iter.Pos, Iter.Index, Iter.Pos, Iter.Index, Local_Is_End); Is_End := Local_Is_End; if (Local_Is_End = Not_Past_End) then Iter.Update := Iter.Robj.Update; end if; end Delete; ------------------------------------------------------------------------ function Is_Same (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); if (Iter1.Robj /= Iter2.Robj) then raise Iterator_Mismatch; end if; return ((Iter1.Pos = Iter2.Pos) and (Iter1.Index = Iter2.Index)); end Is_Same; ------------------------------------------------------------------------ function Get (Iter : in Iterator) return Contained_Type is begin Check_Iterator(Iter); return Iter.Pos.Vals(Iter.Index); end Get; ------------------------------------------------------------------------ procedure Get_Incr (Iter : in out Iterator; Val : out Contained_Type; Is_End : out End_Marker) is begin Check_Iterator(Iter); Val := Iter.Pos.Vals(Iter.Index); Next(Iter, Is_End); end Get_Incr; ------------------------------------------------------------------------ procedure Get_Decr (Iter : in out Iterator; Val : out Contained_Type; Is_End : out End_Marker) is begin Check_Iterator(Iter); Val := Iter.Pos.Vals(Iter.Index); Prev(Iter, Is_End); end Get_Decr; ------------------------------------------------------------------------ function "=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Pos.Vals(Iter1.Index) = Iter2.Pos.Vals(Iter2.Index)); end "="; ------------------------------------------------------------------------ function "=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) = Val); end "="; ------------------------------------------------------------------------ function "=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) = Val); end "="; ------------------------------------------------------------------------ function ">" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Pos.Vals(Iter1.Index) > Iter2.Pos.Vals(Iter2.Index)); end ">"; ------------------------------------------------------------------------ function ">" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) > Val); end ">"; ------------------------------------------------------------------------ function ">" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val > Iter.Pos.Vals(Iter.Index)); end ">"; ------------------------------------------------------------------------ function "<" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Pos.Vals(Iter1.Index) < Iter2.Pos.Vals(Iter2.Index)); end "<"; ------------------------------------------------------------------------ function "<" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) < Val); end "<"; ------------------------------------------------------------------------ function "<" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val < Iter.Pos.Vals(Iter.Index)); end "<"; ------------------------------------------------------------------------ function ">=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Pos.Vals(Iter1.Index) >= Iter2.Pos.Vals(Iter2.Index)); end ">="; ------------------------------------------------------------------------ function ">=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) >= Val); end ">="; ------------------------------------------------------------------------ function ">=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val >= Iter.Pos.Vals(Iter.Index)); end ">="; ------------------------------------------------------------------------ function "<=" (Iter1, Iter2 : in Iterator) return Boolean is begin Check_Iterator(Iter1); Check_Iterator(Iter2); return (Iter1.Pos.Vals(Iter1.Index) <= Iter2.Pos.Vals(Iter2.Index)); end "<="; ------------------------------------------------------------------------ function "<=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is begin Check_Iterator(Iter); return (Iter.Pos.Vals(Iter.Index) <= Val); end "<="; ------------------------------------------------------------------------ function "<=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is begin Check_Iterator(Iter); return (Val <= Iter.Pos.Vals(Iter.Index)); end "<="; end Asgc.Btree.DynamicMANAGED;