-- Copyright (c) 1995/6    John Beidler
--                         Computing Sciences Dept.
--                         Univ. of Scranton, Scranton, PA 18510
--
--                         (717) 941-7446 voice
--                         (717) 941-4250 FAX
--                         beidler@cs.uofs.edu
--
--  For use by non-profit educational institutions only.
--  This software is GUARANTEED.  Please report any errors.  All
--  corrections will be made as soon as possible (normally within
--  one working day).
------------------------------------------------------------------
-- Assertion notation:
-- /=  not equal
-- {}  empty tree
-- ,   and
-- |   or
-- (child,root,sibling)  represents a tree with the object "root" as the
--     root of the tree and "child" and "sibling" are the first child subtree
--     and next sibling subtree, respectively, of the root.  child or sibling
--     may be empty.  root is Object_Type.
-- '   If x passed as argument then x' is result after subprog executes
------------------------------------------------------------------
with Ada.Finalization; use Ada.Finalization;

package Tree_Nary_Polymorphic_Cntl is

type Place_Holder is new controlled with private;
   procedure Initialize (Object: in out Place_Holder);
   procedure Finalize (Object: in out Place_Holder);
   procedure Adjust (Object: in out Place_Holder);
   -------------------------------------------------------------
   -- When extending Place_Holder type the client must provide
   -- Initialize, Finalize, and Adjust procedures for the extended
   -- type UNLESS the extension is bound AND an aggregate is used
   -- to initialize the components in the extension
   -------------------------------------------------------------

type Holder_Class_Ptr is access Place_Holder'Class;
   procedure Recycle (Point: in out Holder_Class_Ptr);

type Tree_Type is new controlled with private;
   procedure Initialize (Tree: in out Tree_Type);
   procedure Finalize (Tree: in out Tree_Type);
   procedure Adjust (Tree: in out Tree_Type);

   Tree_Underflow   : exception;
   Tree_Overflow    : exception;
   Root_Exists      : exception;

function Empty (Tree: Tree_Type) return boolean;
   -----------------------------------------------------
   -- returns Tree = ()?
   -----------------------------------------------------

function Empty_Tree return Tree_Type;
   -----------------------------------------------------
   -- PostCond: returns ()
   -----------------------------------------------------

generic
   type Extended_Type is new Place_Holder with private;
function g_Root_Of (Tree: Tree_Type) return Extended_Type;

function Root_Of (Tree: Tree_Type) return Holder_Class_Ptr;
   -----------------------------------------------------
   -- PreCond:  Tree = (child, root, sibling), Tree /= ()
   -- returns root
   -----------------------------------------------------

procedure Graft (Object: in out Place_Holder'Class;
                 Tree  : in     Tree_Type );
   -----------------------------------------------------
   -- Pre Cond: Tree = ()
   -- PostCond: Tree' = ((), Object, ())
   -- Exception: Invalid_Position, Invalid_Graft,
   --            Tree_Overflow
   -- NOTE:   Swap used to exchange value of Place_Holder'Class
   -----------------------------------------------------

procedure Graft (Subtree: in     Tree_Type;
                 Tree   : in     Tree_Type);
   -----------------------------------------------------
   -- Pre Cond: Tree = ()
   -- PostCond: Tree' = Subtree, Subtree' = ()
   -- Exception: Invalid_Position, Invalid_Graft, Tree_Overflow
   -----------------------------------------------------

procedure Prune (Tree   : in     Tree_Type;
                 Subtree: in out Tree_Type);
   -----------------------------------------------------
   -- Pre Cond:
   -- PostCond: Tree' = (), Subtree' = Tree
   -- Exception: Invalid_Position
   -----------------------------------------------------

function Child_Subtree (Tree: Tree_Type) return Tree_Type;
   -----------------------------------------------------
   -- Pre Cond: Tree = (child, r, sibling)
   -- PostCond: Returns child
   -- Exception: Tree_Underflow, Invalid_Position
   -- SideEffect: child can only be recursively processed
   -----------------------------------------------------

function Sibling_Subtree (Tree: Tree_Type) return Tree_Type;
   -----------------------------------------------------
   -- Pre Cond: Tree = (child, r, sibling)
   -- PostCond: Returns sibling
   -- Exception: Tree_Underflow, Invalid_Position
   -- SideEffect: sibling can only be recursively processed
   -----------------------------------------------------

procedure Update_Root (Tree  : in     Tree_Type;
                       Object: in out Place_Holder'Class);
   -----------------------------------------------------
   -- Pre Cond: Tree = (child, root, sibling)
   -- PostCond: Tree' = (child, Object, sibling)
   -- Exception: Invalid_Position
   -- NOTE:   Swap used to exchange value of Place_Holder'Class
   -----------------------------------------------------

procedure Swap (Source: in out Tree_Type;
                Target: in out Tree_Type);
   -----------------------------------------------------
   -- Pre Cond: None
   -- PostCond: Target' = Source, Source' = Target
   -- Exception: None
   -----------------------------------------------------

private

type Place_Holder is new controlled with
   record
      Child_Node : aliased Holder_Class_Ptr := null;
      Sibling_Node: aliased Holder_Class_Ptr := null;
   end record;
type Tree_Anchor is access all Holder_Class_Ptr;

type Tree_Type is new controlled with
   record
      Anchor: Tree_Anchor;
      Base  : boolean := true;
   end record;

end Tree_Nary_Polymorphic_Cntl;