

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


-- Sokoban for ColorTerminal


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

with snd4ada_hpp;
with tput00_h;

with ada.directories;
with System;


with Interfaces.C.Strings;
with Interfaces.C;
use type interfaces.c.int;


with Interfaces.C;
use  type interfaces.c.unsigned;
with Interfaces.C.Pointers;
with interfaces.c.strings;

with unchecked_deallocation;
with ada.unchecked_conversion;
with Ada.Command_Line;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO;
with ada.numerics.generic_elementary_functions;

with gnat.os_lib;
with ada.characters.handling;


with text_io;

with ada.calendar;

with ada.strings.fixed;

with sysutils;

with GNATCOLL.Terminal;  use GNATCOLL.Terminal;
with solver;
with realtime_hpp;



procedure csok is


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



use text_io;

use interfaces.c;
use interfaces.c.strings;


	procedure Draw; --forward declaration

	package fmath is new
			Ada.Numerics.generic_elementary_functions( float );
	use fmath;

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


	mswin: constant boolean := (gnat.os_lib.directory_separator='\');

	maxmoves : constant integer := 2000;

	timeout: float := 10.0;
	solutionPath : unbounded_string;

	erase, --CAUTION:  use this flag minimally...it causes severe slowing!
	changed,
	haveSolution, waiting, playedonce,
	winner, userexit, help, details, speedup : boolean := false;
	fanfare: interfaces.c.int;



-- begin barrel data ----------------------------------------------------
	nbarrels : integer := 0;
	mxbarrels : constant integer := 512;
	barrow, barcol, recrow, reccol : array(1..mxbarrels) of integer;
	barrowset, barcolset : array(1..mxbarrels) of integer;
-- end barrel data ----------------------------------------------------

	prset, pcset : integer;
	pointset : boolean := false;
	msgShown : boolean := true;



	prsave, pcsave : array(1..maxmoves) of integer;
	nrows, ncols, pr,pc, oldpr,oldpc, oldbr,oldbc,
		newbr,newbc : integer;
	infilname : unbounded_string;
	maxlevel, step, pt : integer;



	flev, fnum : integer := 0;
	savename : unbounded_string := to_unbounded_string("games/resume.txt");

	fmax : integer;
	maxfmax : constant integer := 90;
	mylev,mxlev : array(1..maxfmax) of integer;
	gamefiles, shortname : array(1..maxfmax) of unbounded_string;


	maxrow, maxcol : constant integer := 50;
	maxsize : constant integer := maxrow*maxcol;


	wall, rcpt, barl : array(1..maxrow,1..maxcol) of boolean;
	barptr : array(1..maxrow,1..maxcol) of integer;


	type barray is array(1..mxbarrels,1..maxmoves) of integer;
	type bptr is access barray;
	barrowsave, barcolsave : bptr;
	procedure bfree is new unchecked_deallocation(barray,bptr);


	normalMode : boolean := true;

	ddxx : float := 0.0; --col correction for centroid
	ddzz : float := 0.0; --row correction for centroid

	dx,dz : float;







procedure myassert( condition : boolean;  flag: integer:=0 ) is
begin
  if condition=false then
  		put("ASSERTION Failed!  ");
		if flag /= 0 then
			put_line( "@ " & integer'image(flag) );
		end if;
		new_line;
  		raise program_error;
  end if;
end myassert;












procedure first_prep is -- main program setup
      FileId : text_io.File_Type;
		xfmax : integer;
		linestr: string(1..9);
		last: natural;
begin

	fnum:=1;
	flev:=1;

	if ada.directories.Exists( to_string(savename) ) then 
		put_line("Resume file found");
		text_io.open(fileId, in_file, to_string(savename) );

		--myint_io.get(fileId,xfmax); -- consistency check
		linestr := (others=>' ');
		text_io.get_line(fileId,linestr,last);
		myint_io.get(linestr,xfmax,last);

		if xfmax=fmax then
			--myint_io.get(fileId,fnum); -- this overrides default
			--myint_io.get(fileId,flev); -- this overrides default

			linestr := (others=>' ');
			text_io.get_line(fileId,linestr,last);
			myint_io.get(linestr,fnum,last);

			linestr := (others=>' ');
			text_io.get_line(fileId,linestr,last);
			myint_io.get(linestr,flev,last);

			myassert( fnum>=1 );  myassert( fnum<=fmax );
			myassert( flev>=1 );  myassert( flev<=mxlev(fnum) );
		else
			put_line("Old resume file has different # files...ignoring");
		end if;

		text_io.close(fileId);
	else
		put_line("No resume file found");
	end if;


end first_prep;





procedure restoreSetPoint is
	row,col : integer;
begin
	for r in 1..maxrow loop
	for c in 1..maxcol loop
		barptr(r,c):=-1;
		barl(r,c):=false;
	end loop;
	end loop;

	for i in 1..nbarrels loop
		row:=barrowset(i);
		col:=barcolset(i);
		barrow(i):=row;
		barcol(i):=col;
		barl(row,col):=true;
		barptr(row,col):=i;
	end loop;
	pr := prset;
	pc := pcset;
	oldpr := pr;
	oldpc := pc;
end restoreSetPoint;

procedure setpoint is
begin
	for i in 1..nbarrels loop
		barrowset(i):=barrow(i);
		barcolset(i):=barcol(i);
	end loop;
	prset:=pr;
	pcset:=pc;
	pointset:=true;
	msgShown:=false;
	
	changed:=true;
	draw;

end setpoint;

procedure save( nstep : integer ) is
	row,col : integer;
begin
	myassert( nstep<maxmoves );
	for i in 1..nbarrels loop
		row:=barrow(i);
		col:=barcol(i);
		barrowsave(i,nstep):=row;
		barcolsave(i,nstep):=col;
		myassert( barl(row,col)=true, 9414 );
		myassert( barptr(row,col)=i, 9415 );
	end loop;
	prsave(nstep):=pr;
	pcsave(nstep):=pc;
end save;

procedure restore( nstep : integer ) is
	row,col : integer;
begin
	for r in 1..maxrow loop
	for c in 1..maxcol loop
		barptr(r,c):=-1;
		barl(r,c):=false;
	end loop;
	end loop;

	for i in 1..nbarrels loop
		row:=barrowsave(i,nstep);
		col:=barcolsave(i,nstep);
		barrow(i):=row;
		barcol(i):=col;
		barl(row,col):=true;
		barptr(row,col):=i;
	end loop;
	pr := prsave(nstep);
	pc := pcsave(nstep);
	oldpr := pr;
	oldpc := pc;
end restore;




-- Warning:  this logic might not yet be fully generalized...
--
-- "len" is set by get_line...
--
function is_blank( line : string; len:integer ) return boolean is
	ch1,ch2: character;
begin

	if( len < 1 ) then 
		return true; 
	end if;

	ch1 := line( line'first );

	if ada.characters.handling.is_line_terminator(ch1) then
		return true;
	end if;

	if( len < 2 ) then 
		return true; 
	end if;

	ch2 := line( line'first+1 );

	if  ( ch1=':' ) and ( ch2=':' ) then 
		return true; 
	end if;

	for i in 1..len loop
	  	if( line(i) = '#' ) then 
	  		return false;
		elsif( line(i) /= ' ' ) then
			return true;
		end if;
	end loop;
	return true;

end is_blank;





-- this proc saves current game state to a file
-- ...to solve call "ibox x.sok 1 1"
procedure dump( fname: string ) is
	goal,fence,box,pusher: boolean;
	fout : text_io.file_type;
begin

	text_io.create(fout, out_file, fname);
	for row in 1..nrows loop
	for col in 1..ncols loop
		goal := rcpt(row,col);
		fence := wall(row,col);
		pusher:=(pr=row) and (pc=col);
		box:=barl(row,col);

		if goal and box then
			put(fout,'*');
		elsif goal and pusher then
			put(fout,'+');
		elsif pusher then
			put(fout,'@');
		elsif box then
			put(fout,'$');
		elsif goal then
			put(fout,'.');
		elsif fence then
			put(fout,'#');
		else -- space
			put(fout,' ');
		end if;

	end loop;
	new_line(fout);
	end loop; --row
	new_line(fout);
	text_io.close(fout);

end dump;




procedure readPuzzle( srchdir: unbounded_string ) is
  gfil : file_type;
  l1,l2: natural := 1;
  rcd1, rcd2: string(1..maxcol);
  lvl0 : integer := flev-1;
  lv : integer := 0;
  nrcpt : integer := 0;
  row : integer;
begin


	myassert( flev >= 1, 1001 );
	myassert( flev <= mxlev(fnum), 1002 );

	for b in 1..mxbarrels loop
		barrow(b):=-1;
		barcol(b):=-1;
	end loop;

	for r in 1..maxrow loop
	for c in 1..maxcol loop
		wall(r,c):=false;
		barl(r,c):=false;
		rcpt(r,c):=false;
		barptr(r,c):= -1;
	end loop;
	end loop;
	nbarrels:=0;
	nrcpt:=0;


if normalMode then
   text_io.open( 
		file=> gfil, 
		name=> to_string( gamefiles(fnum) ), 
		mode=>text_io.in_file);
else
   text_io.open( 
		file=> gfil, 
		name=> to_string(srchdir&infilname),
		mode=>text_io.in_file);
end if;

--put_line("flev="&integer'image(flev));

	while( lv < lvl0 ) loop

		 rcd2:=(others=>' ');
     text_io.get_line(gfil, rcd2, l2); 

		--get 1st nonblank into rcd2
     while( is_blank(rcd2,l2) ) loop
	    rcd1:=rcd2;  l1:=l2;  
		 rcd2:=(others=>' ');
       text_io.get_line(gfil, rcd2, l2); 
     end loop;
	  -- rcd2 is 1st nonblank

	--go to end of data block:
	  while( not is_blank(rcd2,l2) ) loop
	  	 rcd1:=rcd2; l1:=l2;
		 rcd2:=(others=>' ');
       text_io.get_line(gfil, rcd2, l2);
	 end loop;
	 lv := lv+1; -- 1-based block count

	end loop;


	 rcd2:=(others=>' ');
    text_io.get_line(gfil, rcd2, l2); 

	--get 1st nonblank into rcd2
    while( is_blank(rcd2,l2) ) loop 
	    rcd1:=rcd2;  l1:=l2;
		 rcd2:=(others=>' ');
       text_io.get_line(gfil, rcd2, l2); 
    end loop;
	-- rcd2 is 1st nonblank


-- we should now be in the right place with rcd2 holding 1st pattern

		if 
			--rcd(l2) /= ' ' and
			rcd2(l2) /= '#' and
			rcd2(l2) /= '$' and
			rcd2(l2) /= '.' and
			rcd2(l2) /= '+' and
			rcd2(l2) /= '*' and
			rcd2(l2) /= '@' 
		then
			l2:=l2-1;
		end if;
		--elliminate cr,lf 11jan16

--put_line(" 1st line: |"&rcd2(1..l2)&"| len="&natural'image(l2));

	nrows:=0; ncols:=0;
	loop 
		rcd1:=rcd2; l1:=l2;
		nrows := nrows + 1;
		row := nrows; -- local variable with nicer name
		--NOTE:  this (row,col) is 1-based !

		if( l1>ncols ) then ncols:=l1; end if;
		for col in 1..l1 loop
			case rcd1(col) is
			when '#' =>  --wall
				wall(row,col):=true;

			when ' ' => --space
				wall(row,col):=false;
				null;

			when '.' =>  --goal
				rcpt(row,col):=true;
				nrcpt:=nrcpt+1;
				recrow(nrcpt):=row;
				reccol(nrcpt):=col;

			when '$' =>  --box
				barl(row,col):=true;
				nbarrels:=nbarrels+1;
				barrow(nbarrels):=row;
				barcol(nbarrels):=col;
				barptr(row,col):=nbarrels;

			when '@' =>  --pusher
				pr:=row;
				pc:=col;
				oldpr:=pr; oldpc:=pc;

			when '+' =>  -- goal + pusher
				rcpt(row,col):=true;
				nrcpt:=nrcpt+1;
				recrow(nrcpt):=row;
				reccol(nrcpt):=col;
				pr:=row;
				pc:=col;
				oldpr:=pr; oldpc:=pc;

			when '*' =>  -- both goal and barrel
				rcpt(row,col):=true;
				nrcpt:=nrcpt+1;
				recrow(nrcpt):=row;
				reccol(nrcpt):=col;
				barl(row,col):=true;
				nbarrels:=nbarrels+1;
				barrow(nbarrels):=row;
				barcol(nbarrels):=col;
				barptr(row,col):=nbarrels;

			when others => -- treat as space
				wall(row,col):=false;
				null;

			end case;

		end loop; --col

		exit when end_of_file(gfil); -- 26feb15 critical addendum
		 rcd2:=(others=>' ');
		text_io.get_line(gfil, rcd2, l2); --l2 includes control char...

		exit when is_blank(rcd2,l2);

		if 
			--rcd(l2) /= ' ' and
			rcd2(l2) /= '#' and
			rcd2(l2) /= '$' and
			rcd2(l2) /= '.' and
			rcd2(l2) /= '+' and
			rcd2(l2) /= '*' and
			rcd2(l2) /= '@' 
		then
			l2:=l2-1;
		end if;
		--elliminate cr,lf 11jan16

--put_line("next line: |"&rcd2(1..l2)&"| len="&natural'image(l2));

	end loop;

--put_line("=================EOF==============");

   text_io.close(gfil);

	step:=1;
	save(step);


	myassert( nbarrels = nrcpt, 1005 );
	myassert( nbarrels <= mxbarrels, 1006 );
	myassert( nrows <= maxrow, 1007 );
	myassert( ncols < maxcol, 1008 ); -- need 1 extra char for EOL

	-- set the centroid adjustment for short, wide puzzles
	ddzz:=0.0;
	ddxx:=0.0;
	if ncols > nrows then
		ddzz := 0.5*float(ncols-nrows);
	elsif nrows > ncols then
		ddxx := 0.5*float(nrows-ncols);
	end if;

end readPuzzle;


procedure restart( srchdir: unbounded_string ) is
	maxrc : integer;
	tstr : string := to_string(shortname(fnum))&", #"&integer'image(flev);
	cptr : chars_ptr := 
		new_string("Sokerban:  "&tstr&"   type <?> for Help");
	title : interfaces.c.char_array := value(cptr);
begin

-- note: initiating rigor of limiting screen output to "draw":
--	if normalMode then
--		put_line("File: "&shortname(fnum)
--			&", fnum="&integer'image(fnum)
--			&", flev "&integer'image(flev));
--	else
--		put_line("File: "&infilname
--			&", flev "&integer'image(flev));
--	end if;


	if pointset then
		restoresetpoint;
	else
		readpuzzle(srchdir);
	end if;

	--put_line("rows="&integer'image(nrows)&", cols="&integer'image(ncols));

	pt:=0;
	if ncols>nrows then
		maxrc:=ncols;
	else
		maxrc:=nrows;
	end if;
	dx := 1.0/float(maxrc); -- based on [0..+1]
	dz := dx;


	playedonce:=false;
	winner:=false;

end restart;


procedure test4win is
begin
  winner:=true;
  for r in 1..nrows loop
  for c in 1..ncols loop
  if rcpt(r,c) and not barl(r,c)  then 
  		winner:=false; 
  end if;
  end loop;
  end loop;

  --if winner then
  --  put_line(" Winner ! " );
  --end if;
  
end test4win;


function testup return boolean is
begin

	if pr=1 then return false; -- edge blocks pusher

	elsif pr=2 then

		if barl(pr-1,pc) or wall(pr-1,pc) then
			return false; -- barrel or wall blocks pusher
		else
			return true;
		end if;

	else -- pr>2

		if wall(pr-1,pc) then return false; -- wall blocks pusher

		elsif barl(pr-1,pc) and wall(pr-2,pc) then return false; --wall blocks barrel

		elsif barl(pr-1,pc) and barl(pr-2,pc) then return false; --2 barrels block

		else return true;

		end if;

	end if;

end testup;

function testdown return boolean is
begin

	if pr=nrows then return false; -- edge blocks pusher

	elsif pr=nrows-1 then

		if barl(pr+1,pc) or wall(pr+1,pc) then
			return false; -- barrel or wall blocks pusher
		else
			return true;
		end if;

	else -- pr<=nrows-2

		if wall(pr+1,pc) then return false; -- wall blocks pusher

		elsif barl(pr+1,pc) and wall(pr+2,pc) then return false; --wall blocks barrel

		elsif barl(pr+1,pc) and barl(pr+2,pc) then return false; --2 barrels block

		else return true;

		end if;

	end if;

end testdown;













function testleft return boolean is
begin

	if pc=1 then return false; -- edge blocks pusher

	elsif pc=2 then

		if barl(pr,pc-1) or wall(pr,pc-1) then
			return false; -- barrel or wall blocks pusher
		else
			return true;
		end if;

	else -- pc>2

		if wall(pr,pc-1) then return false; -- wall blocks pusher

		elsif barl(pr,pc-1) and wall(pr,pc-2) then return false; --wall blocks barrel

		elsif barl(pr,pc-1) and barl(pr,pc-2) then return false; --2 barrels block

		else return true;

		end if;

	end if;

end testleft;

function testright return boolean is
begin

	if pc=ncols then return false; -- edge blocks pusher

	elsif pc=ncols-1 then

		if barl(pr,pc+1) or wall(pr,pc+1) then
			return false; -- barrel or wall blocks pusher
		else
			return true;
		end if;

	else -- pc<=ncols-2

		if wall(pr,pc+1) then return false; -- wall blocks pusher

		elsif barl(pr,pc+1) and wall(pr,pc+2) then return false; --wall blocks barrel

		elsif barl(pr,pc+1) and barl(pr,pc+2) then return false; --2 barrels block

		else return true;

		end if;

	end if;

end testright;


	kickdir : character := 'u';

procedure moveup is
	b: integer;
begin
if testup then
	changed:=true;
	--if winner then erase:=true; end if;
	kickdir:='u';
	oldpr:=pr;
	oldpc:=pc;
	if pr>1 and barl(pr-1,pc) then --ball is being pushed
		barl(pr-1,pc):=false;
		barl(pr-2,pc):=true;
		oldbr:=pr-1;  oldbc:=pc;
		newbr:=pr-2;  newbc:=pc;
		b:=barptr(pr-1,pc); -- index of barrel @ old pos
		barrow(b):=newbr;
		barcol(b):=newbc;
		barptr(pr-2,pc):=b; -- [same] index of barrel, but @ new pos
		barptr(pr-1,pc):=-1;
	end if;
	pr:=pr-1;
	step:=step+1;
	save(step);
	pt := pt+1;
	test4win;
end if;
end moveup;

procedure movedown is
	b: integer;
begin
if testdown then
	changed:=true;
	--if winner then erase:=true; end if;
	kickdir:='d';
	oldpr:=pr;
	oldpc:=pc;
	if pr<nrows and barl(pr+1,pc) then --ball is being pushed
		barl(pr+1,pc):=false;
		barl(pr+2,pc):=true;
		oldbr:=pr+1;  oldbc:=pc;
		newbr:=pr+2;  newbc:=pc;
		b:=barptr(pr+1,pc); -- index of barrel @ old pos
		barrow(b):=newbr;
		barcol(b):=newbc;
		barptr(pr+2,pc):=b; -- [same] index of barrel, but @ new pos
		barptr(pr+1,pc):=-1;
	end if;
	pr:=pr+1;
	step:=step+1;
	save(step);
	pt := pt+1;
	test4win;
end if;
end movedown;

procedure moveleft is
	b: integer;
begin
if testleft then
	changed:=true;
	--if winner then erase:=true; end if;
	kickdir:='r';
	oldpr:=pr;
	oldpc:=pc;
	if pc>1 and barl(pr,pc-1) then --ball is being pushed
		barl(pr,pc-1):=false;
		barl(pr,pc-2):=true;
		oldbr:=pr;  oldbc:=pc-1;
		newbr:=pr;  newbc:=pc-2;
		b:=barptr(pr,pc-1); -- index of barrel @ old pos
		barrow(b):=newbr;
		barcol(b):=newbc;
		barptr(pr,pc-2):=b; -- [same] index of barrel, but @ new pos
		barptr(pr,pc-1):=-1;
	end if;
	pc:=pc-1;
	step:=step+1;
	save(step);
	pt := pt+1;
	test4win;
end if;
end moveleft;

procedure moveright is
	b: integer;
begin
if testright then
	changed:=true;
	--if winner then erase:=true; end if;
	kickdir:='l';
	oldpr:=pr;
	oldpc:=pc;
	if pc<ncols and barl(pr,pc+1) then --ball is being pushed
		barl(pr,pc+1):=false;
		barl(pr,pc+2):=true;
		oldbr:=pr;  oldbc:=pc+1;
		newbr:=pr;  newbc:=pc+2;
		b:=barptr(pr,pc+1); -- index of barrel @ old pos
		barrow(b):=newbr;
		barcol(b):=newbc;
		barptr(pr,pc+2):=b; -- [same] index of barrel, but @ new pos
		barptr(pr,pc+1):=-1;
	end if;
	pc:=pc+1;
	step:=step+1;
	save(step);
	pt := pt+1;
	test4win;
end if;
end moveright;

procedure undo is
begin
	step:=step-1;
	restore(step);
	pt:=pt-1;
	changed:=true;
	--if winner then erase:=true; end if;
	winner:=false;
end undo;

function signum( x : integer ) return integer is
begin
	if x>0 then
		return +1;
	elsif x<0 then
		return -1;
	else
		return 0;
	end if;
end signum;




function numeral( c : character ) return boolean is
begin
	if c='0' or c='1' or c='2' or c='3' or c='4'
	or c='5' or c='6' or c='7' or c='8' or c='9'
	then
		return true;
	else
		return false;
	end if;
end numeral;

function underscore( c: character ) return boolean is
begin
	if c='_' then
		return true;
	else
		return false;
	end if;
end underscore;

function period( c: character ) return boolean is
begin
	if c='.' then
		return true;
	else
		return false;
	end if;
end period;

















procedure Draw is

	info: terminal_info;

	Ok, ispusher, isgoal, isbox: boolean;

	-- feeble attempt to avoid repeated calls 
	-- to set_color, set_fg with same argument:
	-- m=magenta, y=yellow, r=red, g=grey, 
	-- b=blue, k=black, n=green, c=cyan
	type enum is (m,y,r,g,b,k,n,c,x); -- x => not yet set
	colr : enum := x;

	len: integer :=length(solutionPath);
	lstr: string := integer'image(len); -- 4chars or less


	use tput00_h;
begin
if changed or erase then

	changed:=false;

	info.init_for_stdout(auto);


	if erase then

		if mswin then
			SysUtils.bShell("cls", Ok); -- erase-terminal (expensive)
		else
			SysUtils.bShell("clear", Ok); -- erase-terminal (cheap)
		end if;
		erase:=false;

	else

		if mswin then

			--this method is nice and fast...
			--mainly because no system calls are involved:
			cursorHome; --note:  on all but Windows, this is fake.

		else
			SysUtils.bShell("tput cup 0 0", Ok); -- erase-terminal
		end if;

	end if;



if help then

	put_line(" CoTerminalSokoban--help-screen");
	put_line(" q,x => quit");
	put_line(" ?   => toggle-help");
	put_line(" +,- => next, previous level in current file");
	put_line(" n,p => next, previous puzzle-file");
	put_line(" u   => undo move");
	put_line(" r   => restart puzzle");
	put_line(" z   => setPoint");
	put_line(" f   => toggle colors for speed");
	put_line(" =   => AutoSolve, if possible, method #1");
	put_line(" .   => AutoSolve, if possible, method #2");
	put_line(" use arrow-keys to move pusher ><");
	put_line("=================================================");
	put_line(" The goal is to push all the red boxes [] onto the");
	put_line(" yellow goals :: to become cyan braces {}");

else --normal draw

	put_line(" CoTerminalSokoban");
	put_line(" q = quit,  ? = toggle-help");
	new_line;



-- colors available:
-- black,red,green,yellow,blue,magenta,cyan,grey
-- begin draw puzzle--------------------
   --Info.Set_Color (style=>bright); --may upset colors

	if speedup then
	Info.Set_Bg(magenta);
	Info.Set_Fg(yellow);
	colr:=y;
	else
	Info.Set_Bg(black);
	Info.Set_Fg(grey);
	colr:=g;
	end if;


	for row in 1..nrows loop
		for col in 1..ncols loop

			isgoal := rcpt(row,col);
			isbox  := barl(row,col);
			ispusher := (row=pr) and (col=pc);

			if isgoal and isbox then
				if not speedup and colr /= c then
					info.set_fg(cyan);
					colr:=c;
				end if;
				put("{}");

			elsif ispusher then --pusher or (goal+pusher)
				if not speedup and colr /= n then
					info.set_fg(green);
					colr:=n;
				end if;
				put("><");

			elsif( wall(row,col) ) then -- wall
				if not speedup and colr /= g then
					info.set_fg(grey);
					colr:=g;
				end if;
				put("##");

			elsif isbox then -- box
				if not speedup and colr /= r then
					info.set_fg(red);
					colr:=r;
				end if;
				put("[]");

			elsif isgoal then -- goal
				if not speedup and colr /= y then
					info.set_fg(yellow);
					colr:=y;
				end if;
				put("::");

			else -- blank space
				put("  ");
			end if;

		end loop; -- col
		new_line;

	end loop; -- row

   Info.Set_Color (Standard_Output, Style => Reset_All);

-- end draw puzzle----------------------

	put_line( "./games/" & to_string(shortName(fnum)) );
	put_line("...level " & integer'image(flev) );

	--caution:  do NOT change the lengths of these 3 lines,
	--          they are precisely coordinated
	if waiting then
		put_line("...please wait...         ");
	elsif haveSolution then
		put_line("press again to Solve"&lstr&"  "); --10jun19
	else
		put_line("press = or . to try solver");
	end if;


	if winner then
	   Info.Set_Color (background=>reset);
		info.set_color(foreground=>red);
		put_line("Correct !");
		put_line("...completed in "&integer'image(step)&" steps");
		if not playedonce then
			snd4ada_hpp.playSnd(fanfare);
			playedonce:=true;
		end if;
	elsif pointset and not msgShown then
		playedonce:=false;
		msgShown:=true;
		put_line("SetPoint Saved!               ");
		put_line("                              ");
	else
		playedonce:=false;
		put_line("                              ");
		put_line("                              ");
	end if;

   Info.Set_Color (Standard_Output, Style => Reset_All);

end if; --normal draw

end if; --changed
end Draw;










function goodChar(ch: character) return boolean is
begin
	if ada.characters.handling.is_letter(ch) then
		return true;
	elsif (ch='?') or (ch='=') or (ch='+') or (ch='-') or (ch='.') then
		return true;
	else
		return false;
	end if;
end;



procedure handle_key_down( ch: character; srchdir: unbounded_string ) is
	pch: character;
	fileid: text_io.file_type;
begin


-- note that arrow keys typically produce chars
-- preceded by 1 or 2 non-printable chars.
--
-- on Linux:		<home>='H'	<end>='F'
--   A		
-- D B C
--
-- or on MSWin:	<home>='G'	<end>='O'
--   H
-- K P M


if goodChar(ch) then


	case ch is


		when 'H'|'A'|'i'|'w' =>	moveup;
			haveSolution:=false;

		when 'P'|'B'|'k'|'s' =>	movedown;
			haveSolution:=false;

		when 'M'|'C'|'l'|'d' =>	moveright;
			haveSolution:=false;

		when 'K'|'D'|'j'|'a' =>	moveleft;
			haveSolution:=false;

		when 'f' => speedup:= not speedup;

		when 'x' | 'q' =>	userexit:=true;

		when '?'  => help := not help; erase:=true;

		when 'u' => undo;
			haveSolution:=false;

		when 'r' => restart(srchdir);
			haveSolution:=false;
			--erase:=true;
			changed:=true;

		when 'z' => setpoint;

		when 'n' => -- next puzzle file
			haveSolution:=false;
			if normalMode then
				mylev(fnum):=flev;
				fnum := 1 + fnum mod fmax;
				flev := mylev(fnum);
				infilname := gamefiles(fnum);
				pointset:=false;
				restart(srchdir);
				erase:=true;
			end if;

		when 'p' => -- previous puzzle file
			haveSolution:=false;
			if normalMode then
				mylev(fnum):=flev;
				fnum := fnum-1;
				if fnum<1 then
					fnum:=fmax;
				end if;
				flev := mylev(fnum);
				infilname := gamefiles(fnum);
				pointset:=false;
				restart(srchdir);
				erase:=true;
			end if;

		when '+' => -- next level in current file
			haveSolution:=false;
			if normalMode then
				if flev<mxlev(fnum) then
					flev:=flev+1;
				else
					flev:=1;
				end if;
				pointset:=false;
				restart(srchdir);
				erase:=true;
			end if;

		when '-' => -- previous level in current file
			haveSolution:=false;
			if normalMode then
				if flev>1 then
					flev:=flev-1;
				else
					flev:=mxlev(fnum);
				end if;
				pointset:=false;
				restart(srchdir);
				erase:=true;
			end if;

		when '=' | '.' => -- initiate OR continue solver

		if not winner then

			if haveSolution then

				pch:=ada.characters.handling.to_upper(element(solutionPath,1));
				delete(solutionPath,1,1);
				haveSolution:=( length(solutionPath)>0 );

				if pch='U' then
					moveup;
				elsif pch='D' then
					movedown;
				elsif pch='L' then
					moveleft;
				elsif pch='R' then
					moveright;
				else
					--error...should not occur
					haveSolution:=false;
				end if;

			else -- no solution yet

				dump("x.sok"); --saves current game state

---------------- begin solver wait -------------------------------------
				waiting:=true; changed:=true;
				Draw;

				set_unbounded_string(solutionPath, "");

				if ch='.' then
				haveSolution := solver.ibox
					(timeout,to_unbounded_string("x.sok"),1,1,solutionPath);
				else
				haveSolution := solver.puller
					(timeout,to_unbounded_string("x.sok"),1,1,solutionPath);
				end if;

				waiting:=false;
				changed:=true; --force redraw to show message, if any
---------------- end solver wait -------------------------------------

			end if; --haveSolution
		end if; --not winner


		when others => changed:=false;

	end case;

end if;

	-- messages here are immediately erased
	-- unless we pause for user input like this:
	-- ...print informative message...
	-- ...put_line("hit any key after reading debug message");
	-- get_immediate(ch); -- ch: character

end handle_key_down;
















use ada.directories;

	nc1,nc2, ncc : integer := 0;
	numstr : string(1..5) := (others=>' ');

	search : search_type;
	directory_entry : directory_entry_type;
	totgame, nlevels : integer := 0;

	tfile : text_io.file_type;
	ch : character;




procedure sortGames is
	ubstr: unbounded_string;
	nsav: integer;
	use ada.characters.handling;
begin
	-- it seems file search does not return a sorted list...
	-- this proc sorts shortName(),gamefiles(),mxlev() arrays

	-- begin bubble sort on 1st char
	for i in reverse 1..fmax loop
		for j in reverse 1..i-1 loop
			--case-aware UBstring sort:
			--if shortName(i) < shortName(j) then

			--case-unaware first letter sort
			--if to_lower(element(shortName(i),1)) 
			--	< to_lower(element(shortName(j),1)) then

			--case-unaware string sort:
			if   to_lower(to_string(shortName(i))) 
				< to_lower(to_string(shortName(j))) then

				--swap i/j
				ubstr := shortName(i);
				shortName(i) := shortName(j);
				shortName(j) := ubstr;

				ubstr := gamefiles(i);
				gamefiles(i) := gamefiles(j);
				gamefiles(j) := ubstr;

				nsav := mxlev(i);
				mxlev(i):=mxlev(j);
				mxlev(j):=nsav;

			end if;
		end loop; --j
	end loop; --i
	-- end sort

end sortGames;



procedure loadGames(gamdir: unbounded_string) is
begin

------- begin dynamic read of ./games/ directory -------------------------

	-- find *.sok files under ./games/
	put_line("Here are the sok files found under ./games/ :");
	totgame:=0;
	start_search( search, to_string(gamdir), "*.sok" );
	while more_entries( search ) loop
		get_next_entry( search, directory_entry );
		totgame:=totgame+1;

--put_line("totgame="&integer'image(totgame));

		myassert( totgame <= maxfmax ,1350 );
		gamefiles(totgame)  := to_unbounded_string( full_name( directory_entry ) );
		shortName(totgame):= to_unbounded_string( simple_name(directory_entry) );
		put_line( shortName(totgame) );

		declare
			fnam : string := simple_name(directory_entry);
			frst : natural := fnam'first;
			last : natural := fnam'last;
			k : natural;
		begin -- search fnam [*_####.sok] for ####
			nc1:=frst;
			while not underscore(fnam(nc1)) loop nc1:=nc1+1; end loop;
			nc1:=nc1+1;
			nc2:=nc1;
			while not period(fnam(nc2)) loop nc2:=nc2+1; end loop;
			nc2:=nc2-1;

		--put_line(integer'image(nc1)&"..."&integer'image(nc2));

			numstr := (others=>' ');
			k:=1;
			for i in nc1..nc2 loop
				numstr(k):=fnam(i);
				k:=k+1;
			end loop;
			ncc:=k-1;
		end; --declare

		nlevels:=integer'value( numstr(1..ncc) );
		--put_line( shortName(totgame) &" #: "& integer'image(nlevels) );
		mxlev(totgame):=nlevels;

	end loop; -- while more_entries
	fmax:=totgame;
	put_line("...for a total of totgame="&integer'image(totgame));
	new_line;


------- end dynamic read of ./games/ directory --------------------------------

	sortGames;

end loadGames;






procedure initsounds( path: string ) is
begin

	snd4ada_hpp.initSnds;

	fanfare := snd4ada_hpp.initSnd(
		Interfaces.C.Strings.New_String(path&"applause.wav"),90);
	if fanfare<0 then
		put_line("snd4ada_hpp.initSnd ERROR fanfare");
		raise program_error;
	end if;

end initsounds;







surchdir : unbounded_string := to_unbounded_string("games/");
up2 : constant string := "../../";

Ok : boolean := false;



	rtime: interfaces.c.int;


	path0 : constant string(1..7)  := "sounds/";
	path1 : constant string(1..13) := "../../sounds/";


begin --csok


	if mswin then
		rtime:=realtime_hpp.hiPriority;
		-- note:  this seems necessary because some, 
		-- but not all, windows commandline terminals 
		-- seem to randomly freeze at normal priority.
	else
		rtime:=1;
	end if;



---------------- begin sound addendum --------------------------

	if ada.directories.Exists(path0) then
		initsounds(path0);
	else
		initsounds(path1);
	end if;

---------------- end sound addendum --------------------------




	if not ada.directories.exists( to_string(surchdir) ) then
		surchdir := up2 & surchdir;
		savename := up2 & savename;
	end if;


	--allocate large items on heap:
	barrowsave := new barray;
	barcolsave := new barray;


	loadGames(surchdir); --also sorts



	normalMode:=true;
	first_prep; -- init graphics/sound, defines fnum, flev
	infilname := gamefiles(fnum);
	maxlevel := mxlev(fnum);

-- NOTE:  the following is intended to allow
--        users to try their own puzzle file:

	-- here we should process cmdline args if=3:  infilname, mxlevel, flev
   if Ada.Command_Line.Argument_Count =3 then
   
     declare
       lst: natural;
       fstr : string := Ada.Command_Line.Argument(1);--File
       tstr : string := Ada.Command_Line.Argument(2);--Total
       nstr : string := Ada.Command_Line.Argument(3);--# to open 1st
     begin

       infilname := to_unbounded_string(fstr);
       myint_io.get(tstr,maxlevel,lst);
       myint_io.get(nstr,flev,lst);
		 normalMode:=false;

     end; --declare
  
  	elsif Ada.Command_Line.Argument_Count = 1 then
		declare
       lst: natural;
       fstr : string := Ada.Command_Line.Argument(1);--File
		begin
		 myfloat_io.get(fstr,timeout,lst);
		end; --declare

 
   end if;



	for i in 1..fmax loop
		mylev(i):=1;
	end loop;

	restart(surchdir);



	if mswin then
		SysUtils.bShell("cls", Ok); -- erase-terminal
	else
		SysUtils.bShell("clear", Ok); -- erase-terminal
	end if;

	changed:=true;
	Draw;
	-------------------------- main event loop begin: ---------------
   while not userexit loop

		get_immediate(ch);
		handle_key_down( ch, surchdir );
		Draw;

   end loop; 
	--------------------------- main event loop end -------------------

	bfree( barrowsave );
	bfree( barcolsave );



	if normalMode then
		text_io.create(tfile, out_file, to_string(savename) );
		put_line(tfile, integer'image( fmax )); -- only for check
		put_line(tfile, integer'image( fnum ));
		put_line(tfile, integer'image( flev ));
		text_io.close(tfile);
	end if;

	snd4ada_hpp.termSnds; --13may20

		if mswin then
			SysUtils.bShell("cls", Ok); -- erase-terminal
		else
			SysUtils.bShell("clear", Ok); -- erase-terminal
		end if;



end csok;

