

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


-- Breadth First Search traffic-rush slider puzzle solver...
-- a brute-force solver for *.rush
--
-- 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 ">".









with splaylist;
with text_io;

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

with ada.command_line;
with ada.calendar;


procedure bfsr 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)
--type ulong is range 0..4_294_967_295; -- 2**32-1 (big enough here)
type ulong is range 0 .. 2**36-1;




	type keytype is 
	record
		sum12, sum13, sum21, sum31 : ulong;
	end record;

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



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

		if k1.sum12 < k2.sum12 then return true;
		elsif k1.sum12 > k2.sum12 then return false;

		elsif k1.sum13 < k2.sum13 then return true;
		elsif k1.sum13 > k2.sum13 then return false;

		elsif k1.sum21 < k2.sum21 then return true;
		elsif k1.sum21 > k2.sum21 then return false;

		else return (k1.sum31<k2.sum31);

		end if;
	end "<";

	function ">" (k1, k2: in keytype ) return boolean is
	begin
		if    k1.sum12 > k2.sum12 then return true;
		elsif k1.sum12 < k2.sum12 then return false;

		elsif k1.sum13 > k2.sum13 then return true;
		elsif k1.sum13 < k2.sum13 then return false;

		elsif k1.sum21 > k2.sum21 then return true;
		elsif k1.sum21 < k2.sum21 then return false;

		else return (k1.sum31>k2.sum31);

		end if;
	end ">";

	package mysplay is new splaylist( keytype, hashrectype, "<", ">" );
	use mysplay;

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


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






-- puzzles  6x6 = 6rows 6cols
-- 1<=r<=6, 1<=c<=6
function endx(r,c : ushort) return ushort is -- returns 0..35
begin
	--myassert( r>0, 10101 );
	--myassert( c>0, 10201 );
	--myassert( r<=6 );
	--myassert( c<=6 );
	return  (r-1)*6 +(c-1);
end endx;









function bitrep( e: ushort ) return ulong is -- 0<=e<=35
	l: ulong := 2**natural(e);
begin
	return l;
end bitrep;











	grow,gcol : array(1..2) of float;

	winner  : boolean := false;

	nrow,ncol,
	dblk, nblk, gblk : integer;
	maxblk : constant integer := 26;

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

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

	--blank1, blank2: integer;

	depth: integer := 0;
	infilname : unbounded_string;





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

trailenc13, trailenc12, trailenc21, 
	trailenc31 : array(1..trailmax) of ulong;


-- procedure to print out the solution path;
--
procedure dump is

	letters: array(1..maxblk) of character :=
		('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');

	fout : text_io.file_type;

begin

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

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

	new_line(fout);
	put_line(fout,"Nonblank blocks are lettered sequentially");
	put_line(fout,"according to their order in the puzzle file.");
	put_line(fout,"Thus, each move is described by a block ID");
	put_line(fout,"followed by the move direction {u,d,l,r}:");
	new_line(fout);

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

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

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


	text_io.close(fout);

end dump;





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;




procedure test4winner is
	canwin: boolean := true;
begin

if not winner then -- never overwrite first one

	for g in 1..gblk loop
	 canwin := canwin and 
	 	same( rowcen(g), grow(g) ) and
		same( colcen(g), gcol(g) );

	 	--( abs(rowcen(g)-grow(g))<0.1 ) and
	 	--( abs(colcen(g)-gcol(g))<0.1 );

	end loop;

	if canwin then
		winner:=true;
		dump;
		put_line("Solution found !!!");
	end if;

end if;
end test4winner;



procedure init( fname: string ) is
	fin : text_io.file_type;
	len : natural := 1;
	rcd : string(1..99);
begin
	text_io.open(fin, in_file, fname);

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

	myint_io.get(fin, nrow); --5
	myint_io.get(fin, ncol); --4
	myint_io.get(fin, dblk); --11
	myint_io.get(fin, gblk); --1

myassert( gblk=1, 1, "gblk wrong" );

	for g in 1..gblk loop
		myfloat_io.get(fin, grow(g)); --4.0
		myfloat_io.get(fin, gcol(g)); --2.0
	end loop;


	for i in 1..dblk 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)
		idchar(i):=character'val(96+i); --a=97...z=122
		rowcen0(i):=rowcen(i);
		colcen0(i):=colcen(i);
	end loop;


	myint_io.get(fin, nblk);
	nblk := nblk + dblk;

	-- now read the blank spaces:
	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)
		idchar(i):=character'val(96+i); --a=97...z=122
		rowcen0(i):=rowcen(i);
		colcen0(i):=colcen(i);

		myassert( bshape(i)=11, 2, "bad blank shape");
	end loop;



	text_io.close(fin);

	ntrail:=0;
	winner:=false;

end init;







function moveleft( selBlock: integer; track: boolean ) return integer is
	s13,s12,s21,s31: ulong := 0;
	r,c : ushort;
	ret: integer := 0;
	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br,bc : float;
	blank: integer;

begin

-- we first determine if a move is possible...
-- define where a blank is needed, then see if it is there:
br:=sr;
if shape=12 then bc:=sc-1.5;
elsif shape=13 then bc:=sc-2.0; end if;

if shape=12 or shape=13 then
for i in dblk+1..nblk loop
	--if rowcen(i)=br and colcen(i)=bc then
	if same(rowcen(i),br) and same(colcen(i),bc) then
		blank:=i; ret:=1;
	end if;
end loop;
end if;

if ret>0 then -- move is possible

	if( shape=12 ) then

		colcen(selBlock) := sc-1.0;
		colcen(blank) := bc+2.0;

	elsif( shape=13 ) then

		colcen(selBlock) := sc-1.0;
		colcen(blank) := bc+3.0;

	end if;

end if; --ret>0



	if track and ret>0 then
		s13:=0; s12:=0; s21:=0; s31:=0;
		for j in 1..dblk loop
			case bshape(j) is

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

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

				when 13 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)-0.5 ) );
					s13 := s13 + bitrep( endx(r,c) );

				when 31 =>
					r := ushort( float'rounding( rowcen(j)-0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s31 := s31 + bitrep( endx(r,c) );

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

		ntrail:=ntrail+1;
		trailenc12(ntrail):=s12;
		trailenc21(ntrail):=s21;
		trailenc13(ntrail):=s13;
		trailenc31(ntrail):=s31;
		trailsel(ntrail):=selblock;
		trailchr(ntrail):='l';

	end if;


	return ret;

end moveleft;










function moveright( selBlock: integer; track: boolean ) return integer is
	s13,s12,s21,s31: ulong := 0;
	r,c : ushort;
	ret: integer := 0;
	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br,bc : float;
	blank: integer;

begin

-- we first determine if a move is possible...
-- define where a blank is needed, then see if it is there:
br:=sr;
if shape=12 then bc:=sc+1.5;
elsif shape=13 then bc:=sc+2.0; end if;

if shape=12 or shape=13 then
for i in dblk+1..nblk loop
	--if rowcen(i)=br and colcen(i)=bc then
	if same(rowcen(i),br) and same(colcen(i),bc) then
		blank:=i; ret:=1;
	end if;
end loop;
end if;

if ret>0 then -- move is feasible

	if( shape=12 ) then

		colcen(selBlock) := sc+1.0;
		colcen(blank) := bc-2.0;

	elsif( shape=13 ) then

		colcen(selBlock) := sc+1.0;
		colcen(blank) := bc-3.0;

	end if;

end if; -- ret>0




	if track and ret>0 then
		s13:=0; s12:=0; s21:=0; s31:=0;
		for j in 1..dblk loop
			case bshape(j) is

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

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

				when 13 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)-0.5 ) );
					s13 := s13 + bitrep( endx(r,c) );

				when 31 =>
					r := ushort( float'rounding( rowcen(j)-0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s31 := s31 + bitrep( endx(r,c) );

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

		ntrail:=ntrail+1;
		trailenc12(ntrail):=s12;
		trailenc21(ntrail):=s21;
		trailenc13(ntrail):=s13;
		trailenc31(ntrail):=s31;
		trailsel(ntrail):=selblock;
		trailchr(ntrail):='r';

	end if;




	return ret;


end moveright;








function moveup( selBlock: integer; track: boolean ) return integer is
	s13,s12,s21,s31: ulong := 0;
	r,c : ushort;
	ret: integer := 0;
	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br,bc : float;
	blank: integer;

begin

-- we first determine if a move is possible...
-- define where a blank is needed, then see if it is there:
bc:=sc;
if shape=21 then br:=sr-1.5;
elsif shape=31 then br:=sr-2.0; end if;

if shape=21 or shape=31 then
for i in dblk+1..nblk loop
	--if rowcen(i)=br and colcen(i)=bc then
	if same(rowcen(i),br) and same(colcen(i),bc) then
		blank:=i; ret:=1;
	end if;
end loop;
end if;

if ret>0 then -- move is feasible

	if( shape=21 ) then

		rowcen(selBlock) := sr-1.0;
		rowcen(blank) := br+2.0;

	elsif( shape=31 ) then

		rowcen(selBlock) := sr-1.0;
		rowcen(blank) := br+3.0;

	end if;

end if; -- ret>0



	if track and ret>0 then
		s13:=0; s12:=0; s21:=0; s31:=0;
		for j in 1..dblk loop
			case bshape(j) is

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

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

				when 13 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)-0.5 ) );
					s13 := s13 + bitrep( endx(r,c) );

				when 31 =>
					r := ushort( float'rounding( rowcen(j)-0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s31 := s31 + bitrep( endx(r,c) );

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

		ntrail:=ntrail+1;
		trailenc12(ntrail):=s12;
		trailenc21(ntrail):=s21;
		trailenc13(ntrail):=s13;
		trailenc31(ntrail):=s31;
		trailsel(ntrail):=selblock;
		trailchr(ntrail):='u';

	end if;



	return ret;

end moveup;






function movedown( selBlock: integer; track: boolean ) return integer is
	s13,s12,s21,s31: ulong := 0;
	r,c : ushort;
	ret: integer := 0;
	sr : float := rowcen(selBlock);
	sc : float := colcen(selBlock);
	shape : integer := bshape(selBlock);

	br,bc : float;
	blank: integer;

begin

-- we first determine if a move is possible...
-- define where a blank is needed, then see if it is there:
bc:=sc;
if shape=21 then br:=sr+1.5;
elsif shape=31 then br:=sr+2.0; end if;

if shape=21 or shape=31 then
for i in dblk+1..nblk loop
	--if rowcen(i)=br and colcen(i)=bc then
	if same(rowcen(i),br) and same(colcen(i),bc) then
		blank:=i; ret:=1;
	end if;
end loop;
end if;

if ret>0 then -- move is feasible

	if( shape=21 ) then

		rowcen(selBlock) := sr+1.0;
		rowcen(blank) := br-2.0;

	elsif( shape=31 ) then

		rowcen(selBlock) := sr+1.0;
		rowcen(blank) := br-3.0;

	end if;

end if; -- ret>0



	if track and ret>0 then
		s13:=0; s12:=0; s21:=0; s31:=0;
		for j in 1..dblk loop
			case bshape(j) is

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

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

				when 13 =>
					r := ushort( float'rounding( rowcen(j)+0.5 ) );
					c := ushort( float'rounding( colcen(j)-0.5 ) );
					s13 := s13 + bitrep( endx(r,c) );

				when 31 =>
					r := ushort( float'rounding( rowcen(j)-0.5 ) );
					c := ushort( float'rounding( colcen(j)+0.5 ) );
					s31 := s31 + bitrep( endx(r,c) );

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

		ntrail:=ntrail+1;
		trailenc12(ntrail):=s12;
		trailenc21(ntrail):=s21;
		trailenc13(ntrail):=s13;
		trailenc31(ntrail):=s31;
		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 := 
		( trailenc12(nt), trailenc13(nt), 
			trailenc21(nt), trailenc31(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);

		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 database
function getrail( pkey: keytype ) return integer is
	k: integer := 0;
	rec : hashrectype;
begin

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

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

	elsif status=notfound 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 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,");
 
   end if;

end checkForUserFile;







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


	newstop:=0;

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

		depth:=depth+1;

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

		put(" NewCfg="&integer'image(newstop-oldstop));
		put(" depth="&integer'image(depth));
		put(" TotCfg="&integer'image(newstop));
		new_line;

		exit when oldstop=newstop;



		for it in 1 .. newstop-oldstop loop

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


			for ii in 1..dblk loop

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

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

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

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

			end loop;


			exit when winner;



		end loop; --it::944

		exit when winner;

	end loop; -- while::940



end trymove;


	myok: boolean;
	key0 : keytype := (0,0,0,0);
	rec0 : hashrectype;
begin -- bfsr

	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, "bfsr addnode error" );


		trymove;


		if not winner then
			put_line("Failure to find solution.");
		else
			put_line("...see solution in file rpath.txt ======================");
		end if;


	end if;

end bfsr;
