

--
-- Copyright (C) 2021  <fastrgv@gmail.com>
--
-- This program 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 3 of the License, or
-- (at your option) any later version.
--
-- This program 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 may read the full text of the GNU General Public License
-- at <http://www.gnu.org/licenses/>.
--



--
--*****************************************************************
--
-- Package Name:  Splaytree
--
-- This package implements an extremely efficient self-adjusting
-- binary search tree called a splay tree with very little overhead
-- to maintain the balance.  The ordering by IdType is maintained
-- to permit fast access by Id and fast checks for duplicates.
--
-- Reference:
-- See the Journal of the A.C.M., July 1985,
-- Vol. 32, No. 3, pg. 652, library call # QA 76 A77
--
--*************************************************************************

with text_io;
with Unchecked_Deallocation;

package body splaytree is


  procedure dispose is new unchecked_deallocation(splayrec,splayptr);




  -----------------------------------------------------
  --without changing tree structure this searches for
  --the node pointer for Id;  returns null if not found
  -----------------------------------------------------
  function getptr( Id       : in IdType;
                   tree     : in treeType ) return splayptr is
    p: splayptr;
  begin
   if       tree.header = null
   or else  tree.header.size=0  then
     return null;
   else
    p:=tree.header.root;
    while( p /= null ) and then ( p.Id /= Id ) loop
      if  Id < p.Id  then
        p:=p.left_child;
      else
        p:=p.right_child;
      end if;
    end loop;
    return p;
   end if;
  end getptr;


   -- temporary routine for debugging purposes only;
   -- allows users to deduce the tree's structure
  procedure GetParentKey( k: IdType;
                          tree: in out treetype;
                          kp: out IdType ) is
    p: splayptr;
  begin
    p := getptr(k,tree);
    if( p /= null ) and then ( p.Id = k )  then
      if  p.parent /= null  then
        kp := p.parent.Id;
      else
        kp := k;
      end if;
    end if;
  end getparentkey;



  --------------------------------------
  -- the main balancing mechanism...
  -- see "splay trees" in the literature.
  -- Careful, only experts should attempt
  -- modifying this routine.
  ----------------------------------------------
  procedure splay( p: in out splayptr; tree: in treetype ) is
    q,r: splayptr;

    procedure rotate( thisnode: in out splayptr ) is
      dad,son,grandad:splayptr;
    begin
      dad := thisnode.parent;
      if dad = null then
        raise constraint_error;
      end if;
      grandad:=dad.parent;

      if  thisnode = dad.left_child  then
        son:=thisnode.right_child;
        thisnode.right_child := dad;
        thisnode.parent := grandad;
        dad.parent:=thisnode;
        dad.left_child := son;
        if  son /= null  then
          son.parent := dad;
        end if;
        if  grandad=null  then  --dad was old root
          tree.header.root:=thisnode;
        else -- grandad /= null
          if  grandad.right_child=dad  then
             grandad.right_child:=thisnode;
          elsif  grandad.left_child=dad  then
             grandad.left_child:=thisnode;
          else
            raise constraint_error;
          end if;
        end if;
      elsif  thisnode = dad.right_child  then
        son:=thisnode.left_child;
        thisnode.left_child := dad;
        thisnode.parent := grandad;
        dad.parent := thisnode;
        dad.right_child := son;
        if  son /= null  then
          son.parent := dad;
        end if;
        if  grandad=null  then  --dad was old root
          tree.header.root:=thisnode;
        else
          if  grandad.right_child=dad  then
             grandad.right_child:=thisnode;
          elsif  grandad.left_child=dad  then
             grandad.left_child:=thisnode;
          else
             raise constraint_error;
          end if;
        end if;
      else
        raise constraint_error;
      end if;
    end rotate;

  begin  -- splay
   if  ( p /= null  and  tree.header /= null )
   and then  tree.header.size>0
   then
    while  p.parent /= null  loop
      q:=p.parent;
      if  q.parent = null  then -- q is root
        rotate(p);
      else -- q is not root
        r:=q.parent;
        if ( ( q=r.left_child  ) and ( p=q.left_child  ) )
        or ( ( q=r.right_child ) and ( p=q.right_child ) )
        then -- ZIG-ZIG
          rotate(q);
          rotate(p);
        elsif ( ( q=r.left_child  ) and ( p=q.right_child ) )
        or    ( ( q=r.right_child ) and ( p=q.left_child  ) )
        then  -- ZIG-ZAG
          rotate(p);
          rotate(p);
        else
          raise constraint_error; --logically impossible
        end if;
      end if;
    end loop;
   end if;
  end splay;



--------- end of utility routines ------------------------

----------- begin main body ------------------------------

  ------------------------------------------
  -- returns the number of nodes in the tree
  ------------------------------------------
  function length( tree: in treeType ) return integer is
  begin
    if       tree.header = null
    or else  tree.header.size=0  then
      return 0;
    else
      return tree.header.size;
    end if;
  end length;


----- begin pure tree operations that do NOT affect tree structure ------

----- end pure tree operations that do NOT affect tree structure ------




  ------------------------------------------------
  -- gets the nodal data belonging to specified Id
  ------------------------------------------------
  procedure search( Id       : in IdType;
                     tree     : in     treeType;
                     Data     : out DataType;
                     Status :    out StatusType) is
    p: splayptr;
  begin -- search
    p := getptr(Id,tree);
    if  p=null  then
      Status := NotFound;
    elsif ( p.Id = Id )  then
      Status := Found;
      Data := p.Data;
      splay(p,tree);
    else
      Status := NotFound;  --impossible branch!
    end if;
    -- pure implementations always splay at the
    -- last non-null node visited, even on failure !

  end search;







  ------------------------------------------
  -- modifies the nodal data at specified Id
  ------------------------------------------
  procedure ModifyNode( Id       : in IdType;
                        Data     : in DataType;
                        tree     : in out treeType;
                        Status :    out StatusType) is
    olddata: datatype;  localstatus: StatusType;
  begin -- modifynode
    search(Id,tree,olddata,LocalStatus);
    Status := LocalStatus;
    if  LocalStatus=found  then
      tree.header.root.data := Data;
    end if;
  end modifynode;








  ---------------------------------------
  -- deletes the node with specified Id
  -- Any action to curr ptr MUST be
  -- accomplished BEFORE calling this.
  -- This proc avoids changing curr ptr.
  ---------------------------------------
  procedure DelNodeAtPtr( q     : in splayptr;
                     tree   : in out treeType;
                     Status :    out StatusType) is
    idnext : IdType;
    d: DataType;
    p: splayptr;
	 r: splayptr:=q;
    localstatus: statustype;
  begin

  	splay(r,tree); --moves r to root

	status:=Ok;
   tree.header.size := tree.header.size - 1;


    if  tree.header.root.right_child=null  then
      -- tree deletion is easy
      tree.header.root := tree.header.root.left_child;
      if  tree.header.root /= null  then
        tree.header.root.parent := null;
      end if;

		if r/=null then
			dispose(r);
		end if;

    else
      p := tree.header.root.right_child;

      while ( p.left_child /= null )  loop
         p:=p.left_child;
      end loop;
      idnext := p.Id; --immediate successor to Id
      search(idnext,tree,d,localstatus);
      if  localstatus /= found  then
        raise program_error; --should never happen!
      end if;
      -- at this point r is the leftson of its successor (which is
      -- now at the root) and, therefore, has no rightson itself
      tree.header.root.left_child := r.left_child;
      if  tree.header.root.left_child /= null  then
        tree.header.root.left_child.parent := tree.header.root;
      end if;

		if r/=null then
			dispose(r);
		end if;

    end if;

	if tree.header.size<1 then
		tree.header:=null;
		status:=empty;
	end if;

  end delnodeatptr;




   procedure DelNode( Id     : in IdType;
                      tree   : in out treeType;
                      Status :    out StatusType) is
		p: splayptr;
	begin
    p := getptr(Id,tree);
	 delNodeAtPtr(p,tree,status);
	end delnode;






	procedure make_empty(tree: in out treetype; status: out statustype) is
		lstat: statustype;
		p: splayptr;
	begin
		status:=ok;
		while length(tree)>0 loop
			p := tree.header.root;
			delNodeAtPtr(p,tree,lstat);
		end loop;

		if lstat=NilPtr and length(tree)>0 then
			raise program_error;
		end if;
		status:=empty;
	end make_empty;





















---------------------------------------
-- adds node to tail of tree
-- (and inserts into splaytree by Id)
---------------------------------------
procedure AddNode( Id     : in IdType;
                   Data   : in DataType;
                   tree   : in out treeType;
                   Status :    out StatusType) is
  p,q:splayptr;  bok: boolean := true;
begin
  Status := Ok;
  if  tree.header=null
  or else  tree.header.size=0  then  --empty tree (tree)

    if  tree.header=null  then
      tree.header := new treeheader;
    end if;

    tree.header.size := 1;
    --tree.header.root := new splayrec'(Id,data,null,null,null,null,null);
    tree.header.root := new splayrec'(Id,data,null,null,null);

  else
    p:=tree.header.root;
    search_loop:
    loop
      exit search_loop when p=null;
      q:=p;
      if( Id < p.Id ) then
        p:=p.left_child;
      elsif  Id > p.Id  then
        p:=p.right_child;
      else  -- Id=p.Id...duplicate Id!
        status := dupid;
        bok := false;
        exit search_loop;
      end if;
    end loop search_loop;
    -- q is parent-to-be

    if  bok  then

      tree.header.size := tree.header.size + 1;
      --p := new splayrec'(Id,data,q,null,null,null,null);
      p := new splayrec'(Id,data,q,null,null);
      if  Id < q.Id  then
        q.left_child  := p;
      else
        q.right_child := p;
      end if;

      splay(p,tree);  --26 jul 94 (expedites subsequent calls to addnode)
      -- tree operations complete

    end if;

  end if;

exception
	when storage_error =>
		text_io.put_line("AddNode memory maximum reached");
		raise;

end AddNode;




function getsize return integer is
begin
	return splayrec'size;
end getsize;


function getalignment return integer is
begin
	return splayrec'alignment;
end getalignment;



end splaytree;
