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



-- Hungarian version Box Search Method using 4 fPQs


with ada.integer_text_io;
with ada.float_text_io;
with hungarian;
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 utils;


procedure hbox4 is


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

	use text_io;
	use utils;



	pqstatus: mypqtype.statustype;
	exstatus: mysplaytype.statustype;

	ibestcost,ibestpred: vftype;

	solutionPath: unbounded_string;

	maxET: constant float := 600.0; --seconds

	omitHungarian: boolean := false; --default (just curious)
	pushOpt: boolean := false; --default (quickest soln)
	-- true => Push-Optimal + BestMoves

	timeexit, memoryexit: boolean := false;

	maxGbDefault: constant float := 7.5;
	maxGb: float := maxGbDefault;

	knodesPerGb: constant float := 2_000.0;
	-- but more precisely...
	-- hashrectype: 297 (304) bytes per node...
	-- splayrec: 376 bytes per node...
	-- 297+376 bytes per splayrec+data = 673 ~ 680 bytes per node
	-- => 2000 nodes = 1.3mb => 1.3gb per 2m nodes
	-- => 1gb per 1.540m nodes ???







procedure pullup(
	orec: in  hashrectype;
	okey: in  keytype;
	xbr,xbc: in ushort
	) is

	br: ushort := xbr;
	bc: ushort := xbc;
	pr: ushort := br-1;
	pc: ushort := bc;
	ob: constant ushort := indx(br,bc);
	op: constant ushort := indx(pr,pc);
	obr: constant ushort := br;
	obc: constant ushort := bc;
	xplz: ushort := orec.totpulz;
	xmvz: ushort := orec.totmovz;
	mvz: ushort := dppathexists(pr,pc,ibestcost);

begin
	if mvz<254 and testup(br,bc) 
	then 

		vf(ob):=0;
		vf(op):=1;

		br:=pr; bc:=pc;
		pr:=pr-1;
		xplz:=xplz+1;
		xmvz:=xmvz+mvz+1;

		if omitHungarian then
			saveifnew4e(orec,okey,0,xplz,xmvz,pr,pc,br,bc);
		elsif pushOpt then
			hsaveifnew4e(orec,okey,0,xplz,xmvz,pr,pc,br,bc);
		else
			hsaveifnew4(orec,okey,0,xplz,xmvz,pr,pc,br,bc);
		end if;

		vf(op):=0;
		vf(ob):=1;

	end if;
end pullup;


procedure pulldown(
	orec: in  hashrectype;
	okey: in  keytype;  
	xbr,xbc: in ushort
	) is

	br: ushort := xbr;
	bc: ushort := xbc;
	pr: ushort := br+1;
	pc: ushort := bc;
	ob: constant ushort := indx(br,bc);
	op: constant ushort := indx(pr,pc);
	obr: constant ushort := br;
	obc: constant ushort := bc;
	xplz: ushort := orec.totpulz;
	xmvz: ushort := orec.totmovz;
	mvz: ushort := dppathexists(pr,pc,ibestcost);

begin
	if mvz<254 and testdown(br,bc)
	then 

		vf(ob):=0;
		vf(op):=1;

		br:=pr; bc:=pc;
		pr:=pr+1;
		xplz:=xplz+1;
		xmvz:=xmvz+mvz+1;

		if omitHungarian then
			saveifnew4e(orec,okey,1,xplz,xmvz,pr,pc,br,bc);
		elsif pushOpt then
			hsaveifnew4e(orec,okey,1,xplz,xmvz,pr,pc,br,bc);
		else
			hsaveifnew4(orec,okey,1,xplz,xmvz,pr,pc,br,bc);
		end if;

		vf(op):=0;
		vf(ob):=1;

	end if;
end pulldown;


procedure pullleft(
	orec: in  hashrectype;
	okey: in  keytype;  
	xbr,xbc: in ushort
	) is

	br: ushort := xbr;
	bc: ushort := xbc;
	pr: ushort := br;
	pc: ushort := bc-1;
	ob: constant ushort := indx(br,bc);
	op: constant ushort := indx(pr,pc);
	obr: constant ushort := br;
	obc: constant ushort := bc;
	xplz: ushort := orec.totpulz;
	xmvz: ushort := orec.totmovz;
	mvz: ushort := dppathexists(pr,pc,ibestcost);

begin
	if mvz<254 and testleft(br,bc)
	then 

		vf(ob):=0;
		vf(op):=1;

		br:=pr; bc:=pc;
		pc:=pc-1;
		xplz:=xplz+1;
		xmvz:=xmvz+mvz+1;

		if omitHungarian then
			saveifnew4e(orec,okey,3,xplz,xmvz,pr,pc,br,bc);
		elsif pushOpt then
			hsaveifnew4e(orec,okey,3,xplz,xmvz,pr,pc,br,bc);
		else
			hsaveifnew4(orec,okey,3,xplz,xmvz,pr,pc,br,bc);
		end if;

		vf(op):=0;
		vf(ob):=1;

	end if;
end pullleft;


procedure pullright(
	orec: in  hashrectype;
	okey: in  keytype;  
	xbr,xbc: in ushort
	) is

	br: ushort := xbr;
	bc: ushort := xbc;
	pr: ushort := br;
	pc: ushort := bc+1;
	ob: constant ushort := indx(br,bc);
	op: constant ushort := indx(pr,pc);
	obr: constant ushort := br;
	obc: constant ushort := bc;
	xplz: ushort := orec.totpulz;
	xmvz: ushort := orec.totmovz;
	mvz: ushort := dppathexists(pr,pc,ibestcost);

begin
	if mvz<254 and testright(br,bc)
	then 

		vf(ob):=0;
		vf(op):=1;

		br:=pr; bc:=pc;
		pc:=pc+1;
		xplz:=xplz+1;
		xmvz:=xmvz+mvz+1;

		if omitHungarian then
			saveifnew4e(orec,okey,2,xplz,xmvz,pr,pc,br,bc);
		elsif pushOpt then
			hsaveifnew4e(orec,okey,2,xplz,xmvz,pr,pc,br,bc);
		else
			hsaveifnew4(orec,okey,2,xplz,xmvz,pr,pc,br,bc);
		end if;

		vf(op):=0;
		vf(ob):=1;

	end if;
end pullright;





procedure trymove is
	use mypqtype;
	use mysplaytype;

	rec: hashrectype;

	bog: array(0..3) of integer := (others=>0);

	k,avg4,abog,
	bestbog,
	pri0,pri1,pri2,pri3,pri4: integer := 0;

	iboxes: constant integer := integer(nboxes);

	key: keytype;

	fstat: mypqtype.StatusType;
	estatus: mysplaytype.StatusType;

	tfile: text_io.file_type;

	et: float;

	xr,xc, vpr,vpc,
	ii : ushort := 0;

	nbog,
	olef, ile,ilf : integer := 0;

	gb: float := 0.0;
	knodes, pcmem, robin: integer := 0;
	--robin0     t7 o2
	-- 0,4=>1 : 2.3 16.5
	-- 3 => 4 : 4.2 35
	-- 2 => 3 : 5.1 54
	-- 1 => 2 : 2.5 52

begin --trymove


olef:=0;


outer_main:
loop

	ilf:=mypqtype.length(frontier);
	ile:=mysplaytype.length(explored);


	if ile+ilf > olef + 99_999 then
		olef := ile+ilf;

		tsec1:=ada.calendar.seconds(ada.calendar.clock);
		et := float(tsec1-tsec0);


		put(" Ex(k)="&itrim(ile/1000));
		put(" Fr(k)="&itrim(ilf/1000));

		put(" avg4="&itrim(avg4));
		put(" abog="&itrim(abog));

		put(" best="&itrim(bestbog)&"/"&utrim(nboxes));
		put(" ET="); put(et,0,2,0);

		knodes := ile/1000 + ilf/1000;

		gb:=float(knodes)/knodesPerGb;
		put(" %mem="); put( 100.0*gb/maxGb, 0,1,0);
		new_line;


		if length(outfilname)>1 then --append to output file

			text_io.open(tfile, append_file, to_string(outfilname));
			put(tfile," best="&itrim(bestbog)&"/"&utrim(nboxes));
			put(tfile," ET="); put(tfile,et,0,2,0);

			put(tfile," %mem="); put(tfile, 100.0*gb/maxGb, 0,1,0);
			new_line(tfile);
			text_io.close(tfile);

		end if; --3mar21 addendum end


		if gb > maxGb then
			memoryexit:=true;
			exit outer_main; --quit: low memory
		end if;

		if et > maxET then
			timeexit:=true;
			exit outer_main;
		end if;

	end if;


	exit outer_main when ilf=0;


-- set round robin control parameters:

	--default round robin:
	robin := (robin+1) mod 4; -- {0,1,2,3}

	abog := (avg4+bestbog)/2; --progress measure...
	--compromise between immediate trend & overall progress



	if bestbog>3*iboxes/4 then --hbox3 very good
		robin:=0; skip3:=true;
		-- => skip expensive countCorrals ftn (& 2others)
	end if;

-- Reasoning behind above control-settings for "robin":
-- It is often true near the beginning and endgame
-- that there are many corrals and blocked rooms.
-- Thus, one initially needs to have all 4 measures in 
-- play to unblock them. Eventually around mid-puzzle 
-- the blockages have been reduced, so one can focus more 
-- on the single measure #BOG. And since one can also expect 
-- blockages @ endgame, we avoid resisting that by ignoring 
-- measures 2,3,4 near endgame.
-- Remember too, this solver is a puller that works backwards.

--pri#1: nb-bog [0=>all boxes on goal]
--pri#2: nCorr - 1
--pri#3: nBlRoom
--pri#4: nBlBox




	case robin is

	when 0 => -- pri1 = #Boxes - #BOG

		mypqtype.popNode(frontier,key,rec,1,pri1,pri2,pri3,pri4,pri0,fstat);

	when 1 => -- pri2 = #corrals - 1

		mypqtype.popNode(frontier,key,rec,2,pri1,pri2,pri3,pri4,pri0,fstat);

	when 2 => --pri3 = #blockedRooms

		mypqtype.popNode(frontier,key,rec,3,pri1,pri2,pri3,pri4,pri0,fstat);

	when 3 => --pri4 = #blockedBoxes

		mypqtype.popNode(frontier,key,rec,4,pri1,pri2,pri3,pri4,pri0,fstat);

	when others => null;
	end case;

	nbog := iboxes - pri1;

	k:=(k+1) mod 4;
	bog(k):=nbog;
	avg4 := ( bog(0)+bog(1)+bog(2)+bog(3) ) / 4;
	-- previous 4 readings shows recent trend

	if nbog>bestbog then bestbog:=nbog; end if;



		--add to {explored}
		mysplaytype.addnode( key, rec, explored, estatus);


		swinnertest(solutionPath, key, rec);
		exit outer_main when winner;


		if 
			estatus=Ok -- avoid dupid [Ok => noDup]
		then

			restore2(vf,rec,vpr,vpc);


			--find puller bestcost for each loc in p-corral
			--so that dpPathExists() works correctly within pull*
			dppathprep(vpr,vpc,ibestcost,ibestpred);

			for br in ushort range 2..nrows-1 loop
			for bc in ushort range 2..ncols-1 loop
			if vf( indx(br,bc) ) = 1 then

				pullup(rec,key,br,bc);

				pullright(rec,key,br,bc);

				pulldown(rec,key,br,bc);

				pullleft(rec,key,br,bc);

			end if;
			end loop;
			end loop;

		end if; --status not dupId-------------------------------------------



end loop outer_main;


end trymove;






	tfile: text_io.file_type;

	len, upper, min,sec,sec0: integer := 0;

	Ok: boolean;

begin -- box


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


	if Ok then



		if length(outfilname)>1 then --output to file
			text_io.create(tfile, out_file, to_string(outfilname));
			put_line(tfile,"hbox4 log file");
			text_io.close(tfile);
		end if;



		winner:=false;

		readPuzzle(level); --also sets pvalid/bvalid arrays


		hungarian.inithun(vf,ff,ee,bvalid,nrows,ncols);
		-- here, bvalid is "improved" (further restricted)


-- Note that "bvalid" is NOT a minimal set of locations
-- where boxes reside without deadlock; It is a convenient
-- hungarian domain where manhattan distances define 
-- minimal costs of traversal.


	set_unbounded_string(solutionPath, "");
	myassert( length(solutionPath)=0, 98989, "initialSol" );



		hsave0(vf,ff,nrows,ncols,ee,pvalid,omitHungarian);
		findnexii; --not necessary but interesting

		tsec0:=ada.calendar.seconds(ada.calendar.clock);


		trymove;


		if not winner then

			new_line;
			if memoryexit then
				put_line(" Low Memory Abort");
			elsif timeexit then
				put_line(" Time Limit Abort");
			else
				put_line(" Failure to find solution.");
			end if;

		else

			tsec1:=ada.calendar.seconds(ada.calendar.clock);
			sec := integer(tsec1-tsec0);
			sec0 := sec;
			min := sec/60;
			sec := sec rem 60;

			put_line("Winner=========================================");

			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(" nrows:"&ushort'image(nrows));
			put_line(" ncols:"&ushort'image(ncols));

			put_line(" #boxes:"&ushort'image(gngoals));
			put_line(" #interior:"&ushort'image(savefp));

			put_line(" Puzzle File: "&to_string(infilname));
			put_line(" Level:"&integer'image(level));

			put(" ET(m:s): "); put(itrim(min)); put(":"); put(itrim(sec));
			new_line;

			put(" ET(s): "); put(itrim(sec0)); new_line;

			if length(outfilname)>1 then --output to file

				text_io.open(tfile, append_file, to_string(outfilname));

				put_line(tfile,"Solution");

				put(tfile, to_string(solutionPath) );
				new_line(tfile);
				new_line(tfile);


				put(tfile,"Moves:");
				put(tfile, integer'image( len ) );
				new_line(tfile);

				put(tfile,"Pushes:");
				put(tfile, integer'image(upper) );
				new_line(tfile);

				put_line(tfile,"Puzzle File: "&to_string(infilname));
				put_line(tfile,"Level:"&integer'image(level));


				put(tfile,"Solver_time: "); 
				put(tfile,itrim(min)); 
				put(tfile,":"); 
				put(tfile,itrim(sec));
				new_line(tfile);


				put_line(tfile,"Box: Hungarian 4 fPQ roundRobin");
				put(tfile,"MaxGb: "); put(tfile,maxGb,1,0,0); 
				new_line(tfile);
				put(tfile,"Method:");
				if omitHungarian then
					put_line(tfile," NON-Hungarian");
				elsif pushOpt then
					put_line(tfile," efficient");
				else
					put_line(tfile," fastest");
				end if;


				text_io.close(tfile);

			end if;


		end if;

		put_line(" box : Hungarian 4 fPQ roundRobin");
		put(" MaxGb: "); put(maxGb,1,0,0); new_line;
		if omitHungarian then
			put_line(" NON-Hungarian method used");
		elsif pushOpt then
			put_line(" efficient solution method used");
		else
			put_line(" fastest solution method used");
		end if;




		mysplaytype.make_empty(explored,exstatus);
		mypqtype.make_empty(frontier,pqstatus);


	end if;


exception

	when storage_error =>

		mysplaytype.make_empty(explored,exstatus);
		mypqtype.make_empty(frontier,pqstatus);
		raise;

	when others =>

		mysplaytype.make_empty(explored,exstatus);
		mypqtype.make_empty(frontier,pqstatus);
		raise;

end hbox4;
