

--
-- 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
--
-- ibox3:  BoxInertia...[fixed-urgency] tunnel skipper+relent.
-- Not purely BFS so...after first solution is found, 
-- the longer search tree branches are skipped.  
-- Now exits only after entire queue is searched.
--
-- Inertial Box-centric version (for larger/lishout puzzles)...
-- choose a box, then direction to 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 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 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 ibox3r is


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

	use text_io;
	use emutils;
	use mysplaylist;


	relenting: ushort;
	onestep, userexit: boolean := false;
	ibestcost,ibestpred: vftype;
	solutionPath: unbounded_string;


-- these test box-moves




-----------------------------------------------------------










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

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br-1;
	pc: ushort := bc;
	boxmoves: ushort := 0;
	prc,brc: ushort;
	moves: ushort := dppathexists(pr,pc,ibestcost);
begin --pullup
	changed:=false;
	if moves<254 and then testup(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;
			brc := indx(br,bc);
			prc := indx(pr,pc);

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

			exit when not testup(br,bc);
			exit when bnexus(brc); --box @ Bvalid+Enexus
			--exit when enexus(prc); --pull @ Enexus
			exit when not vtunl(prc);
			exit when onestep;

		end loop;
		bsaveifnew(okey,0,olp,boxmoves,olm+moves, pr,pc, br,bc);
	end if;
end pullup;





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

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br+1;
	pc: ushort := bc;
	boxmoves: ushort := 0;
	prc,brc: ushort;
	moves: ushort := dppathexists(pr,pc,ibestcost);
begin
	changed:=false;
	if moves<254 and then testdown(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;
			brc := indx(br,bc);
			prc := indx(pr,pc);

			exit when not testdown(br,bc);
			exit when bnexus(brc); --box @ Bvalid+Enexus
			--exit when enexus(prc); --pull @ Enexus
			exit when not vtunl(prc);
			exit when onestep;

		end loop;
		bsaveifnew(okey,1,olp,boxmoves,olm+moves, pr,pc, br,bc);
	end if;
end pulldown;






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

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br;
	pc: ushort := bc-1;
	boxmoves: ushort := 0;
	prc,brc: ushort;
	moves: ushort := dppathexists(pr,pc,ibestcost);
begin
	changed:=false;
	if moves<254 and then testleft(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;
			brc := indx(br,bc);
			prc := indx(pr,pc);

			exit when not testleft(br,bc);
			exit when bnexus(brc); --box @ Bvalid+Enexus
			--exit when enexus(prc); --pull @ Enexus
			exit when not htunl(prc);
			exit when onestep;

		end loop;
		bsaveifnew(okey,3,olp,boxmoves,olm+moves, pr,pc, br,bc);
	end if;
end pullleft;






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

	br: ushort := xr;
	bc: ushort := xc;
	pr: ushort := br;
	pc: ushort := bc+1;
	boxmoves: ushort := 0;
	prc,brc: ushort;
	moves: ushort := dppathexists(pr,pc,ibestcost);
begin
	changed:=false;
	if moves<254 and then testright(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;
			brc := indx(br,bc);
			prc := indx(pr,pc);

			exit when not testright(br,bc);
			exit when bnexus(brc); --box @ Bvalid+Enexus
			--exit when enexus(prc); --pull @ Enexus
			exit when not htunl(prc);
			exit when onestep;

		end loop;
		bsaveifnew(okey,2,olp,boxmoves,olm+moves, pr,pc, br,bc);
	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
	it,odiff,diff, newstop, oldstop, avg2: integer := 0;
	okey: keytype;
	orec: hashrectype;
	olm,olp, opr, opc, ii : ushort;
	bxfrac : float;
	difference : boolean;
	ich: character;
	avail: boolean := false;
	status: mysplaylist.statustype;
begin --trymove

	newstop:=0;

	outer:
	loop


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


		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.


		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

			--NOTE: at each reentry into trymove, oldstop=0.
			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" );

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



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

			brestore(orec, opr,opc);
			bwinnertest(okey,solutionPath,olp,olm);
			exit outer when winner;
			dppathprep(opr,opc,ibestcost,ibestpred);


			-- 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)<256 then --process this box

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


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


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


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


				end if;

				exit outer when winner;

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

		end if;

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

	put_line("Bytes per hashrec:" & integer'image(hashrectype'size/8));
	put_line("Bytes per keytype:" & integer'image(keytype'size/8));
	put_line("Bytes per ushort:" & integer'image(ushort'size/8));
	put_line("Bytes per ubyte:" & integer'image(ubyte'size/8));

	--put_line("Bytes per pooltype:" & integer'image(pooltype'size/8));
	put_line("Bytes per VFS:" & integer'image(vfstype'size/8));
	put_line("Bytes per vftype:" & integer'image(vftype'size/8));


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

	if Ok then

		winner:=false;

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

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


		bsave0; --initializes splaytree

		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
			new_line;
			put_line("Failure to find solution.");
		else
			put_line("Winner=========================================");
		end if;

		if not userexit then
			--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(" ibox3r: tunnel-skipper + relenting=");
			put_line(ushort'image(relenting));

			--bdump(0,0); --show nexii on screen
			--dumpvalid;
			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
			bsave0; -- 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));


	end if;

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


end ibox3r;
