

--
-- 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/>.
--


-- Sokoban Reverse-BFS solver : 
-- a brute-force breadth-first-search in reverse
--
-- ipuller3...
-- adjustable uni-dir-inertia for pulls;
-- uni-dir-inertia for non-pulls, 
-- but no saving in tunnels, unless on puller-goal;
--
-- Puller-centric version... (good for small,dense puzzles)
-- chooses puller direction {no,so,ea,we} to try
-- and then whether or not to pull any adjacent box.
--
-- An article by Frank Takes shows clear advantages to working from
-- a solved position backwards to the start position, which prevents
-- deadlocked positions from taking up space in the search tree.
-- I am aware that puller-deadlocks are still possible, but they are
-- less problematic because they self-terminate fairly quickly in a BFS.
--
-- This version attempts to detect tunnels
-- and avoids placing configs onto the priority queue that represent
-- partial traversals thru them.  The only exceptions are a) if pulling
-- and the box lands on a box-target;  b) if the puller lands on a
-- puller-target = initial pusher position.
--
-- Uses a splaytree, to test whether a given config was seen before.  
-- Extremely fast access, but can only solve relatively small puzzles
-- due to memory constraints.
--
-- Uses a fullproof Key-type, for which we must define
-- operators "<" and ">".








with system;
with splaylist;
with text_io;

with ada.characters.handling;
with ada.strings.fixed;

with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO;

with ada.command_line;
with ada.calendar;
with emutils;




procedure iplr3r is


	use ada.characters.handling;
	use Ada.Strings.Unbounded;
	use Ada.Strings.Unbounded.Text_IO;

	use text_io;
	use emutils;
	use mysplaylist; -- emutils

	onestep, userexit: boolean := false;
	solutionPath: unbounded_string;
	pr,pc, relenting: ushort;


--///////////////////////////////////////////////////////////////////////
-- the following 8 procs all attempt to exit "tunnels" prior to saving,
-- where "tunnel" means turns are not possible:
--///////////////////////////////////////////////////////////////////////

procedure moveup(okey: keytype; olp,olm: ushort) is -- without pulling
	moves: ushort := 0;
begin
	pr:=pr-1;
	moves:=1;
	while 
		ptestup(pr,pc) and -- moving again is possible
		not ptestright(pr,pc) and not ptestleft(pr,pc) and -- in tunnel
		(pr/=gpr or pc/=gpc) -- not @ puller-goal
	loop 
		pr:=pr-1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,0,pr,pc,olp,olm,0,moves);
end moveup;

-- only called if ptestup=true (initially):
procedure pullup(okey: keytype; olp,olm: ushort;  changed: out boolean) is
	boxmoves: ushort := 0;
	ip,ib: ushort;
begin
	changed:=false;
	if vf(indx(pr+1,pc))=1 then -- box to pull
		changed:=true;
		loop
			vf(indx(pr+1,pc)):=0;
			vf(indx(pr,pc)):=1;
			pr:=pr-1;
			boxmoves:=boxmoves+1;
			ib:=indx(pr+1,pc); --box index
			ip:=indx(pr,pc);

-- note: enexus>bnexus>nexus>revGoal(ff=2)

			exit when not ptestup(pr,pc);        --puller blocked
			exit when bnexus(ib); -- Bvalid+Enexus
			--exit when enexus( ip ); --key puller pos
			exit when not vtunl(ip);
			exit when pr=gpr and pc=gpc; --puller on puller goal
			exit when onestep;

		end loop;
		psaveifnew(okey,0,pr,pc,olp,olm,boxmoves,boxmoves);
	end if;
end pullup;








procedure movedown(okey: keytype; olp,olm: ushort) is -- without pulling
	moves: ushort := 0;
begin
	pr:=pr+1;
	moves:=1;
	while 
		ptestdown(pr,pc) and 
		not ptestright(pr,pc) and 
		not ptestleft(pr,pc) and
		(pr/=gpr or pc/=gpc) 
	loop 
		pr:=pr+1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,1,pr,pc,olp,olm,0,moves);
end movedown;

-- only called if testdown=true
procedure pulldown(okey: keytype; olp,olm: ushort;  changed: out boolean) is
	boxmoves: ushort := 0;
	ip,ib: ushort;
begin
	changed:=false;
	if vf(indx(pr-1,pc))=1 then -- box to pull
		changed:=true;
		loop
			vf(indx(pr-1,pc)):=0;
			vf(indx(pr,pc)):=1;
			pr:=pr+1;
			boxmoves:=boxmoves+1;
			ib:=indx(pr-1,pc); --box index
			ip:=indx(pr,pc);

			exit when not ptestdown(pr,pc);
			exit when bnexus(ib); -- Bvalid+Enexus
			--exit when enexus( ip ); --key puller pos
			exit when not vtunl(ip);
			exit when pr=gpr and pc=gpc; --puller on puller goal
			exit when onestep;


		end loop;
		psaveifnew(okey,1,pr,pc,olp,olm,boxmoves,boxmoves);
	end if;
end pulldown;







procedure moveleft(okey: keytype; olp,olm: ushort) is -- without pulling
	moves: ushort := 0;
begin
	pc:=pc-1;
	moves:=1;
	while 
		ptestleft(pr,pc) and 
		not ptestup(pr,pc) and 
		not ptestdown(pr,pc) and
		(pr/=gpr or pc/=gpc) 
	loop 
		pc:=pc-1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,3,pr,pc,olp,olm,0,moves);
end moveleft;

-- only called when testleft=true
procedure pullleft(okey: keytype; olp,olm: ushort;  changed: out boolean) is
	boxmoves: ushort := 0;
	ip,ib: ushort;
begin
	changed:=false;
	if vf(indx(pr,pc+1))=1 then -- box to pull
		changed:=true;
		loop
			vf(indx(pr,pc+1)):=0;
			vf(indx(pr,pc)):=1;
			pc:=pc-1;
			boxmoves:=boxmoves+1;
			ib:=indx(pr,pc+1); --box index
			ip:=indx(pr,pc);

			exit when not ptestleft(pr,pc);
			exit when bnexus(ib); -- Bvalid+Enexus
			--exit when enexus( ip ); --key puller pos
			exit when not htunl(ip);
			exit when pr=gpr and pc=gpc; --puller on puller goal
			exit when onestep;


		end loop;
		psaveifnew(okey,3,pr,pc,olp,olm,boxmoves,boxmoves);
	end if;
end pullleft;






procedure moveright(okey: keytype; olp,olm: ushort) is -- without pulling
	moves: ushort := 0;
begin
	pc:=pc+1;
	moves:=1;
	while 
		ptestright(pr,pc) and 
		not ptestup(pr,pc) and 
		not ptestdown(pr,pc) and
		(pr/=gpr or pc/=gpc) 
	loop 
		pc:=pc+1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,2,pr,pc,olp,olm,0,moves);
end moveright;

-- only called when testright=true
procedure pullright(okey: keytype; olp,olm: ushort; changed: out boolean) is
	boxmoves: ushort := 0;
	ip,ib: ushort;
begin
	changed:=false;
	if vf(indx(pr,pc-1))=1 then -- box to pull
		changed:=true;
		loop
			vf(indx(pr,pc-1)):=0;
			vf(indx(pr,pc)):=1;
			pc:=pc+1;
			boxmoves:=boxmoves+1;
			ib:=indx(pr,pc-1); --box index
			ip:=indx(pr,pc);

			exit when not ptestright(pr,pc);
			exit when bnexus(ib); -- Bvalid+Enexus
			--exit when enexus( ip ); --key puller pos
			exit when not htunl(ip);
			exit when pr=gpr and pc=gpc; --puller on puller goal
			exit when onestep;


		end loop;
		psaveifnew(okey,2,pr,pc,olp,olm,boxmoves,boxmoves);
	end if;
end pullright;








	function itrim( i: integer ) return string is
	begin
		return ada.strings.fixed.trim( integer'image(i), ada.strings.left);
	end itrim;

	function utrim( i: ushort ) return string is
	begin
		return ada.strings.fixed.trim( ushort'image(i), ada.strings.left);
	end utrim;




-- time limit algo#1, before which retry is attempted:
timeLim : ada.calendar.day_duration := 2.0; --seconds

-- [retry] time limit algo#2
retryLim : ada.calendar.day_duration := 2.0; --seconds




procedure trymove( timeLimited: boolean := false ) is
	diff, newstop, oldstop: integer := 0;
	okey: keytype;
	orec: hashrectype;
	prev, bp : ubyte;
	olm,olp : ushort;
	opr, opc : ushort;
	pch: character;
	lbox, rbox, ubox, dbox, changed : boolean;
	bxfrac : float;
	ich: character;
	avail: boolean := false;
	status: mysplaylist.statustype;
begin --trymove


	newstop:=0;

	outer:
	loop

		bxfrac := float(bestnk*100)/float(gngoals);

		oldstop:=newstop;
		newstop:=mysplaylist.length(exploring);
		diff:=newstop-oldstop;
		exit outer when diff=0;


		if not winner then
			put("R=");
			put(utrim(relenting));
			put(" NewCfg="&itrim(newstop-oldstop));
			put(", ");
			myfloat_io.put(item=>bxfrac,fore=>2,aft =>1,exp=>0);
			put("%");
			if newstop<2000 then
				put(" TotCfg="&itrim(newstop));
			else
				put(" TotCfg(k)="&itrim(newstop/1000));
			end if;
			put("  [press q to quit]");
			new_line;
		end if;


		avail:=false;
		get_immediate(ich,avail);
		if avail and then ich='q' then userexit:=true; exit outer; end if;

		if timeLimited then
			tsec1:=ada.calendar.seconds(ada.calendar.clock);
			if tsec1-tsec0>retryLim then exit outer; end if;
		end if;



		for it in 1..diff loop

			if oldstop=0 and it=1 then
				mysplaylist.head( exploring, status ); --put iterator @ list-head
				--myassert( status=Ok, 101, "head error" );
			else
				mysplaylist.next( exploring, status ); --move iterator to next
				--myassert( status=Ok, 102, "next error" );
			end if;

			-- get data from iterator's current position:
			mysplaylist.data( exploring, okey, orec, status ); --get okey, orec
			--myassert( status=Ok, 103, "splay.data error" );




		if 
			(orec.ngoals>=ubyte(bestnk/relenting)) --greediness
			--and ( orec.xlevel<1 ) --yet unexpanded
		then

			-- This only gives advantage when the solution
			-- is found at relenting>=8 ! Very few go that far.
			-- mark as expanded, prevents wasted effort at next relenting
			--orec.xlevel:=1;
			--mysplaylist.modifynode(okey,orec,exploring,status);


			prestore(orec); -- restores arrangement of boxes & puller
			pwinnertest( okey, solutionPath, orec.totpulz, orec.totmovz );
			exit outer when winner;
			prev:= orec.prevmove; -- previous move direction
			bp:= orec.boxpull; -- # [straight-line] pulls of this box

			olm:=orec.totmovz;
			olp:=orec.totpulz;





			if bp>0 then -- was a pull

				case prev is
					when 0 => pch:='D';
					when 1 => pch:='U';
					when 2 => pch:='L';
					when 3 => pch:='R';
					when others => pch:='X';
				end case;

			else -- was a move with no pull

				case prev is
					when 0 => pch:='d';
					when 1 => pch:='u';
					when 2 => pch:='l';
					when 3 => pch:='r';
					when others => pch:='x';
				end case;

			end if;


			opr:=ushort(orec.prsave);
			opc:=ushort(orec.pcsave);
			lbox:=(vf(indx(opr,opc-1))=1);
			rbox:=(vf(indx(opr,opc+1))=1);
			ubox:=(vf(indx(opr-1,opc))=1);
			dbox:=(vf(indx(opr+1,opc))=1);

			if ptestright(opr,opc) then
				if pch/='r' then --don't attempt to undo previous move
					pr:=opr; pc:=opc;
					moveright(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
					pr:=opr; pc:=opc;
				if lbox then pullright(okey,olp,olm,changed); end if;
				if changed then prestore(orec); end if;
			end if;


			if ptestleft(opr,opc) then
				if pch/='l' then
					pr:=opr; pc:=opc;
					moveleft(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
					pr:=opr; pc:=opc;
				if rbox then pullleft(okey,olp,olm,changed); end if;
				if changed then prestore(orec); end if;
			end if;


			if ptestup(opr,opc) then
				if pch/='u' then
					pr:=opr; pc:=opc;
					moveup(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
					pr:=opr; pc:=opc;
				if dbox then pullup(okey,olp,olm,changed); end if;
				if changed then prestore(orec); end if;
			end if;


			if ptestdown(opr,opc) then
				if pch/='d' then
					pr:=opr; pc:=opc;
					movedown(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
					pr:=opr; pc:=opc;
				if ubox then pulldown(okey,olp,olm,changed); end if;
				if changed then prestore(orec); end if;
			end if;


		end if;

		exit outer when winner;

		end loop; --it


	end loop outer; -- while



end trymove;


	iet: integer;
	et, tsec9: ada.calendar.day_duration;

	density: ushort;
	Ok: boolean;

	len, upper: integer := 0;

begin -- ipuller3

	checkForUserFile(Ok);
	-- defines:  infilname, level, maxlevel

	if Ok then

		readPuzzle(level);
		density := 100*gngoals/ushort(nbvalid);

		psave0; --initializes splaytree


		put_line(" nrows="&ushort'image(nrows));
		put_line(" ncols="&ushort'image(ncols));
		put_line(" pfmax="&ushort'image(pfmax));
		put_line(" nBox="&ushort'image(gngoals));



		findnexii;

	tsec0:=ada.calendar.seconds(ada.calendar.clock);




		relenting:=2;
		--if density>20 then relenting:=4; end if; --31jul19

		trymove;
		while not winner and not userexit loop
			relenting:=relenting*2;
			exit when relenting>gngoals*4;
			trymove;
		end loop;


		tsec9:=ada.calendar.seconds(ada.calendar.clock);

		et := tsec9 - tsec0;
		iet := integer(et);


		if userexit then
			put_line("user-abort");
		elsif not winner then
			put_line("Failure to find solution.");
		else
			put_line("Winner=====================================");
		end if;


		if not userexit then
			--put_line(" minMoves="&ushort'image(minMoves));
			--put_line(" minBoxPulls="&ushort'image(minBoxPulls));

			put_line(" nrows="&ushort'image(nrows));
			put_line(" ncols="&ushort'image(ncols));
			put_line(" pfmax="&ushort'image(pfmax));
			put_line(" nBox="&ushort'image(gngoals));
			put_line(" iplr3r with inertia + relenting=");
			put_line(ushort'image(relenting));


			--pdump; --show nexii on screen
			put_line(" Density="&ushort'image(density));
			put(" Winning value of relenting="&ushort'image(relenting));
			new_line;
		end if;



--------------------------------------------------------------------
----------------- begin solve again, if quick: ---------------------
--------------------------------------------------------------------


		if tsec9-tsec0 < timeLim then 
		-- 1st try took less than timeLim sec, 
		-- so let's retry for more efficient soln:

			careful:=true; urgent:=true; onestep:=true;
			if relenting<4 then relenting:=4; end if;
			bestnk:=0; -- highest #boxes-on-goals so far

			winner:=false;


			--readPuzzle(level); --needed, for some unknown reason
			vf:=ovf; -- 11dec20
			psave0; -- REinitialize splaytree
			--findnexii;
			tsec0:=ada.calendar.seconds(ada.calendar.clock);

			trymove(true); --need to limit runtime, this time!

			if winner then
				put_line(" improvement found!");
			else
				put( ada.calendar.day_duration'image(retryLim));
				put(" sec improvement NOT found!");
				new_line;
			end if;

		end if;


--------------------------------------------------------------------
----------------- end solve again, if quick: ---------------------
--------------------------------------------------------------------


		put("Solution:"); new_line;
		put( to_string(solutionPath) );
		new_line;


		len:= length(solutionPath);
		put(" moves=");
		put( integer'image( len ) );
		new_line;

		put(" pushes=");
		upper:=0;
		for i in 1..len loop
			if is_upper( element(solutionPath,i) ) then
				upper:=upper+1;
			end if;
		end loop;
		put( integer'image(upper) );
		new_line;

		put_line(" ETsec: "&integer'image(iet));




-- ipuller3...
-- uni-dir-inertia for pulls;
-- uni-dir-inertia for non-pulls, 
-- but no saving in tunnels, unless on puller-goal;

	end if;

	--put_line(integer'image(system.storage_pools.storage_size(pool)));

	--put_line(long_long_integer'image(system.memory_size/1_000_000/1_000_000));
	--put_line(long_long_integer'image(system.memory_size/1_000_000/system.storage_unit/1_000_000));


exception
	when storage_error =>
		put_line("Memory insufficient to solve this problem with this algorithm!");
		raise;

end iplr3r;
