

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


-- Sokoban Reverse-BFS solver : 
-- a brute-force breadth-first-search in reverse
--
-- ibox1 ... simpler logic versus ibox. After first solution
-- is found, the longer search tree branches are skipped.  
-- Now exits only after entire queue is searched.

-- IBOX=Inertial Box-centric version.
--
-- Algorithm:
-- choose a box, then a direction;  move it as far as possible
-- in that same direction, while saving critical intermediate 
-- positions. Ignores exact puller position but saves puller-corral.
--
-- 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 much space in the search tree.
-- 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 ">".
--
-- Note that solutions are push-optimal but NOT move-optimal
-- since the extent of the pusher movement is completely ignored.








with splaylist;
with text_io;

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

with ada.command_line;
with ada.calendar;

with emutils;


package body solver is


function ibox( timeout_sec: float;
	infilname: unbounded_string;
	ilevel, imaxlevel : integer;
	solutionPath : in out unbounded_string
	) return boolean is

	failure: boolean := false;

	-- put a time limit on this embedded version:
	interactive_timeout : ada.calendar.day_duration := 10.0; --seconds


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

	use text_io;

	use emutils;
	use mysplay;











procedure pullup(
	okey: keytype;  xr,xc : ushort; changed: out boolean ) is

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br-1;
	pc: ushort := bc;
	boxmoves: ushort := 0;
	irc: ushort;

begin --pullup
	changed:=false;
	if dppathexists(pr,pc) and then btestup(br,bc) then
		changed:=true;
		loop
			vf(indx(pr+1,pc)):=0;
			vf(indx(pr,pc)):=1;
			br:=pr; bc:=pc;
			pr:=pr-1;
			boxmoves:=boxmoves+1;
			irc := indx(br,bc);

			exit when not btestup(br,bc);
			exit when ff(irc)=2;
			exit when bnexus(irc); --Bvalid+Enexus
			exit when enexus(indx(pr,pc));

		end loop;
		bsaveifnew(solutionPath,okey,0,boxmoves, pr,pc, br,bc);

	end if;
end pullup;






procedure pulldown(
	okey: keytype;  xr,xc : ushort;	changed: out boolean ) is

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br+1;
	pc: ushort := bc;
	boxmoves: ushort := 0;
	irc: ushort;

begin
	changed:=false;
	if  dppathexists(pr,pc) and then btestdown(br,bc) then
		changed:=true;
		loop
			vf(indx(pr-1,pc)):=0;
			vf(indx(pr,pc)):=1;
			br:=pr; bc:=pc;
			pr:=pr+1;
			boxmoves:=boxmoves+1;
			irc := indx(br,bc);

			exit when not btestdown(br,bc);
			exit when ff(irc)=2;
			exit when bnexus(irc);
			exit when enexus(indx(pr,pc));

		end loop;
		bsaveifnew(solutionPath,okey,1,boxmoves, pr,pc, br,bc);

	end if;
end pulldown;






procedure pullleft(
	okey: keytype;  xr,xc : ushort;	changed: out boolean ) is

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br;
	pc: ushort := bc-1;
	boxmoves: ushort := 0;
	irc: ushort;

begin
	changed:=false;
	if  dppathexists(pr,pc) and then btestleft(br,bc) then
		changed:=true;
		loop
			vf(indx(pr,pc+1)):=0;
			vf(indx(pr,pc)):=1;
			br:=pr; bc:=pc;
			pc:=pc-1;
			boxmoves:=boxmoves+1;
			irc := indx(br,bc);

			exit when not btestleft(br,bc);
			exit when ff(irc)=2;
			exit when bnexus(irc);
			exit when enexus(indx(pr,pc));

		end loop;
		bsaveifnew(solutionPath,okey,3,boxmoves, pr,pc, br,bc);

	end if;
end pullleft;






procedure pullright(
	okey: keytype;  xr,xc : ushort;	changed: out boolean ) is

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br;
	pc: ushort := bc+1;
	boxmoves: ushort := 0;
	irc: ushort;

begin
	changed:=false;
	if  dppathexists(pr,pc) and then btestright(br,bc) then
		changed:=true;
		loop
			vf(indx(pr,pc-1)):=0;
			vf(indx(pr,pc)):=1;
			br:=pr; bc:=pc;
			pc:=pc+1;
			boxmoves:=boxmoves+1;
			irc := indx(br,bc);

			exit when not btestright(br,bc);
			exit when ff(irc)=2;
			exit when bnexus(irc);
			exit when enexus(indx(pr,pc));

		end loop;
		bsaveifnew(solutionPath,okey,2,boxmoves, pr,pc, br,bc);

	end if;
end pullright;




















procedure trymove is
	odiff,diff, newstop, oldstop, avg2: integer := 0;
	okey: keytype;
	orec: hashrectype;
	opr, opc, ii : ushort;
	bxfrac : float;
	difference : boolean;
	use mysplay;
begin --trymove


	minMoves:=usmx;
	minBoxPulls:=usmx;

	depth:=0;
	newstop:=0;

	loop


		bxfrac := float(bestnk*100)/float(gngoals+1);
		-- in order to win, we must end up with puller in the
		-- proper corral, in addition to positioning all boxes.

		depth:=depth+1;

		oldstop:=newstop;
		newstop:=mysplay.length(mytree);

		diff := newstop-oldstop;

		exit when diff=0;



		for it in 1 .. diff loop


tsec1:=ada.calendar.seconds(ada.calendar.clock);
if tsec1-tsec0>interactive_timeout then failure:=true; end if;
exit when failure;


			mysplay.nextOrHead( mytree, status ); --move iterator to next
			myassert( status=Ok, 102, "next error" );

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

			olpulz:=orec.totpulz;


		if olpulz+1<minBoxPulls then -- improved soln possible

			brestore(orec, opr,opc);
			dppathprep(opr,opc);


			-- do a lexicographic search for boxes,
			-- then try to move it in 4 directions:
			for br in 2..nrows-1 loop
			for bc in 2..ncols-1 loop


				ii:=indx(br,bc);

				if vf(ii)=1 and ee(ii)<=255 then --process this box

					pullright(okey,br,bc,difference);
					if difference then
						brestore(orec,opr,opc);
					end if;


					pullleft(okey,br,bc, difference);
					if difference then
						brestore(orec,opr,opc);
					end if;


					pullup(okey,br,bc, difference);
					if difference then
						brestore(orec,opr,opc);
					end if;


					pulldown(okey,br,bc, difference);
					if difference then
						brestore(orec,opr,opc);
					end if;


				end if;

			end loop; --bc
			end loop; --br

		end if;

		end loop; -- for it


	end loop;




end trymove;






begin -- ibox

	interactive_timeout := ada.calendar.day_duration(timeout_sec);

	level:=ilevel;
	maxlevel:=imaxlevel;

	winner:=false;

	readPuzzle(infilname,level);

	if failure then return false; end if;

	set_unbounded_string(solutionPath, "");

	mysplay.make_empty(mytree,status);
--put(statustype'image(status)); new_line;
	myassert(status=empty or status=ok, 99988, "ibox make_empty");

	myassert( mysplay.length(mytree) = 0, 99999, "initialSplay" );
	myassert( length(solutionPath)=0, 98989, "initialSol" );


	bsave0; --ebutils
	findnexii;

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



	trymove;

	return winner;

end ibox;








function puller( timeout_sec: float;
	infilname: unbounded_string;
	ilevel, imaxlevel : integer;
	solutionPath : in out unbounded_string
	) return boolean is

	failure: boolean := false;

	-- put a time limit on this embedded version:
	interactive_timeout : ada.calendar.day_duration := 10.0; --seconds



-- puller1...simpler logic versus puller, now taking single steps 
-- when not pulling seems to produced a queue ordering that finds 
-- better solutions.  After first solution is found, the longer
-- search tree branches are skipped.  Now exits only after entire
-- queue is searched.
-- 
--
-- Sokoban Reverse-BFS solver : 
-- a brute-force breadth-first-search in reverse
--
-- 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 ">".











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

	use text_io;
	use emutils;
	use mysplay;






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


-- only called if testup=true
procedure pullup(okey: keytype;  changed: out boolean) is
	boxmoves: ushort := 0;
	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
			exit when not ptestup;        --puller blocked
			exit when ff(ib)=2; --box on goal
			exit when bnexus(ib); -- Bvalid+Enexus
			exit when enexus( indx(pr,pc) ); --key puller pos
			exit when pr=gpr and pc=gpc; --puller on puller goal
		end loop;
		psaveifnew(solutionPath,okey,0,boxmoves,boxmoves);
	end if;
end pullup;






procedure movedown(okey: keytype) is -- without pulling
	moves,boxmoves: 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(solutionPath,okey,1,0,moves);
end movedown;


-- only called if testdown=true
procedure pulldown(okey: keytype;  changed: out boolean) is
	boxmoves: ushort := 0;
	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
			exit when not ptestdown;
			exit when ff(ib)=2; --box on goal
			exit when bnexus(ib); -- 
			exit when enexus( indx(pr,pc) ); --key puller pos
			exit when pr=gpr and pc=gpc;
		end loop;
		psaveifnew(solutionPath,okey,1,boxmoves,boxmoves);
	end if;
end pulldown;







procedure moveleft(okey: keytype) is -- without pulling
	moves,boxmoves: 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(solutionPath,okey,3,0,moves);
end moveleft;


-- only called when testleft=true
procedure pullleft(okey: keytype;  changed: out boolean) is
	boxmoves: ushort := 0;
	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
			exit when not ptestleft;
			exit when ff(ib)=2; --box on goal
			exit when bnexus(ib); -- slower
			exit when enexus( indx(pr,pc) ); --key puller pos
			exit when pr=gpr and pc=gpc;
		end loop;
		psaveifnew(solutionPath,okey,3,boxmoves,boxmoves);
	end if;
end pullleft;






procedure moveright(okey: keytype) is -- without pulling
	moves,boxmoves: 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(solutionPath,okey,2,0,moves);
end moveright;



-- only called when testright=true
procedure pullright(okey: keytype;  changed: out boolean) is
	boxmoves: ushort := 0;
	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
			exit when not ptestright;
			exit when ff(ib)=2; --box on goal
			exit when bnexus(ib); -- 
			exit when enexus( indx(pr,pc) ); --key puller pos
			exit when pr=gpr and pc=gpc;
		end loop;
		psaveifnew(solutionPath,okey,2,boxmoves,boxmoves);
	end if;
end pullright;




















procedure trymove is
	newstop, oldstop: integer := 0;
	okey: keytype;
	orec: hashrectype;
	prev, bp : ubyte;
	opr, opc : ushort;
	pch: character;
	lbox, rbox, ubox, dbox, changed : boolean;
	bxfrac : float;
	use mysplay;
begin --trymove

	minMoves:=usmx;
	minBoxPulls:=usmx;

	depth:=0;
	newstop:=0;

	loop

		pcountbest(nk,ng);
		if bestnk<nk then bestnk:=nk; end if;
		bxfrac := float(bestnk*100)/float(ng);


		depth:=depth+1;

		oldstop:=newstop;
		newstop:=mysplay.length(mytree);


--put("Top IT loop 1..");
--put(integer'image(newstop-oldstop));
--new_line;

		exit when oldstop=newstop;

		for it in 1 .. newstop-oldstop loop

tsec1:=ada.calendar.seconds(ada.calendar.clock);
if tsec1-tsec0>interactive_timeout then failure:=true; end if;
exit when failure;

			mysplay.nextOrHead( mytree, status ); --move iterator to next
			myassert( status=Ok, 102, "next error" );

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

			olpulz:=orec.totpulz;
			olmovz:=orec.totmovz;

		if (olpulz+1<minBoxPulls) and (olmovz+1<minMoves) then
		-- improved solution possible

			prestore(orec);
			prev:= orec.prevmove;
			bp:= orec.boxpull; -- # [straight-line] pulls of this box


			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
					moveright(okey);
					prestore(orec);
				end if;
				changed:=false;
				if lbox then pullright(okey,changed); end if;
				if changed then prestore(orec); end if;
			end if;


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


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


			if ptestdown then
				if pch/='d' then
					movedown(okey);
					prestore(orec);
				end if;
				changed:=false;
				if ubox then pulldown(okey,changed); end if;
				--if changed then prestore(orec); end if;
			end if;


		end if;

		end loop; -- inner for it


	end loop; -- outer




end trymove;














begin -- puller

myassert( not failure, 99987, "enter puller");

	interactive_timeout := ada.calendar.day_duration(timeout_sec);

	level:=ilevel;
	maxlevel:=imaxlevel;

	winner:=false;

	readPuzzle(infilname, level);

	if failure then return false; end if;

	set_unbounded_string(solutionPath, "");

	mysplay.make_empty(mytree,status);
--put(statustype'image(status)); new_line;
	myassert(status=empty or status=ok, 99988, "puller make_empty");

	myassert( mysplay.length(mytree) = 0, 99999, "initialSplay(puller)" );


	psave0;
	findnexii;

	pcountbest(nk,gngoals);
	if bestnk<nk then bestnk:=nk; end if;


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

--put(" tree size @ enter = ");
--put(integer'image(mysplay.length(mytree)));
--new_line;

	trymove;

	return winner;

end puller;





end solver;
