


--
-- Copyright (C) 2023  <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/>.
--


-- Breadth First (now A*) Search cube.adb puzzle solver...
--
-- Uses a splaytree, to test whether a given config was seen before.  
-- Extremely fast access.
--
-- Uses a fullproof Key-type, for which we must define
-- operators "<" and ">".

-- To Do: understand why [pri := nt+dist2sol] WORKS for fbfs7.adb
-- and FAILS here, yet [pri := nt/2 + dist2sol] works fine!







with splaypq0;
with splaytree;
with text_io;

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

with ada.command_line;
with ada.calendar;

with utils4;
with gametypes;


package body fbfs4 is


procedure bfs (
	currentCfg: in keytype;
	emptyCfg: in emptytype;
	solutionPath : out unbounded_string
) is


	use utils4;
	use gametypes;

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

	use text_io;

	originalCfg: constant keytype := currentCfg;
	lcentroid: keytype := originalCfg;
	lempty: emptytype := emptyCfg;


	package myint_io is new text_io.integer_io(integer);
	package myfloat_io is new text_io.float_io(float);


	procedure myassert( 
		condition : boolean;  
		flag: integer:=0;
		msg: string := ""
		) is
	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;


--------------- begin types for hashtable --------------------------

	type hashrectype is
	record
		tchr: character :='x'; --move direction from prevkey to thiskey
		tsel : integer := 99; --ID of block moved in prevkey to get to thiskey
		--thiskey, 
		prevkey : keytype := key0;
	end record;


	function "<" (v1, v2: in vi3) return boolean is
	begin
		for i in 1..3 loop
			if v1(i)<v2(i) then return true;
			elsif v1(i)>v2(i) then return false;
			end if;
		end loop;
		return false;
	end "<";


	function ">" (v1, v2: in vi3) return boolean is
	begin
		for i in 1..3 loop
			if v1(i)>v2(i) then return true;
			elsif v1(i)<v2(i) then return false;
			end if;
		end loop;
		return false;
	end ">";



	function "<" (k1, k2: in keytype ) return boolean is
	begin

		for i in rngp loop
			if k1(i)<k2(i) then return true;
			elsif k1(i)>k2(i) then return false;
			end if;
		end loop;
		return false;

	end "<";

	function ">" (k1, k2: in keytype ) return boolean is
	begin

		for i in rngp loop
			if k1(i)>k2(i) then return true;
			elsif k1(i)<k2(i) then return false;
			end if;
		end loop;
		return false;

	end ">";


	package mytree is new splaytree( keytype, hashrectype, "<", ">" );
	explored : mytree.treetype;
	estatus : mytree.statustype; -- Ok, found, ...


	package mypq is new splaypq0( keytype, hashrectype, "<", ">" );
	frontier : mypq.listtype;
	fstatus : mypq.statustype; -- Ok, found, ...




--------------- end types for hashtable --------------------------




	maxpri: integer := 0; --tracks priorities...must be in 0..200 (splaypq0.p1range)


-- this stuff must be in utils4.ads because it is used in move*:
--	trailmax: constant integer := 300; --max #moves to solve
--	ntrail : integer := 0; --path length of current config
--	trailchr : array(1..trailmax) of character := (others=>'X');
--	trailsel : array(1..trailmax) of integer := (others=>0);
--	trailenc : array(1..trailmax) of keytype;


function i2st( i: integer ) return string is
begin
	if i>=0 and i<=9 then
		return ada.strings.fixed.trim( integer'image(i), ada.strings.left);
	elsif i=10 then
		return "A";
	else
		return " ";
	end if;
end i2st;



procedure dump is
	--sel:integer;
begin

	--each solution step has 5 chars

	set_unbounded_string(solutionPath, "");
	for i in 1..ntrail loop
		--sel:=trailsel(i);

		append(solutionPath, "  " ); -- 2 blank spaces

		append(solutionPath, i2st( trailsel(i) )  ); -- 1 chars [0..9,A]

		append(solutionPath, " " ); -- single blank space

		append(solutionPath, trailchr(i) ); -- final char
			-- {'u' 'd' 'l' 'r' 'n' 'a'}

	end loop;
end dump;


function dist2sol( centr: in keytype ) return integer is
	dist: integer := 0;
begin
	for i in rngp loop
		dist := dist 
			+ abs( centr(i)(1)-centroidMid(i)(1) )
			+ abs( centr(i)(2)-centroidMid(i)(2) )
			+ abs( centr(i)(3)-centroidMid(i)(3) );
	end loop;
	return dist;
end dist2sol;







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

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








procedure undo is
 res: boolean;
 chr: character;
 sel: integer;
begin

	if ntrail>0 then

 		chr := trailchr(ntrail);
		sel := trailsel(ntrail);

		trailchr(ntrail):='x';
		trailsel(ntrail):=99;
		trailenc(ntrail):=key0;

		ntrail := ntrail-1;

		case chr is

			when 'd' =>
				res := moveup(sel,lcentroid,lempty);
				myassert(res,11,"undo 1");

			when 'u' =>
				res := movedown(sel,lcentroid,lempty);
				myassert(res,12, "undo 2");

			when 'r' =>
				res := moveleft(sel,lcentroid,lempty);
				myassert(res,13, "undo 3");

			when 'l' =>
				res := moveright(sel,lcentroid,lempty);
				myassert(res,14, "undo 4");

			when 'a' => --level increase
				res := movenear(sel,lcentroid,lempty);
				myassert(res,15, "undo 5");

			when 'n' => --level decrease
				res := moveaway(sel,lcentroid,lempty);
				myassert(res,16, "undo 6");

			when others => null;
		end case;

	end if;

end undo;













procedure addifnew( okey: keytype ) is
	rec : hashrectype;
	nt: constant integer := ntrail; --current path length
	nukey : constant keytype := trailenc(nt);
	nusel : constant integer := trailsel(nt);
	nuch  : constant character := trailchr(nt);
	pri: mypq.p1range;
	use mypq;
	use mytree;
begin

	mytree.search(nukey,explored,rec,estatus);

	if estatus=mytree.notfound then -- not already in {explored}

		mypq.search( nukey, frontier, rec, pri, fstatus );

		-- if found, we have reached this config earlier, so ignore

		if fstatus=mypq.notfound then -- not already in {frontier}

			rec.prevkey := okey;
			rec.tsel:= nusel;
			rec.tchr:= nuch;


			--pri := nt + dist2sol(nukey); --very slow
			-- 20 seconds, 45 moves (efficient soln)
			-- this one worries me since it fails in rcube...

			--pri := nt/2 + dist2sol(nukey); --fast, good
			pri := 2*nt/3 + dist2sol(nukey); --very fast
			-- 0.5 second, 49 moves


			myassert( pri<mypq.p1range'last, 19, "Priority Error" ); 
			--must be within splaypq::p1range: 0..200 (was 1000)

			if pri>maxpri then maxpri:=pri; end if; --tracker 2sep23

			mypq.addnode( nukey, rec, pri, frontier, fstatus );
			myassert( fstatus=mypq.ok, 15, "addnode error" );

			test4winner(nukey);

		end if; -- not seen

	end if; --not in explored


end addifnew;






-- recursive ftn to load trail* from database
function getrail( pkey: keytype ) return integer is
	k: integer := 0;
	rec : hashrectype;
	use mytree;
begin

	mytree.search( pkey, explored, rec, estatus );

	if estatus=notfound then
		return 0;

	elsif rec.tchr = 's' then
		--myassert(pkey=originalCfg, 15, "getrail error 0");
		return 0;

	else

		k := getrail( rec.prevKey ); --RECURSIVE call
		myassert(k>=0,16, "getrail error");

		k := k+1;
		trailchr(k) := rec.tchr;
		trailsel(k) := rec.tsel;

	end if;

	return k;

end getrail;





procedure restore( okey: keytype ) is
 sel : integer;
 chr : character;
 verbose: constant boolean := false; --true;
 ok: boolean := true;
 savkey: keytype;
begin

	trailchr := (others=>'x');
	trailsel := (others=>99);
	trailenc := (others=>key0);

	-- restore configuration of okey...

	ntrail:=getrail(okey); --fill trailchr/trailsel/trailenc arrays

	--now, rebuild current cfg [where key=okey]
	lcentroid := originalCfg;
	lempty := emptyCfg;

	if verbose then
		put_line(" restore...");
		put("oky|"); put(key2str(okey)); put("|"); new_line;
		put("Cfg|"); put(key2str(lcentroid)); put("|"); new_line; new_line;
	end if;


	for i in 1..ntrail loop
		chr := trailchr(i);
		sel := trailsel(i);
		ok:=false;
		savkey:=lcentroid;
		case chr is
			when 'u' =>
				ok:=moveup(sel,lcentroid,lempty,false);
			when 'd' =>
				ok:=movedown(sel,lcentroid,lempty,false);
			when 'l' =>
				ok:=moveleft(sel,lcentroid,lempty,false);
			when 'r' =>
				ok:=moveright(sel,lcentroid,lempty,false);
			when 'n' =>
				ok:=movenear(sel,lcentroid,lempty,false);
			when 'a' =>
				ok:=moveaway(sel,lcentroid,lempty,false);

			when others => 
				ok:=false;
				put("...bad trailchr in restore...");
		end case;

		if verbose then
			put(" ntrail="&integer'image(ntrail));
			put(" i="&integer'image(i));
			put("| sel="&integer'image(sel));
			put(", chr="&chr); new_line;
			put("Cfg|");
			put(key2str(lcentroid));
			put("|"); new_line; new_line;
		end if;

		myassert(lcentroid/=savkey, 13, "restore.move failed to update lcentroid?");
		myassert(ok, 26, "Error in Restore: not Ok...");

	end loop;

end restore;







depth: integer := 0;

procedure trymoves is
	len: integer := 0;
	okey: keytype;
	orec: hashrectype;
	pri: integer;
	ok: boolean;
begin --trymoves

	outer:
	loop

		depth:=depth+1;

		len:=mypq.length(frontier);

--if depth mod 100 = 0 then
--put(" depth="&integer'image(depth));
--put("   len="&integer'image(len));
--new_line;
--end if;


		if len=0 then
			put("Fail... len-exit"); new_line;
			put(integer'image(depth));
			put(integer'image(len));
			new_line;
			exit outer;
		end if;

		-- define okey, orec, pri; then remove front elt from {frontier}:
		mypq.popNode(frontier,okey,orec,pri,fstatus);

--2 sanity checks:-------------------------------------------------------

		if orec.tchr /= 's' then --not initial cfg
			myassert( orec.tsel in 0..10, 55, "bad tsel in mypq" );
		end if;

		-- in ('u','d','r','l','n','a') );
		myassert( orec.tchr in 'a'..'u', 56, "bad tchr in mypq" );
-------------------------------------------------------------------------


		-- (pri not needed) insert orec into {explored}
		mytree.addNode(okey,orec,explored,estatus);

		restore(okey);


		inner:
		for i in rngp loop -- blocks numbered 0..10

			ok:=moveup(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;


			ok:=movedown(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;


			ok:=moveright(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;


			ok:=moveleft(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;



			ok:=movenear(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;


			ok:=moveaway(i,lcentroid,lempty,true);
			if ok then
				addifnew(okey);
				exit outer when winner;
				undo;
			end if;


		end loop inner;



	end loop outer;

	if winner then
		dump;
	end if;


end trymoves;




	pri: integer;

	use mypq;

	rec0: hashrectype;

begin -- bfs

	bfsWorking:=true;

	rec0.tchr:='s';
	rec0.tsel:=99;
	rec0.prevkey:=key0;

	pri := dist2sol(currentCfg);
	mypq.addnode( key0, rec0, pri, frontier, fstatus );
	myassert( fstatus=ok, 114, "fbfs26 addnode error" );

	--put("initial dist2sol = "); put(integer'image(pri)); new_line;

	trymoves;

	--put(" MaxPri: "&integer'image(maxpri));
	--new_line; --debug 2sep23

	mypq.make_empty(frontier, fstatus);
	mytree.make_empty(explored, estatus);

	bfsWorking:=false;


exception --2sep23
	when others=>
		put_line(" MaxPri: "&integer'image(maxpri));
		raise;
		
end bfs; --proc


end fbfs4; --package

