

--
-- Copyright (C) 2022  <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 caz/flatAZ 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.Unbounded;
with Ada.Strings.Unbounded.Text_IO;

with ada.command_line;
with ada.calendar;


package body fbfs26 is


procedure bfs (
	infilname: unbounded_string;
	solutionPath : out unbounded_string
) is



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

	use text_io;


	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 ubyte is range 0..255; -- 2**8-1 (1-byte)
--type ushort is range 0..65_535; -- 2**16-1 (2-bytes)

subtype azrange is integer range 0..27;
type keytype is array(azrange) of azrange;


	type hashrectype is
	record
		tchr : character;
		prevkey : keytype;
	end record;



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

		for i in azrange 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 azrange 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 --------------------------






-- 1<=r<=3, 1<=c<=3, 1<=l<=3
-- this ftn encodes location coordinates as 1..27
-- ...and apparently the specific encoding is
-- irrelevant so long as it is one-to-one. 1dec22
function endx(r,c,l : integer) return integer is -- returns 1..27
begin
	--return  integer( (r-1)*9 +(c-1)*3+(l-1) +1 );
	return  integer( (l-1)*9 +(r-1)*3+(c-1) +1 ); --prove irrelevant: Ok too.
end endx;

-- in rufascube the indx() ftn = this endx() ftn ...
--
-- and the permute array are equal...
-- perm(r,c,l) = endx(r,c,l)
-- at the beginning and in solved position,
-- where indx(2,2,2)=14 [symbol(14)=" "], and
-- indx(3,3,3)=27 [symbol(27)="z"]
-- indx(1,1,1)= 1 [symbol(1)="a"]
-- indx(1,1,2)= 2 [symbol(2)="b"]
-- etc.

-- In this flat version
-- indx(2,2,2)=14 [symbol(14)="n"]
-- indx(3,2,3)=26 [symbol(27)="z"]
-- indx(3,3,3)=27 [symbol(27)="0"]












	grow,gcol,glev : array(azrange) of integer;

	winner  : boolean := false;

	nrow,ncol,nlev,
	dblk, nblk, gblk : integer;

	-- these arrays track the current positions of
	-- each of 26 cubelets + 1 blank at index=27:
	rowcen0, colcen0, levcen0,
	rowcen, colcen, levcen : array(azrange) of integer;

	idchar : array(azrange) of character := (others=>' ');

	blank: integer;

	depth: integer := 0;





	trailmax: constant integer := 300; --max #moves to solve
	ntrail : integer := 0;
	trailchr : array(1..trailmax) of character := (others=>'X');

	trailenc : array(1..trailmax) of keytype;


-- procedure to print out the solution path;
--
procedure dump is
--azrange: 0..27
	letters: array(azrange) of character :=
		('0','a','b','c','d','e','f','g','h','i','j','k','l','m',
		     'n','o','p','q','r','s','t','u','v','w','x','y','z',' ');

begin
-- note that trailchr alone has enough info to define soln
	set_unbounded_string(solutionPath, "");
	for i in 1..ntrail loop
		append(solutionPath, trailchr(i) );
	end loop;

end dump;





--sum of manhattan 3D distances between
--each cubelet and its goal:
function dist2sol return integer is
	d,dr,dc,dl: integer := 0;
begin
	for g in 1..26 loop
		dr:=( rowcen(g) - grow(g) );
		dc:=( colcen(g) - gcol(g) );
		dl:=( levcen(g) - glev(g) );
		d := d + abs(dr) + abs(dc) + abs(dl);
	end loop;
	return d;
end dist2sol;


procedure init( fname: string ) is
	fin : text_io.file_type;
	len : natural := 1;
	rcd : string(1..99);
	rr,cc,ll: integer;
	g: integer := 0;
begin


	nrow:=3; ncol:=3; nlev:=3;
	dblk:=26; gblk:=26;

	nblk:=dblk+1; --27

	-- define 26 goal positions...order here is critical !
	--
	-- Somewhat sure about the following description...
	--
	-- Order must match caz.adb::indx [9*(r-1)+3*(c-1)+l]
	for r in 1..3 loop
	for c in 1..3 loop
	for l in 1..3 loop
	if r=3 and c=3 and l=3 then --skip blank pos
		null;
	else
		g:=g+1;
		grow(g):=r; --float(r)-0.5; 
		gcol(g):=c; --float(c)-0.5; 
		glev(g):=l; --float(l)-0.5;
	end if;
	end loop;
	end loop;
	end loop;



-- expect 27 lines with (row,col,layer) in each,
-- defining the current cubelet positions a..z,
-- the final line is the blank space position.
-- This is the format dumped from rcube.

	text_io.open(fin, in_file, fname);

-- read the file that contains the
-- (row,column,layer) positions of 
-- each cubelet written as integers:

	for i in 1..nblk loop
		myint_io.get(fin, rr);
		myint_io.get(fin, cc);
		myint_io.get(fin, ll);
		rowcen(i):=rr;
		colcen(i):=cc;
		levcen(i):=ll;
		text_io.get_line(fin, rcd, len); -- ignore any text
		idchar(i):=character'val(96+i); --a=97...z=122
		rowcen0(i):=rowcen(i);
		colcen0(i):=colcen(i);
		levcen0(i):=levcen(i); --last one (i=27) is blank pos
	end loop;

	text_io.close(fin);

	blank:=dblk+1; --27=index of blank space

	ntrail:=0;
	winner:=false;

end init;





-- ?is there a better way? Yes, but advantage is debatable.
-- I could track moves by updating perm(r,c,l)...
function ifind( r,c,l : integer ) return integer is
	rr,cc,ll,ret: integer := 0;
begin
	for j in 1..26 loop

		rr := rowcen(j);
		cc := colcen(j);
		ll := levcen(j);

		if rr=r and cc=c and ll=l then
			ret:=j;
		end if;
	end loop;
	myassert( ret in 1..26 );

	return ret;
end ifind;





--decrease column
function moveleft( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if bc<ncol then
	-- space allows moveleft
		selBlock:=ifind(br,bc+1,bl);
		colcen(selBlock) := bc;
		colcen(blank) := bc+1;
		ret:=1;
	end if;


	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='l';

	end if;


	return ret;

end moveleft;










function moveright( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if bc>1 then
	-- space allows moveright
		selBlock:=ifind(br,bc-1,bl);
		colcen(selBlock) := bc;
		colcen(blank) := bc-1;
		ret:=1;
	end if;


	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='r';

	end if;


	return ret;


end moveright;








function moveup( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if br<nrow then
	-- space allows moveup
		selBlock:=ifind(br+1,bc,bl);
		rowcen(selBlock) := br;
		rowcen(blank) := br+1;
		ret:=1;
	end if;


	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='u';

	end if;


	return ret;

end moveup;






function movedown( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if br>1 then
	-- space allows movedown
		selBlock:=ifind(br-1,bc,bl);
		rowcen(selBlock) := br;
		rowcen(blank) := br-1;
		ret:=1;
	end if;


	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='d';

	end if;


	return ret;


end movedown;









--level decreases
function movebackward( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if bl<nlev then
	-- space allows movebackward (level decreases)
		selBlock:=ifind(br,bc,bl+1);
		levcen(selBlock) := bl;
		levcen(blank) := bl+1;
		ret:=1;
	end if;



	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='b';

	end if;


	return ret;


end movebackward;






--level increases
function moveforward( track: boolean ) return integer is

	s: keytype := (others=>0);

	selBlock,ret: integer := 0;

	br: integer := rowcen(blank);
	bc: integer := colcen(blank);
	bl: integer := levcen(blank);

begin


	if bl>1 then
	-- space allows moveforward (lev increases)
		selBlock:=ifind(br,bc,bl-1);
		levcen(selBlock) := bl;
		levcen(blank) := bl-1;
		ret:=1;
	end if;



	if track and ret>0 then
		for j in 1..dblk loop
			s(j) := ( endx(rowcen(j),colcen(j),levcen(j)) );
		end loop;

		ntrail:=ntrail+1;
		trailenc(ntrail):=s;
		trailchr(ntrail):='f';

	end if;


	return ret;


end moveforward;
















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

	if ntrail>0 then

 		chr := trailchr(ntrail);
		ntrail := ntrail-1;

		case chr is

			when 'd' =>
				res := moveup(false);
				myassert(res>0,11,"undo 1");

			when 'u' =>
				res := movedown(false);
				myassert(res>0,12, "undo 2");

			when 'r' =>
				res := moveleft(false);
				myassert(res>0,13, "undo 3");

			when 'l' =>
				res := moveright(false);
				myassert(res>0,14, "undo 4");

			when 'b' => --level increase
				res := moveforward(false);
				myassert(res>0,15, "undo 5");

			when 'f' => --level decrease
				res := movebackward(false);
				myassert(res>0,16, "undo 6");


			when others => null;
		end case;


	end if;

end undo;









procedure test4winner( key: keytype ) is
begin

	if dist2sol<1 then
		winner:=true;

		dump;

	end if;

end test4winner;








procedure addifnew( okey: keytype ) is
	rec : hashrectype;
	nt: constant integer := ntrail;
	nukey : keytype := trailenc(nt);
	pri: integer;
	use mypq;
	use mytree;
begin

	mytree.search(nukey,explored,rec,estatus);
	if estatus=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=notfound then -- not already in {frontier}

			rec.prevkey := okey;
			rec.tchr := trailchr(nt);

			--estimate of total soln length
			--pri := nt+dist2sol; --often fails...why?
			--pri := dist2sol; --works but inefficient
			pri := nt/2 + dist2sol; --magically works!

			myassert( pri<1_000, 19, "Priority Error" ); 
			--must be within splaypq::p1range: 0..1_000

			mypq.addnode( nukey, rec, pri, frontier, fstatus );
			myassert( fstatus=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 rec.tchr = 's' then
		return 0;

	elsif estatus=notfound then
		return 0;

	else

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

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

	end if;

	return k;

end getrail;




procedure restore( okey: keytype ) is
 res : integer;
 chr : character;
begin

	-- restore original block positions:
	for i in 1..nblk loop
		rowcen(i):=rowcen0(i);
		colcen(i):=colcen0(i);
		levcen(i):=levcen0(i);
	end loop;

-- now, restore block configuration

	ntrail:=getrail(okey);
	for i in 1..ntrail loop
		chr := trailchr(i);
		case chr is
			when 'u' =>
				res := moveup(false);
				myassert(res>0,101,"restore 1");

			when 'd' =>
				res := movedown(false);
				myassert(res>0,102,"restore 2");

			when 'l' =>
				res := moveleft(false);
				myassert(res>0,103,"restore 3");

			when 'r' =>
				res := moveright(false);
				myassert(res>0,104,"restore 4");



			when 'f' => -- level increase
				res := moveforward(false);
				myassert(res>0,105,"restore 5");

			when 'b' => -- level decrease
				res := movebackward(false);
				myassert(res>0,106,"restore 6");




			when others => 
				null;
				put_line("ERROR in restore...bad trailchr");
				myassert(false);
		end case;
	end loop;
end restore;






procedure trymove is
	len: integer := 0;
	okey: keytype;
	orec: hashrectype;
	res,pri: integer;
begin --trymove


	loop

		depth:=depth+1;

		--this prevents memory abort...
		-- 2_000_000 is just a WAG (approx 10sec wait before fail)
--		if depth>2_000_000 then
--			put("Fail... depth-exit"); new_line;
--			exit;
--		end if;
		--Note that bfs26Ftn.cpp has no depth limit & works fine <= 10sec.

		len:=mypq.length(frontier);

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

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

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

		restore(okey);

		-- not needed here
		--test4winner(okey);
		--exit when winner;



		res := moveup(true);
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;

		res := movedown(true);
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;

		res := moveright(true);
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;

		res := moveleft(true);
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;


		res := moveforward(true); --level increase
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;

		res := movebackward(true); --level decrease
		if res>0 then
			addifnew(okey);
			exit when winner;
			undo;
		end if;



	end loop; -- while::940



end trymove;


	key0 : keytype := (others=>0);
	rec0 : hashrectype;
	pri: integer;

	use mypq;

begin -- bfs


	init( to_string(infilname) ); -- read puzzle file w/current config

	rec0.prevKey := key0;
	rec0.tchr := 's';

	pri := dist2sol; --must call AFTER init
	mypq.addnode( key0, rec0, pri, frontier, fstatus );
	myassert( fstatus=ok, 114, "fbfs26 addnode error" );

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

	trymove;

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


end bfs; --proc

end fbfs26; --package
