with Unchecked_Deallocation; --, text_io;

package body Tree_Nary_Polymorphic_Cntl is
   procedure Free is new Unchecked_Deallocation (Place_Holder'Class, Holder_Class_Ptr);
   procedure Free is new Unchecked_Deallocation (Holder_Class_Ptr, Tree_Anchor);
   procedure Recycle (Point: in out Holder_Class_Ptr) renames Free;

procedure Initialize (Object: in out Place_Holder) is
   begin -- Initialize
      null;
   end Initialize;
   -----------------------------------------------------
procedure Finalize (Object: in out Place_Holder) is
   begin -- Finalize
      null;
   end Finalize;
   -----------------------------------------------------
procedure Adjust (Object: in out Place_Holder) is
   begin -- Adjust
      null;
   end Adjust;
   -----------------------------------------------------

procedure Initialize (Tree: in out Tree_Type) is
   begin -- Initialize
      Tree.Anchor    := new Holder_Class_Ptr;
      Tree.Anchor.all:= null;
      Tree.Base      := true;
   end Initialize;
   -----------------------------------------------------
procedure Erase_Subtree (Tree_Ptr: in out Holder_Class_Ptr) is
   begin -- Erase_Subtree
      if Tree_Ptr /= null then
          Erase_Subtree (Tree_Ptr.Child_Node);
          Erase_Subtree (Tree_Ptr.Sibling_Node);
          Free (Tree_Ptr);
      end if;
   end Erase_Subtree;
   --------------------------------------------------
procedure Finalize (Tree: in out Tree_Type) is
   begin -- Finalize
   if Tree.Base then
      Erase_Subtree (Tree.Anchor.all);
      Free (Tree.Anchor);
   end if;
   end Finalize;
   -------------------------------------------------------
procedure Adjust (Tree: in out Tree_Type) is
   Original: Holder_Class_Ptr := Tree.Anchor.all;
   procedure Clone (Srce, Trgt: in out Holder_Class_Ptr) is
      begin -- Clone
         if Srce /= null then
             Trgt := new Place_Holder'Class'(Srce.all);
             Clone (Srce.Child_Node, Trgt.Child_Node);
             Clone (Srce.Sibling_Node, Trgt.Sibling_Node);
         end if;
      end Clone;
      ----------------------------------------------------
   begin -- Adjust
      Tree.Anchor.all := null;
      Clone (Original, Tree.Anchor.all);
   end Adjust;
   -------------------------------------------------------
function Empty (Tree: Tree_Type) return boolean is
   begin
      return Tree.Anchor.all = null;
   end Empty;
   -------------------------------------------------------
function Empty_Tree return Tree_Type is
   Answer: Tree_Type;
   begin -- Empty_Tree
      return Answer;
   end Empty_Tree;
   -------------------------------------------------------
function g_Root_Of (Tree: Tree_Type) return Extended_Type is
   begin -- g_Root_Of
      return Extended_Type(Root_Of(Tree).all);
   end g_Root_Of;
   -------------------------------------------------------
function Root_Of (Tree: Tree_Type) return Holder_Class_Ptr is
   begin -- Root_Of
      if Tree.Anchor.all = null then
          raise Tree_Underflow;
        else
          return new Place_Holder'Class'(tree.Anchor.all.all);
      end if;
   end Root_Of;
   -------------------------------------------------------
procedure Graft (Object: in out Place_Holder'Class;
                 Tree  : in     Tree_Type ) is
   New_Node: Holder_Class_Ptr:= new Place_Holder'Class'(Object);
   begin -- Graft
      New_Node.Child_Node  := null;
      New_Node.Sibling_Node:= Tree.Anchor.all;
      Tree.Anchor.all      := New_Node;
   exception
      when storage_error => raise Tree_Overflow;
   end Graft;
   -------------------------------------------------------
procedure Graft (Subtree: in     Tree_Type;
                 Tree   : in     Tree_Type) is
   procedure Rec_Attach (This, That : in out Holder_Class_Ptr) is
      begin -- Rec_Attach
         If That = null then
             That := This;
           else -- bush being attached
             Rec_Attach (This, That.Sibling_Node);
         end if;
      end Rec_Attach;
      ----------------------------------------------------
   begin -- Graft
      if not empty (SubTree) then
          Rec_Attach (Tree.Anchor.all, Subtree.Anchor.all.Sibling_Node);
          Tree.Anchor.all   := Subtree.Anchor.all;
          Subtree.Anchor.all:= null;
      end if;
   end Graft;
   -------------------------------------------------------
procedure Prune (Tree   : in     Tree_Type;
                 Subtree: in out Tree_Type) is
   begin -- Prune
      Subtree := Empty_Tree;
      if not Empty (Tree) then
          SubTree.Anchor.all:= Tree.Anchor.all;
          Tree.Anchor.all   := Tree.Anchor.all.Sibling_Node;
          Subtree.Anchor.all.Sibling_Node := null;
      end if;
   end Prune;
   -----------------------------------------------------
function Child_Subtree (Tree: Tree_Type) return Tree_Type is
   Answer: Tree_Type;
   begin -- Child_Subtree
      if Tree.Anchor.all = null then
          raise Tree_Underflow;
        else
          Answer.Anchor:= Tree.Anchor.all.Child_Node'Access;
          Answer.Base  := false;
          return Answer;
      end if;
   end Child_Subtree;
   -------------------------------------------------------
function Sibling_Subtree (Tree: Tree_Type) return Tree_Type is
   Answer: Tree_Type;
   begin -- Sibling_Subtree
      if Tree.Anchor.all = null then
          raise Tree_Underflow;
        else
          Answer.Anchor:= Tree.Anchor.all.Sibling_Node'Access;
          Answer.Base  := false;
          return Answer;
      end if;
   end Sibling_Subtree;
   -------------------------------------------------------
procedure Update_Root (Tree  : in     Tree_Type;
                       Object: in out Place_Holder'Class) is
   New_Node: Holder_Class_Ptr:= new Place_Holder'Class'(Object);
   begin -- Process_Root
      if Tree.Anchor.all = null then
          raise Tree_Underflow;
        else
          New_Node.Child_Node  := Tree.Anchor.all.Child_Node;
          New_Node.Sibling_Node:= Tree.Anchor.all.Sibling_Node;
          Free (Tree.Anchor.all);
          Tree.Anchor.all:= New_Node;
      end if;
   end Update_Root;
   -------------------------------------------------------
procedure Swap (Source: in out Tree_Type;
                Target: in out Tree_Type) is
   Temp: Holder_Class_Ptr;
   begin
      Temp             := Target.Anchor.all;
      Target.Anchor.all:= Source.Anchor.all;
      Source.Anchor.all:= Temp;
   end Swap;
   -------------------------------------------------------

end Tree_Nary_Polymorphic_Cntl;