

--
-- 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 Search block slider puzzle solver...
-- a brute-force solver for *.blok
--
-- 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 ">", if the keytype has no intrinsic order.



-- This code has become specific to this one puzzle,
-- I have abandon any attempt to generalize it.

-- This takes about 35 seconds to solve.
-- It uses a keytype that visits all permutations
-- of puzzle pieces versus all possible locations;
-- relying on a more precise test4win ftn. to pick
-- the first winner.





with splaylist;
with text_io;

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

with ada.command_line;
with ada.calendar;


--this BFS solver uses a full permutation-based-key 
--so that each block has a particular goal position
--regardless of its size...primarily to solve c9.adb


procedure bfsp is



	use Ada.Strings.Fixed;
	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 pos_range is integer range 0..12; -- 0+#positions

	type keytype is array(pos_range) of pos_range;
	--appropriate for a full permutation search,
	--which is overkill in this case: 11 blocks, 6 letters (panmcl)
	--Many blocks have common letter-labels, so
	--several permutations are equivalent because
	--they put the same 6 letters in the same positions.
	--Only if it becomes critical to reduce solution time
	--might it be worth the effort to figure out a
	--more efficient keytype.
	--This one takes 35 seconds.


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


-- if "keytype" does not have a natural ordering, define it here:

	function "<" (k1, k2: in keytype ) return boolean is
	begin
		for i in pos_range 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 pos_range 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 mysplay is new splaylist( keytype, hashrectype, "<", ">" );
	use mysplay;

	mytree : listtype;
	status : statustype; -- Ok, found, ...


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



-- 1<=r<=2, 1<=c<=6
-- this ftn encodes location
function endx(r0,c0 : ushort) return pos_range is
	r: integer := integer(r0);
	c: integer := integer(c0);
	ret: integer := (r-1)*6+(c-1)+1; -- 1..12
begin
	return ret; --1..12
end endx;



	infilname: unbounded_string;




	mxblokz: constant integer := 11;
	mxblnkz: constant integer := 1;

	winner  : boolean := false;

	nrow,ncol,
	dblk, nblk, gblk : integer;
	maxblk : constant integer := mxblokz+mxblnkz; --#blks+blanks

	rowcen0, colcen0,
	rowcen, colcen : array(1..maxblk) of float;
	lett: array(1..maxblk) of character;

	bshape : array(1..maxblk) of integer;
	idchar : array(1..maxblk) of character := (others=>' ');

	--blank1: integer;
	blank: array(1..mxblnkz) of integer;

	depth: integer := 0;





	trailmax: constant integer := 300; -- even klotski needs only 116 moves
	ntrail : integer := 0;
	trailsel : array(1..trailmax) of integer := (others=>0);
	trailchr : array(1..trailmax) of character := (others=>'X');
	trailenc11 : array(1..trailmax) of keytype;



-- procedure to print out the solution path;
--
procedure dump is
	fout: text_io.file_type;
begin

	text_io.create( fout, out_file, "Pan_path.txt" );

new_line;
put_line(" writing solution to file:  Pan_path.txt");
new_line;

	put_line(fout, to_string(infilname) );
	new_line(fout);

	put_line(fout,"Solution path with #steps="
				&integer'image(ntrail)&" :");
	new_line(fout);

	for i in 1..ntrail loop
		put(fout, trailchr(i)&"  " );
		if 0=(i mod 10) then new_line(fout); end if;
	end loop;
	new_line(fout);
	text_io.close(fout);

end dump;




procedure dumpGameState is
	fileid : text_io.file_type;
begin

   text_io.Create
      (File => FileId,
       Mode => text_io.Out_File,
       Name => "panGame.txt");

	put_line(fileid, "this file should be similar to panama.blk");
	myint_io.put(fileid, nrow);
	new_line(fileid);
	myint_io.put(fileid, ncol);
	new_line(fileid);
	myint_io.put(fileid, dblk);
	new_line(fileid);
	myint_io.put(fileid, gblk);
	put(fileid, " 0.5 0.5");
	new_line(fileid);

	for i in 1..nblk loop
		myint_io.put(fileid, bshape(i));
		put(fileid," ");
		myfloat_io.put(fileid, rowcen(i));
		put(fileid," ");
		myfloat_io.put(fileid, colcen(i));
		put(fileid," ");
		if i<nblk then
		put(fileid,lett(i)); new_line(fileid);
		else
		put_line(fileid, "white");
		end if;
	end loop;

   text_io.Close (File => FileId);

end dumpGameState;




procedure test4winner is
	rc,cc: integer;
	ch: character;
	ok: boolean := true;
begin

	winner := true;

	for k in 1..dblk loop
	--for k in 1..dblk+1 loop

		rc := integer(float'rounding(+0.5+rowcen(k)));
		cc := integer(float'rounding(+0.5+colcen(k)));
		ch:= lett(k);

myassert(rc>0);
myassert(rc<3);

myassert(cc>0);
myassert(cc<7);

		if rc=1 then --first row

			case cc is
				when 1 => Ok:=(ch='p');
				when 2 => Ok:=(ch='a');
				when 3 => Ok:=(ch='n');
				when 4 => Ok:=(ch='a');
				when 5 => Ok:=(ch='m');
				when 6 => Ok:=(ch='a');
				when others => Ok:=false;
			end case;

		elsif rc=2 then -- 2nd row

			case cc is
				when 1 => Ok:=(ch='c');
				when 2 => Ok:=(ch='a');
				when 3 => Ok:=(ch='n');
				when 4 => Ok:=(ch='a');
				when 5 => Ok:=(ch='l');
				--when 6 => Ok:=(ch=' ');
				when others => Ok:=false;
			end case;

		end if;

		-- if ok=true then this block is consistent w/soln.

		winner := winner and Ok;

	end loop; -- for k


	if winner then
		dump;
	else
		dumpGameState;
	end if;

end test4winner;



-- 26oct22: simplified to read original "panama.blk"
	numblanks: constant integer := 1;
procedure init( fname: string ) is
	use ada.strings;
	fin : text_io.file_type;
	len : natural := 1;
	rcd : string(1..99) := (others=>' ');
	--nb: integer;
	grow,gcol: float; --unused
begin
	text_io.open(fin, in_file, fname);

	text_io.get_line(fin, rcd, len); -- objective-text (ignore)

	myint_io.get(fin, nrow); --2 
	myint_io.get(fin, ncol); --6 
	myint_io.get(fin, dblk); --11 #nonblank pieces
	myint_io.get(fin, gblk); --1
		myfloat_io.get(fin, grow); --0.5
		myfloat_io.get(fin, gcol); --0.5


	for i in 1..dblk loop -- define puzzle blocks
		myint_io.get(fin, bshape(i));
		myfloat_io.get(fin, rowcen(i));
		myfloat_io.get(fin, colcen(i));
		rcd:=(others=>' ');
		text_io.get_line(fin, rcd, len); -- char
		declare
			str: string := trim(rcd,both);
		begin
			lett(i) := str(1);
		end;

		idchar(i):=character'val(96+i); --a=97...z=122
		rowcen0(i):=rowcen(i);
		colcen0(i):=colcen(i);

--put(lett(i)); put(" ");
--put(rcd);
--new_line;

	end loop;


	nblk := dblk+numblanks; -- dblk+1

	for i in dblk+1..nblk loop
		myint_io.get(fin, bshape(i));
		myfloat_io.get(fin, rowcen(i));
		myfloat_io.get(fin, colcen(i));
		text_io.get_line(fin, rcd, len); -- color (ignore)
		lett(i) := ' ';

		--idchar(i):=character'val(96+i); --a=97...z=122
		rowcen0(i):=rowcen(i);
		colcen0(i):=colcen(i);

	end loop;

	text_io.close(fin);

	blank(1):=dblk+1;


	ntrail:=0;
	winner:=false;

	dumpGameState;

end init;








function same( f1, f2 : float ) return boolean is
	epsilon: constant float := 0.1;
begin
	if abs(f1-f2) < epsilon then
		return true;
	else
		return false;
	end if;
end same;





function moveleft( selBlock: integer; track: boolean ) return integer is

	ok: boolean := false;
	ret: integer := 0;
	found1, found2, found3 : integer := -1;

	s11: keytype := (others=>0);
	r,c : ushort;

	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br, bc : array(1..mxblnkz) of float;

begin

	for j in 1..numblanks loop
		br(j) := rowcen( blank(j) );
		bc(j) := colcen( blank(j) );
	end loop;





--moveLEFT
	if( shape=11 ) then


		for j in 1..numblanks loop

			if same(br(j),sr) and same(bc(j),sc-1.0) then
				found1:=blank(j);
			end if;

		end loop;

		if found1>=1 then
			colcen(selBlock) := colcen(selBlock) - 1.0;
			colcen(found1) := colcen(found1) + 1.0;
			ret:=1;
		end if;


	end if;  -- all shapes



	if track and ret>0 then


		for j in 1..dblk loop
			case bshape(j) is
				when 11 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s11(j) := endx(r,c);
				when others => null;
			end case;
		end loop;

		ntrail:=ntrail+1;
		trailenc11(ntrail):=s11;
		trailsel(ntrail):=selblock;
		trailchr(ntrail):='l';

	end if;


	return ret;

end moveleft;







function moveright( selBlock: integer; track: boolean ) return integer is

	ok: boolean := false;
	ret: integer := 0;
	found1, found2, found3 : integer := -1;

	r,c : ushort;

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

	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br, bc : array(1..mxblnkz) of float;

begin

	for j in 1..numblanks loop
		br(j) := rowcen( blank(j) );
		bc(j) := colcen( blank(j) );
	end loop;





--moveRight

	if( shape=11 ) then


		for j in 1..numblanks loop

			if same(br(j),sr) and same(bc(j),sc+1.0) then
				found1:=blank(j);
			end if;

		end loop;

		if found1>=1 then
			colcen(selBlock) := colcen(selBlock) + 1.0;
			colcen(found1) := colcen(found1) - 1.0;
			ret:=1;
		end if;


	end if;  -- all shapes



	if track and ret>0 then


		for j in 1..dblk loop
			case bshape(j) is

				when 11 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s11(j) := endx(r,c);
				when others => null;
			end case;
		end loop;


		ntrail:=ntrail+1;
		trailenc11(ntrail):=s11;
		trailsel(ntrail):=selblock;
		trailchr(ntrail):='r';

	end if;




	return ret;


end moveright;








function moveup( selBlock: integer; track: boolean ) return integer is

	ok: boolean := false;
	ret: integer := 0;
	found1, found2, found3 : integer := -1;

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

	r,c : ushort;

	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br, bc : array(1..mxblnkz) of float;

begin

	for j in 1..numblanks loop
		br(j) := rowcen( blank(j) );
		bc(j) := colcen( blank(j) );
	end loop;





--moveUp

	if( shape=11 ) then

		for j in 1..numblanks loop

			if same(br(j),sr-1.0) and same(bc(j),sc) then
				found1:=blank(j);
			end if;

		end loop;

		if found1>=1 then
			rowcen(selBlock) := rowcen(selBlock) - 1.0;
			rowcen(found1) := rowcen(found1) + 1.0;
			ret:=1;
		end if;


	end if;  -- all shapes



	if track and ret>0 then


		for j in 1..dblk loop
			case bshape(j) is

				when 11 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s11(j) := endx(r,c);

				when others => null;
			end case;
		end loop;


		ntrail:=ntrail+1;
		trailenc11(ntrail):=s11;
		trailsel(ntrail):=selblock;

		trailchr(ntrail):='u';

	end if;



	return ret;

end moveup;






function movedown( selBlock: integer; track: boolean ) return integer is


	ok: boolean := false;
	ret: integer := 0;
	found1, found2, found3 : integer := -1;

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

	r,c : ushort;

	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br, bc : array(1..mxblnkz) of float;

begin

	for j in 1..numblanks loop
		br(j) := rowcen( blank(j) );
		bc(j) := colcen( blank(j) );
	end loop;





--moveDown

	if( shape=11 ) then


		for j in 1..numblanks loop

			if same(br(j),sr+1.0) and same(bc(j),sc) then
				found1:=blank(j);
			end if;

		end loop;

		if found1>=1 then
			rowcen(selBlock) := rowcen(selBlock) + 1.0;
			rowcen(found1) := rowcen(found1) - 1.0;
			ret:=1;
		end if;


	end if;  -- all shapes



	if track and ret>0 then


		for j in 1..dblk loop
			case bshape(j) is
				when 11 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s11(j) := endx(r,c);

				when others => null;
			end case;
		end loop;


		ntrail:=ntrail+1;
		trailenc11(ntrail):=s11;
		trailsel(ntrail):=selblock;

		trailchr(ntrail):='d';

	end if;


	return ret;


end movedown;














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

	if ntrail>0 then

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

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

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

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

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

			when others => null;
		end case;


	end if;

end undo;



















procedure addifnew( okey: keytype ) is
	rec : hashrectype;
	nt: constant integer := ntrail;
	key : keytype := trailenc11(nt);
begin

	mysplay.search( key, mytree, rec, status );

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

	if status=notfound then

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

		--insert to tail of list.
		mysplay.addnode( key, rec, mytree, status );
		myassert( status=ok, 15, "addnode error" );

		test4winner;

	end if; -- not seen

end addifnew;






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

	mysplay.search( pkey, mytree, rec, status );

	if status=notfound then
		return 0;

	elsif rec.tchr = 's' or rec.tsel=0 then
		return 0;

	else

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

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

	end if;

	return k;

end getrail;




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

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

-- now, restore block configuration

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

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

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

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

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







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


	newstop:=0;

	outer:
	while  (depth<500) and (not winner) loop

		depth:=depth+1;

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

		--exit outer when oldstop=newstop;
		if oldstop=newstop then
			put("exit outer...old=new"); new_line;
			exit outer;
		end if;

		inner:
		for it in 1 .. newstop-oldstop loop


			exit inner when winner;

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

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

			restore(okey);

			block:
			for ii in 1..dblk loop

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

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

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

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

			end loop block;


			exit inner when winner;


		end loop inner;

		exit outer when winner;

	end loop outer;


end trymove;



procedure checkForUserFile( ok: out boolean ) is

begin

	ok:=false;

	-- here we should process single cmdline arg:  infilname
   if Ada.Command_Line.Argument_Count =1 then
   
     declare
       fstr : string := Ada.Command_Line.Argument(1);--File
     begin
       infilname := to_unbounded_string(fstr);
		 ok:=true;
     end; --declare

	else

		put_line("One parameter is expected:");
		put_line("1) filename,");
		myassert(false);
 
   end if;

end checkForUserFile;


	myok: boolean := false;
	key0 : keytype := (others=>0);
	rec0 : hashrectype;
	len: integer;
begin -- bfsp


	checkForUserFile(myok);
	-- defines:  infilname


	if myok then

		init( to_string(infilname) ); -- read puzzle file

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

		mysplay.addnode( key0, rec0, mytree, status );
		myassert( status=ok, 114, "bfsp addnode error" );


		trymove;

		if winner then
			put_line("Solution Found");
		else
			put_line("Failure to find solution.");
		end if;

		len := mysplay.length( mytree );
		put(integer'image(len)); put(" dead leaves still in splaylist"); new_line;
		put(integer'image(depth)); put(" depth"); new_line;

	end if;

end bfsp; --proc

