

--
-- Copyright (C) 2020  <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.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO;

with ada.command_line;
with ada.calendar;
with utils;




procedure iplr3r is


	use Ada.Strings.Unbounded;
	use Ada.Strings.Unbounded.Text_IO;

	use text_io;
	use utils;
	use mysplay; -- utils





--///////////////////////////////////////////////////////////////////////
-- 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 and -- moving again is possible
		not ptestright and not ptestleft and -- in tunnel
		(pr/=gpr or pc/=gpc) -- not @ puller-goal
	loop 
		pr:=pr-1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,0,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);

			exit when not ptestup;        --puller blocked
			exit when pr=gpr and pc=gpc; --puller on puller goal

			exit when bnexus(ib); -- Bvalid+Enexus
			--exit when enexus( ip ); --key puller pos

			exit when not vtunl(ip);

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


-- enexus > bnexus > nexus contains goals [ff(brc)=2]
-- NOTE:  if iplr3r ever fails to find a solution,
--        simply uncomment the exit statements.






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

			exit when bnexus(ib); -- 
			--exit when enexus( ip ); --key puller pos

			exit when not vtunl(ip);

		end loop;
		psaveifnew(okey,1,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 and 
		not ptestup and 
		not ptestdown and
		(pr/=gpr or pc/=gpc) 
	loop 
		pc:=pc-1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,3,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;
			exit when pr=gpr and pc=gpc;

			exit when bnexus(ib); -- slower
			--exit when enexus( ip ); --key puller pos

			exit when not htunl(ip);

		end loop;
		psaveifnew(okey,3,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 and 
		not ptestup and 
		not ptestdown and
		(pr/=gpr or pc/=gpc) 
	loop 
		pc:=pc+1; 
		moves:=moves+1;
	end loop;
	psaveifnew(okey,2,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;
			exit when pr=gpr and pc=gpc;

			exit when bnexus(ib); -- 
			--exit when enexus( ip ); --key puller pos

			exit when not htunl(ip);

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









procedure trymove 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;
begin --trymove


	newstop:=0;

	outer:
	loop

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

		oldstop:=newstop;
		newstop:=mysplay.length(mytree);
		diff:=newstop-oldstop;
		exit outer when diff=0;


		if not winner then
			put("R=");
			put(ushort'image(relenting));

			put(" NewCfg="&integer'image(newstop-oldstop));
			put(", ");
			myfloat_io.put(item=>bxfrac,fore=>2,aft =>1,exp=>0);
			put("%");
			if newstop<2000 then
				put(" TotCfg="&integer'image(newstop));
			else
				put(" TotCfg(k)="&integer'image(newstop/1000));
			end if;
			new_line;
		end if;


		for it in 1..diff loop


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

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



			prestore(orec); -- restores arrangement of boxes & puller

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


			-- mark as expanded...
			-- prevents wasted effort at next relenting
			orec.xlevel:=1;
			mysplay.modifynode(okey,orec,mytree,status);


			prev:= orec.prevmove; -- previous move direction
			bp:= orec.boxpull; -- # [straight-line] pulls of this box
			olm:=ushort(prev);
			olp:=ushort(bp);





			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 then
				if pch/='r' then --don't attempt to undo previous move
					moveright(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
				if lbox then pullright(okey,olp,olm,changed); end if;
				if changed then prestore(orec); end if;
			end if;


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


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


			if ptestdown then
				if pch/='d' then
					movedown(okey,olp,olm);
					prestore(orec);
				end if;
				changed:=false;
				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;



	density: ushort;
	Ok: boolean;

begin -- ipuller3

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

	if Ok then

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

		psave0;


		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 loop
			relenting:=relenting*2;
			exit when relenting>gngoals*4;
			trymove;
		end loop;



		if not winner then
			put_line("Failure to find solution.");
		else
			put_line("Winner=====================================");
		end if;


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


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