

--
-- 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:  splaypq
--
-- New version with added priority field that allows:
-- a) random access by unique key value, just as before;
-- b) sequential access by an integer-valued priority field
--    that allows duplicates, with the typical properties
--    of a Priority Queue.
--    Equal priorities are inserted AFTER others using AddNode2.
--
-- 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; --debug only
with Unchecked_Deallocation;

package body splaypq0 is


  procedure dispose is new unchecked_deallocation(splayrec,splayptr);
  procedure dispose is new unchecked_deallocation(hashnode,hashptr);



	procedure myassert( 
		condition : boolean;  
		flag: integer:=0;
		msg: string := ""
		) is
		use text_io;
	begin
	  if condition=false then
			put("ASSERTION Failed!  ");
			if flag /= 0 then
				put( "@ " & integer'image(flag) &" : " );
			end if;
			put_line(msg);
			new_line;
			raise program_error;
	  end if;
	end myassert;



  -----------------------------------------------------
  --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;


--------- 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;




  ------------------------------------------------
  -- gets the nodal data belonging to specified Id;
  -- in the process, we splay, bringing Id to root.
  ------------------------------------------------
  procedure search( Id       : in IdType;
                     List     : in     ListType;
                     Data     : out DataType;
							pri : out integer;
                     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;
		pri := p.priority;
      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
  -- No change to priority.
  ------------------------------------------
  procedure ModifyNode( Id       : in IdType;
                        Data     : in DataType;
                        List     : in out ListType;
                        Status :    out StatusType) is
    olddata: datatype;  localstatus: StatusType;
	 pri: integer;
  begin -- modifynode
    search(Id,List,olddata,pri,LocalStatus);
    Status := LocalStatus;
    if  LocalStatus=found  then
      list.header.root.data := Data;
    end if;
  end modifynode;











  ---------------------------------------
  -- deletes the node with specified Id
  -- Any action to curr ptr, or other
  -- list links 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
	use text_io;
    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.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
			dispose(r);
		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,pri,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
      	dispose(r);
		end if;

    end if;

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

  end delnodeatptr;




--debug only:
function find(
	list: listtype;
	thishash: hashptr;
	k: out p1range;
	j: out integer
	) return boolean is
	found: boolean:=false;
	h: hashptr;
begin
	for i in p1range loop
		h:=list.header.hash(i);
		k:=i;
		j:=0;
		while h/=null and then h/=thishash loop
			h:=h.hnext;
			j:=j+1;
		end loop;
		exit when h=thishash;
	end loop;
	return h=thishash;
end find;

procedure unhook(
	list: in out listtype; 
	thishash: hashptr;
	pri: p1range) is
	prevh,nexth: hashptr;
	use text_io;
begin
		nexth:=thishash.hnext; --possibly null
		prevh:=thishash.hprev; --possibly null
		if prevh = null then --head of hash(pri) list
--myassert(list.header.hash(pri)=thishash,99,"unhook.378");
			list.header.hash(pri):=nexth;
		else
			prevh.hnext := nexth;
		end if;
		if nexth /= null then
			nexth.hprev := prevh;
		end if;
end unhook;


--Push "thishash" onto the head of the hash(pri) list
procedure push(
	list:in out listtype; 
	thishash: hashptr; 
	pri: p1range) is
	r: hashptr;
begin

-- insert thishash into different doubly linked list @head:
	r:=list.header.hash(pri); --may be null
	thishash.hnext:=r;
	thishash.hprev:=null; --head flag
	if r/=null then
		r.hprev := thishash; -- r becomes 2nd item
	end if;
	list.header.hash(pri):=thishash; --new node becomes 1st

end push;

procedure bumpKey(
		List   : in out ListType;
		Id   : IdType;
		data : datatype;
		nupri  : p1range;
		Status :    out StatusType) is

	thishash: hashptr;
	thissplay: splayptr;
	opri: p1range;
	use text_io;
begin

	thissplay := getptr(Id,List);
	if thissplay=null then
		status:=notfound;
	else
		status:=Ok;

		thishash:=thissplay.hptr;
		opri:=thissplay.priority;

		unhook(list,thishash,opri);
		push(list,thishash,nupri);

		thissplay.data := data; --updated totpulz, etc
		thissplay.priority:=nupri;

	end if;

end bumpkey;






  -- delete node @ specified key
procedure rmKey(
	List   : in out ListType;
	Id   : IdType;
	Status :    out StatusType) is
	use text_io;
	pri: p1range;

	thishash: hashptr;
	thissplay: splayptr;
begin
	thissplay := getptr(Id,List);
	if thissplay=null then
		status:=notfound;
	else
		status:=Ok;
		thishash:=thissplay.hptr;
		pri:=thissplay.priority;

		-- before deleting thishash I need to unhook it
		unhook(list,thishash,pri);

		dispose(thishash);

		delNodeAtPtr(thissplay,list,status);

	end if;
end rmkey;


procedure popNode(
	List   : in out ListType;
	Id   : out IdType;
	Data : out DataType;
	pri  : out integer;
	Status :    out StatusType) is
	thishash: hashptr:=null;
	thissplay: splayptr:=null;
	use text_io;
	quit: boolean := false;
begin

	if 
		list.header/= null
		and then
		list.header.size>0
	then
		status:=Ok;

		for i in p1range loop
			thishash := list.header.hash(i);
			if 
				thishash/=null
				--and then thishash.down/=null
				--and then thishash.down.hptr=thishash
			then
				thissplay:= thishash.down; --splayptr to pop
				list.header.hash(i):=thishash.hnext; --maybe null
				if thishash.hnext /= null then
					thishash.hnext.hprev:=null;
				end if;
				exit;
			end if;
		end loop; -- for i

myassert(thissplay/=null, 59990, "splaypq::536");

		id   := thissplay.id;
		pri  := integer(thissplay.priority);
		Data := thissplay.Data;

		dispose(thishash); -- the hashptr

		delNodeAtPtr(thissplay,list,status); -- the splayptr

	else
		status:=NilPtr;
	end if;

end popnode;




--see what's next in priority queue:
procedure peekNode(
	List   : in out ListType;
	Id   : out IdType;
	Data : out DataType;
	pri  : out integer;
	Status :    out StatusType) is
	thishash: hashptr;
	thissplay: splayptr;
	use text_io;
	quit: boolean := false;
begin

	if 
		list.header/= null
		and then
		list.header.size>0
	then
		status:=Ok;

		for i in p1range loop
			thishash := list.header.hash(i);
			if 
				thishash/=null
				--and then thishash.down/=null
				--and then thishash.down.hptr=thishash
			then
				thissplay := thishash.down; --node to pop
				exit;
			end if;
		end loop; -- for i

myassert(thissplay/=null, 59995, "splaypq::587");
		--if thissplay=null then
		--	status:=nilptr;
		--else
			id   := thissplay.id;
			pri  := integer(thissplay.priority);
			Data := thissplay.Data;
		--end if;

	else
		status:=NilPtr;
	end if;

end peeknode;













----------------------------------------------------
-- inserts into random access splaytree by unique Id
-- AND into queue by integer priority BEHIND
-- others of equal priority.
---------------------------------------
procedure AddNode( Id     : in IdType;
                   Data   : in DataType;
						 pri    : in p1range;
                   List   : in out ListType;
                   Status :    out StatusType) is

  p,q:splayptr;  bok: boolean := true;
  use text_io;
  found: boolean := false;
  nuhptr: hashptr;
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,
	 	pri, null,null,null, null );

--======================================================================
-- now we deal with list structure...insert node in priority order
--======================================================================

		--load very 1st elt into hash array
		nuhptr := new hashnode;
		nuhptr.down:= list.header.root;
		nuhptr.hnext:=null;
		nuhptr.hprev:=null;
		list.header.hash(pri):=nuhptr;

		list.header.root.hptr := nuhptr;



  else --already 1 or more nodes in splaytree

    p:=list.header.root;
    search_loop:
    loop --search by Id
      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 -- this is a new unique Id [key]...insert it
      list.header.size := list.header.size + 1;
      p := new splayrec'(Id,data,pri, q, null,null, null); --q:=parent
      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


--======================================================================
-- now we deal with list structure...insert node @ head of hashlist
--======================================================================

		nuhptr := new hashnode;
		nuhptr.down:=p;
		p.hptr := nuhptr; --ptr from new splayrec to hashnode

		push(list,nuhptr,pri); --put onto head of hash(pri) list



    end if; -- bok

  end if; -- one or more nodes already in splaytree


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


end AddNode;

















-- prepare for reuse:
procedure make_empty(list: in out listtype; status: out statustype) is
	lstat: statustype;
	id: idtype;
	data: datatype;
	pri: integer;
begin
	status:=ok;
	while length(list)>0 loop
		popnode(list,id,data,pri,lstat);
	end loop;
	if lstat=NilPtr and length(list)>0 then
		raise program_error;
	end if;
	status:=empty;
end make_empty;




end splaypq0;
