

--
-- Copyright (C) 2019  <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:  SplayList
--
-- 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.
-- Linear access and traversal of the tree elements according to
-- insertion order [fifo queue] is also supported using
-- the "head" and "next" accessors.
--
-- 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 splaylist 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;
                   List     : in ListType ) return splayptr is
    p: splayptr;
  begin
   if       list.header = null
   or else  list.header.size=0  then
     return null;
   else
    p:=list.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;
                          list: in out listtype;
                          kp: out IdType ) is
    p: splayptr;
  begin
    p := getptr(k,list);
    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; list: in listtype ) 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
          list.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
          list.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  list.header /= null )
   and then  list.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;


  --------------------------------------------------
  -- performs the list-delete pointer manipulations
  -- and disposes the node.
  -- repositions iterator to predecessor
  -- ( successor when deleting the head )
  --------------------------------------------------
  procedure listdel( r: in out splayptr; list: in out listtype ) is
  begin
    if  ( r /= null  and  list.header /= null )  then

      if  r.prev /= null  then     -- not @ head of list
        r.prev.next := r.next;     -- OK even if r=tail (r.next=null)

      else                         -- @ head, so redefine
        list.header.head := r.next;       -- OK even if r=tail (r.next=null)
      end if;

-- note:
-- avoid changing the iterator (curr-pointer)
-- unless we are deleting the very node to which it points...

if r=list.curr then -- 24jul16

      if     r.prev /= null  then  -- not @ head of list
        list.curr := r.prev;       -- set curr=predecessor

      elsif  r.next /= null  then  -- @ head but not @ tail of list
        list.curr := r.next;       -- set curr=successor

      else     -- we are deleting the last element in list.header...
        list.curr := null;         -- we are @ head AND @ tail
      end if;

end if;


      if  r.next /= null  then  -- not @ tail of list
        r.next.prev := r.prev;  -- OK even if r=head (r.prev=null)

      else                      -- @ tail so redefine
        list.header.tail := r.prev;    -- OK even if r=head (r.prev=null)
      end if;

      dispose(r);


    end if;
  end listdel;

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

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

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


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


  ----------------------------------------------
  -- moves current node pointer to previous node
  ----------------------------------------------
  procedure prev ( List : in out ListType;
                   Status :    out StatusType) is
  begin
    Status := empty;
    if        list.header /= null
    and then  list.curr /= null  then
      list.curr := list.curr.prev;
      if  list.curr /= null  then
        Status := OK;
      end if;
    end if;
  end prev;





  ------------------------------------------
  -- moves current node pointer to next node
  ------------------------------------------
  procedure next ( List : in out ListType;
                   Status :    out StatusType) is
  begin
    Status := empty;
    if        list.header /= null
    and then  list.curr /= null  then
      list.curr := list.curr.next;
      if  list.curr /= null  then
        Status := OK;
      end if;
    end if;
  end next;


  ------------------------------------------
  -- moves current node pointer to next node
  -- 11sep18: choose head if list.curr=null
  -- which is now the case, if first call.
  ------------------------------------------
  procedure nextOrHead ( List : in out ListType;
                   Status :    out StatusType) is
  begin
    Status := empty;
	 if list.header /= null then

	 	if list.curr /= null then
			list.curr := list.curr.next;
			if  list.curr /= null  then
			  Status := OK;
			end if;
		else
			list.curr := list.header.head;
			if  list.curr /= null  then
			  Status := OK;
			end if;
		end if;

    end if;
  end nextOrHead;

  --------------------------------------------
  -- sets the iterator to the head of the list
  --------------------------------------------
  procedure head ( List : in out ListType;
                   Status :    out StatusType) is
  begin
    Status := empty;
    if  list.header /= null  then

      list.curr := list.header.head;
      if  list.curr /= null  then
        Status := OK;
      else
        Status := empty;
      end if;

    end if;
  end head;


  --------------------------------------------
  -- sets the iterator to the tail of the list
  --------------------------------------------
  procedure tail ( List : in out ListType;
                   Status :    out StatusType) is
  begin
    Status := empty;
    if  list.header /= null  then

      list.curr := list.header.tail;
      if  list.curr /= null  then
        Status := OK;
      else
        Status := empty;
      end if;

    end if;
  end tail;


  ------------------------------------------------------------
  -- returns the nodal data at the iterator's current position
  ------------------------------------------------------------
  procedure data( List : in ListType;
                  Id   : out IdType;
                  Data : out DataType;
                  Status :    out StatusType) is
  begin
    if        list.header /= null
    and then  list.curr /= null  then
      Id := list.curr.Id;
      Data := list.curr.Data;
      Status := OK;
    else
      Status := empty; 
    end if;
  end data;

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




  ------------------------------------------------
  -- gets the nodal data belonging to specified Id
  ------------------------------------------------
  procedure search( Id       : in IdType;
                     List     : in     ListType;
                     Data     : out DataType;
                     Status :    out StatusType) is
    p: splayptr;
  begin -- search
    p := getptr(Id,List);
    if  p=null  then
      Status := NotFound;
    elsif ( p.Id = Id )  then
      Status := Found;
      Data := p.Data;
      splay(p,list);
    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;
                        List     : in out ListType;
                        Status :    out StatusType) is
    olddata: datatype;  localstatus: StatusType;
  begin -- modifynode
    search(Id,List,olddata,LocalStatus);
    Status := LocalStatus;
    if  LocalStatus=found  then
      list.header.root.data := Data;

      --list.curr:=list.header.root;
		-- note:  do NOT change iterator
		--        when merely accessing data

    end if;
  end modifynode;






  ---------------------------------------
  -- deletes the node with specified Id
  -- repositions iterator to predecessor
  -- ( successor when deleting the head )
  ---------------------------------------
  procedure DelNode( Id     : in IdType;
                     List   : in out ListType;
                     Status :    out StatusType) is
    idnext : IdType;
    d: DataType;
    p,r: splayptr;
    localstatus: statustype;
  begin
   search(Id,list,d,localstatus);
   status := localstatus;
   if  localstatus=found  then
		status:=Ok;
    list.header.size := list.header.size - 1;
    r := list.header.root;
    -- search moved sought cell to root so
    -- the current root is the cell to delete (r.Id=Id)

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

      --list delete and dispose
      listdel( r, list );
    else
      p := list.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,list,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
      list.header.root.left_child := r.left_child;
      if  list.header.root.left_child /= null  then
        list.header.root.left_child.parent := list.header.root;
      end if;

      --list delete and dispose
      listdel( r, list );
    end if;
   end if;
  end delnode;







  ---------------------------------------
  -- 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;
                     List   : in out ListType;
                     Status :    out StatusType) is
    idnext : IdType;
    d: DataType;
    p: splayptr;
	 r: splayptr:=q;
    localstatus: statustype;
	 --pri: integer;
  begin

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

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

	if list.header /=null and then list.header.head /=null then
		if r=list.header.head then
			list.header.head:=r.next;
		end if;
	end if;

	if list.header /=null and then list.header.tail /=null then
		if r=list.header.tail then
			list.header.tail:=r.prev;
		end if;
	end if;



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


      --list delete and dispose
		if r/=null then
      	listdel( r, list );
		end if;

    else
      p := list.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,list,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
      list.header.root.left_child := r.left_child;
      if  list.header.root.left_child /= null  then
        list.header.root.left_child.parent := list.header.root;
      end if;

      --list delete and dispose
		if r/=null then
      	listdel( r, list );
		end if;

    end if;

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

  end delnodeatptr;



  -- delete node @ curr;  reset curr to next
procedure rmNode(
	List   : in out ListType;
	Id   : out IdType;
	Data : out DataType;
	Status :    out StatusType) is
	q: splayptr;
begin
	if  
		list.curr /= null
	then
		status:=Ok;
		q:=list.curr;
		id:=q.id;
		Data := q.Data;

		if list.curr.next /=null then
			list.curr:=list.curr.next;
		else
			list.curr:=list.curr.prev;
		end if;

		delNodeAtPtr(q,list,status);

		if list.curr=null then
			status:=empty;
		end if;
	else
		status:=NilPtr;
	end if;
end rmnode;

procedure make_empty(list: in out listtype; status: out statustype) is
	lstat: statustype;
	id: idtype;
	data: datatype;
begin
	status:=ok;
	if length(list)>0 then
		head(list, lstat);
		while length(list)>0 loop
			rmnode(list,id,data,lstat);
		end loop;
		status:=lstat;
	end if;
end make_empty;





















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

    if  list.header=null  then
      list.header := new listheader;
    end if;

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

    -- list insertion (first node)
    list.header.head := list.header.root;
    list.header.tail := list.header.root;

    list.curr := null; --11sep18 (see nextOrHead)
    --list.curr := list.header.tail;
	 -- note:  we define current pointer ONLY when inserting
	 --        into an empty tree/list

  else
    p:=list.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

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

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

      --add to tail of list (nonempty)
      list.header.tail.next := p;
      p.prev := list.header.tail;
      list.header.tail := p;

      --list.curr := list.header.tail;
		--24jul16 do NOT allow [normal] insertion to
		-- change iterator

    end if;

  end if;

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

end AddNode;








end splaylist;
