// This include file is for games that use logical directions.
// These are named directions that function like nodes.
// In a map of the board, each space has a list of directions away from it and of which space is found in each direction.
// So, the board is made up of assigned relations between spaces, not of mathematical relations between spaces on a grid.

// RESTRICTING USER INPUT

setsystem maxmove 2;
ban commands allmoves;
allow moves 1 captures 1 promotions 2;

// Chess defaults

set wpr 2;
set bpr 7;
set wcastle c1 g1;
set bcastle c8 g8;
set wprom Q R B N;
set bprom q r b n;
set ep false;
set fps 2;
set movetype MOVE;

setconst k King;
setconst K King;
setconst q Queen;
setconst Q Queen;
setconst r Rook;
setconst R Rook;
setconst b Bishop;
setconst B Bishop;
setconst n Knight;
setconst N Knight;
setconst p Black_Pawn;
setconst P White_Pawn;

// Define promotion zones
foreach sp spaces:
  set wpz.{#sp} >= rankname #sp 8;
  set bpz.{#sp} <= rankname #sp 1;
next;

// This alternate include file for Chess is designed to use logical directions, created by means of the map and link commands.
// Logical directions are useful for boards of unusual geometries, such as circular boards, toroidal boards, or 3D boards.

map n 0 1 s 0 -1 w -1 0 e 1 0; // Orthogonal directions
map nw -1 1 ne 1 1 sw -1 -1 se 1 -1; // Diagonal directions
map nne 1 2 nnw -1 2 sse 1 -2 ssw -1 -2; // Hippogonal directions
map nee 2 1 nww -2 1 sww -2 -1 see 2 -1; // Hippogonal directions

// Vertical directions for pawns; 
// Not to be extended, since pawns must promote at the end even if a Rook could go further.
map pn 0 1 ps 0 -1; 

// FUNCTIONS AND SUBROUTINES FOR PIECES

def Bishop logride #0 #1 nw ne sw se;
def Bishop-Range lograys #0 nw sw se ne;
set Bishop-Desc "The %s may move any number of spaces in any diagonal direction until it reaches an occupied space. A diagonal direction is one that goes through opposite corners of spaces.";

def Cardinal fn Bishop #0 #1 or fn Knight #0 #1;
def Cardinal-Range merge leaps #0 1 2 rays #0 1 1;
set Cardinal-Desc "The %s may move along diagonals as a Bishop or leap as a Knight.";

def King logleap #0 #1 s n e w nw ne sw se;
def King-Range logleaps #0 nw sw se ne n w s e;
set King-Desc "The %s leaps one space in any lateral or diagonal direction. It may castle with a Rook on its first move so long as it is not in check, there is nothing in between it and the Rook, it doesn't pass through check while castling, and the Rook hasn't moved. In castling, it moves two spaces toward the Rook, and the Rook moves to the space the King passed over.";

// Since castling has the side effect of moving the Rook, this subroutine is used for actual King moves:

sub King from to:
	if not fn King #from #to:
		verify sub castle #from #to and match #to var cond isupper space #to wcastle bcastle;
	endif;
	if isupper space #to:
		set Kpos #to;
	else:
		set kpos #to;
	endif;
	return true;
endsub;

def Knight logleap #0 #1 nne nnw sse ssw nee nww sww see;
def Knight-Range logleaps #0 nne nnw sse ssw nee nww sww see;
set Knight-Desc "The %s may leap to any space that is one rank and two files away or two ranks and one file away.";

def Marshall fn Knight #0 #1 or fn Rook #0 #1;
def Marshall-Range merge rays #0 1 0 leaps #0 1 2;
set Marshall-Desc "The %s moves orthogonally as a Rook or leaps as a Knight.";

def White_Pawn
remove var ep
and logride #ep #1 n
and < rankname #1 var bpr
and logleap #0 #1 nw ne
and var ep
or and == rankname #0 var wpr logride #0 #1 n
or logleap #0 #1 n
and empty #1
and != var movetype CHECK
or and islower space #1 logleap #0 #1 nw ne
and any count var wprom == var movetype CHECK onboard where #1 pn
and <= - rank #1 rank #0 var fps
and > rank #1 rank #0;

def Black_Pawn
remove var ep
and logride #ep #1 s
and > rankname #1 var wpr
and logleap #0 #1 sw se
and var ep
or and == rankname #0 var bpr logride #0 #1 s
or logleap #0 #1 s
and empty #1
and != var movetype CHECK
or and isupper space #1 logleap #0 #1 sw se
and any count var bprom == var movetype CHECK onboard where #1 ps
and <= - rank #0 rank #1 var fps
and < rank #1 rank #0;

// Because a Pawn move may include the side effects of capturing a piece on another space or of promoting,
// these subroutines are used for actual Pawn moves:
// These routines have been generalized to accomodate the first moves of Pawns on boards of different sizes
// and to allow for initial moves longer than the double move, such as the triple move allowed in Omega Chess,
// and the extended powers of en passant capture that go along with an extended first move.
// The variables wpr and bpr define the ranks that White's and Black's Pawns start on. They assume all Pawns
// start on the same rank. The variable fps tells how far the first Pawn step can be. It defaults to 2 for Chess.

sub White_Pawn from to;
	my newpiece;
	my newmove;

	// Pawn Movement
	verify > rank #to rank #from;
	verify <= - rank #to rank #from #fps;
	if capture:
		verify logleap #from #to nw ne;
		set ep false;
	elseif and #ep logleap #from #to nw ne:
		verify logride #ep #to n;
		verify < rankname #to var bpr;
		capture #ep;
		set ep false;
	elseif > distance #to #from 1:
		verify == rankname #from #wpr;
		verify logride #from #to n;
		set ep #to;
	else:
		verify logleap #from #to n;
		set ep false;
	endif;

	// Pawn Promotion
	if not #wpz.{#to}: // Not yet in promotion zone
		say #wpz.{#to};
		if != space #to $moved:
			set name alias const alias $moved;
			die "You may not promote a" #name "until it reaches the promotion zone.";
		endif;
	elseif onboard where #to pn: // Not yet on last rank
	say "Not yet on last rank.";
		if == White_Pawn const alias space #to and count var wprom:
			print where #to ps;
			if not $answered and == mln $maxmln:
				push wprom space #to;
				askpromote #wprom;
			endif;
		elseif not match space #to var wprom and != White_Pawn const alias space #to:
			set name alias const alias $moved;
			set newname alias const alias space #to;
			set msg list "You may not promote your" #name "to a" join #newname ".<BR>";
			set msg str_replace "_" " " var msg;
			die #msg;
		endif;
	elseif count var wprom: // On last rank
		if == White_Pawn const alias space #to:
			if == count var wprom 1:
				set newpiece join list var wprom;
			set newmove join #newpiece "-dest";
			add #newpiece $dest;
				appendmove #newmove;
			else:
				askpromote #wprom;
			endif;
		elseif not match space #to var wprom:
			set name alias const alias $moved;
			set newname alias const alias space #to;
			set msg list "You may not promote your" #name "to a" join #newname ".<BR>";
			set msg str_replace "_" " " var msg;
			die #msg;
		endif;
	else:
 		set name alias const alias $moved;
		set msg list "You may not advance your" #name "to the last rank, because there is nothing you may promote it to.";
		set msg str_replace "_" " " var msg;
		die #msg;
	endif;
	set nopvc 0;
	return true;
endsub;

sub Black_Pawn from to;
	my newpiece;
	my newmove;

	// Pawn Movement
	verify < rank #to rank #from;
	verify <= - rank #to rank #from #fps;
	if capture:
		verify logleap #from #to sw se;
		set ep false;
	elseif #ep and logleap #from #to se sw:
		verify logride #ep #to s;
		verify > rankname #to var wpr;
		capture #ep;
		set ep false;
	elseif > distance #to #from 1:
		verify == rankname #from #bpr;
		verify logride #from #to s;
		set ep #to;
	else:
		verify logleap #from #to s;
		set ep false;
	endif;

	// Pawn Promotion
	if not #bpz.{#to}: // Not yet in promotion zone
		if != space #to $moved:
			set name alias const alias $moved;
			die "You may not promote a" #name "until it reaches the promotion zone.";
		endif;
	elseif onboard where #to ps: // Not yet on last rank
		if == Black_Pawn const alias space #to and count var bprom:
			if not $answered and == mln $maxmln:
				push bprom space #to;
				askpromote #bprom;
			endif;
		elseif not match space #to var bprom and != Black_Pawn const alias space #to:
			set name alias const alias $moved;
			set newname alias const alias space #to;
			set msg list "You may not promote your" #name "to a" join #newname ".<BR>";
			set msg str_replace "_" " " var msg;
			die #msg;
		endif;
	elseif count var bprom: // On last rank
		if == Black_Pawn const alias space #to:
			if == count var bprom 1:
				set newpiece join list var bprom;
			set newmove join #newpiece "-dest";
			add #newpiece $dest;
				appendmove #newmove;
			else:
				askpromote #bprom;
			endif;
		elseif not match space #to var bprom:
			set name alias const alias $moved;
			set newname alias const alias space #to;
			set msg list "You may not promote your" #name "to a" join #newname ".<BR>";
			set msg str_replace "_" " " var msg;
			die #msg;
		endif;
	else:
 		set name alias const alias $moved;
		set msg list "You may not advance your" #name "to the last rank, because there is nothing you may promote it to.";
		set msg str_replace "_" " " var msg;
		die #msg;
	endif;
	set nopvc 0;
	return true;
endsub;

def White_Pawn-Range logleaps #0 nw ne n (n n);
def Black_Pawn-Range logleaps #0 sw se s (s s);

set White_Pawn-Desc "The %s may move one space straight forward without capturing, or it may move one space diagonally forward to capture. On its first move, it may move two spaces forward without capturing so long as it isn't blocked. If this move takes it over a space an enemy Pawn could have captured it on, that %s may immediately capture it by en passant, moving to the space it passed over. On reaching the last rank, it must promote to another piece. This may be any piece except a King or another Pawn.";
set Black_Pawn-Desc var White_Pawn-Desc;

def Queen fn Bishop #0 #1 or fn Rook #0 #1;
def Queen-Range merge fn Rook-Range #0 fn Bishop-Range #0;
set Queen-Desc "The %s may move as a Rook or a Bishop.";

def Rook logride #0 #1 s n e w;
def Rook-Range lograys #0 n w s e;
set Rook-Desc "The %s may move any number of spaces in any lateral direction until it reaches an occupied space. A lateral direction is one that goes through opposite sides of spaces.";

// This subroutine checks whether a King (or other royal piece) is in check.

sub checked king:
	my from piece;
	local movetype;

	set movetype CHECK;
	if isupper cond empty var king $moved space var king:
		def enemies onlylower;
	else:
		def enemies onlyupper;
	endif;
	for (from piece) fn enemies:
		if fn const alias #piece #from var king:
			return #from;
		endif;
	next;
	return false;
endsub;

// CASTLING SUBROUTINES

// This is a generic castling subroutine for actual moves. It handles both regular castling and free castling.
// Castling is handled as a King's move, and the only argument that ever needs to be passed
// to the subroutine is an alternate destination for the piece the King is castling with.
// As long as the piece is just leaping to a space adjacent to the King on the other side,
// no arguments need to be given. The subroutine will find the piece the King may castle
// with and move it to the appropriate location if castling proves legal.

// This subroutine presumes that the positions of the King and any piece it may castle
// with are flagged at the beginning of the game, that they will be unflagged when the
// piece moves, that castling involves movement only along a rank, that the checked
// subroutine has been created for telling when a space is attacked, that it is not used
// for castling to spaces it is never legal for a King to castle to, and that #from
// and #to were set in a previous function.

sub castle from to:
	local coord RPOS RDEST xdir;

	if not flag #from:
		die A King may not castle after it moves.;
	endif;
	if capture:
		die A King may not castle to an occupied space.;
	endif;
	set xdir direction #from #to;
	if not match var xdir e w:
		die Castling is allowed only in an east or west direction, not in a #xdir direction.;
	endif;
	if not logride #from #to #xdir:
		die A King may not castle across any occupied space.;
	endif;
	set coord #to;
	do:
		set coord where #coord #xdir;
		if == #coord #from:
			die No piece was found to castle with.;
		elseif flag #coord:
			break;
		elseif == #coord #to or not onboard #coord:
			die No piece was found to castle with.;
		elseif not empty #coord:
			die The King cannot castle with the piece at #coord;
		endif;
	loop;
	set RPOS #coord;
	move #to #from; // Temporarily undo King move
	if sub checked #from:
		die A King may not castle out of check.;
	endif;
	store;
	for coord path #from #to:
		move #from #coord;
		if sub checked #coord:
			die A King may not castle through check.;
		endif;
		restore;
	next;
	move #from #to; // Redo King move
	set RDEST where #to cond == var xdir w e w;
//	unsetflag #RPOS;
	move #RPOS #RDEST;
	return true;
endsub;

// Used to evaluate possible castling moves without producing error messages.

sub castlepos from to:
	local coord RPOS RDEST xdir safe;
	verify flag #from;
	verify empty #to;
	set xdir direction #from #to;
	verify match var xdir e w;
	verify logride #from #to #xdir;
	verify not sub checked #from;
	set coord #to;
	do:
		set coord where #coord #xdir;
		verify onboard #coord;
		verify not match #coord #from #to;
		if flag #coord:
			break;
		endif;
		verify empty #coord;
	loop;
	verify flag #coord;
	set RPOS #coord;
	store;
	for coord path #from #to:
		move #from #coord;
		set safe not sub checked #coord;
		restore;
		verify #safe;
	next;
	move #from #to; // Redo King move
	set RDEST where #to cond == var xdir w e w;
	move #RPOS #RDEST;
	set safe not sub checked #to;
	restore;
	return #safe;
endsub;

// Goes through all possible moves, putting all legal moves into the array $legalmoves
// Returns false if any legal moves are found, and returns true if none are found.

sub stalemated kingpos:
	store;
	local from piece to movetype;

	set movetype MOVE;

	set king space #kingpos;
	if isupper #king:
		def friends onlyupper;
		def friend isupper #0;
		set cspaces var wcastle;
	else:
		def friends onlylower;
		def friend islower #0;
		set cspaces var bcastle;
	endif;

	store;

 // Can any piece legally move?
	for (from piece) fn friends:
		for to fn join const alias #piece "-Range" #from:
			if fn const alias #piece #from #to and not fn friend space #to and onboard #to:
				move #from #to;
				if not sub checked cond == #from #kingpos #to #kingpos:
					setlegal "{#piece} {#from}-{#to}";
				endif;
			endif;
			restore;
		next;
		if fn const alias #piece #from #from and flag permit-stationary-moves:
			if not sub checked #kingpos:
				setlegal "{#piece} {#from}-{#to}";
			endif;
		endif;
	next;
	
	

	// Castling moves are handled separately
	if > count var cspaces 0 and flag #kingpos:
		for to var cspaces:
			if sub castlepos #kingpos #to:
				setlegal "{#king} {#kingpos}-{#to}";
			endif;
		next;
	endif;
	setsystem autorules sub describe_rules;

	return not count system legalmoves;
endsub;

// Used for calculating pseudo legal moves without the overhead of checking for stalemate or checks on a King.
// Used in development for checking that piece movement has been programmed correctly.
// Not meant for use in a finished game.
// side == true for white, false for black

sub calcpseudolegal side:
	store;
	local from piece to movetype;

	set movetype MOVE;

	if var side:
		def friends onlyupper;
		def friend isupper #0;
	set cspaces var wcastle;
	else:
		def friends onlylower;
		def friend islower #0;
	set cspaces var bcastle;
	endif;

	store;

 // Can any piece legally move?
	for (from piece) fn friends:
		for to fn join const alias #piece "-Range" #from:
			if fn const alias #piece #from #to and not fn friend space #to and onboard #to:
				setlegal #from #to;
			endif;
			restore;
		next;
	next;

	return cond count system legalmoves false true;
endsub;

// Empty space, just in case.

def @ false;

// This is for handling a specific castling move written as two moves.
// It is useful when you need to distinguish a castling move from another legal move.
// It can also be used to handle free castling or simply because you want to see the 
// castling move written out more explicitly.

// The pieces to castle must be on the same rank with nothing in between them.
// Neither may move to an occupied space, and both must come from flagged spaces,
// which indicates a piece has not moved yet.

sub castle2 kingfrom kingto rookfrom rookto:
	local coord xdir;

	if not flag #kingfrom:
		die A King may not castle after it moves.;
	endif;
	if not flag #rookfrom:
		die A King may not castle with a piece that has already moved.;
	endif;
	if not match @ $lastcaptured $prevcaptured:
		die Castling to an occupied space is not allowed.;
	endif;
	if empty #kingfrom:
		move #kingto #kingfrom;
	endif;
	if empty #rookfrom:
		move #rookto #rookfrom;
	endif;
	set xdir direction #kingfrom #kingto;
	if not match var xdir e w:
		die Castling is allowed only in an east or west direction, not in a #xdir direction.;
	endif;
	if not logride #kingfrom #kingto #xdir:
		die A King may not castle across any occupied space.;
	endif;
	if not logride #rookto #rookfrom #xdir:
		dir A Rook may not castle across an occupied space.;
	endif;

	if sub checked #kingfrom:
		die A King may not castle out of check.;
	endif;
	store;
	for coord path #kingfrom #kingto:
		move #kingfrom #coord;
		if sub checked #coord:
			die A King may not castle through check.;
		endif;
		restore;
	next;
	move #kingfrom #kingto; // Redo King move
	move #rookfrom #rookto; // Redo Rook move
	unsetflag #kingfrom #rookfrom;
	if isupper space #kingto:
		set Kpos #kingto;
	else:
		set kpos #kingto;
	endif;
	return true;
endsub;

// Used to evaluate a specific possible castling move without producing error messages.
// Companion to castle2 for potential moves.

sub castlepos2 kingfrom kingto rookfrom rookto:
	local coord xdir safe;
	verify flag #kingfrom and flag #rookfrom;
	verify empty #kingto and empty #rookto;
	set xdir direction #kingfrom #kingto;
	verify match var xdir e w;
	verify logride #kingfrom #kingto #xdir;
	verify logride #rookto #rookfrom #xdir;
	verify not sub checked #kingfrom;
	store;
	for coord path #kingfrom #kingto:
		move #kingfrom #coord;
		set safe not sub checked #coord;
		restore;
		verify #safe;
	next;
	move #kingfrom #kingto; // Make King move
	move #rookfrom #rookto; // Move Rook move
	set safe not sub checked #kingto;
	restore;
	return #safe;
endsub;

// Goes through all possible moves, putting all legal moves into the array $legalmoves
// Returns false if any legal moves are found, and returns true if none are found.
// Like stalemated except that it uses castlepos2 for checking castling moves.

sub stalemated2 kingpos:
	store;
	local from piece to movetype pr;

	set movetype MOVE;

	set king alias space #kingpos;
	if hasupper #king:
		def friends onlyupper;
		def friend isupper #0;
		set cspaces var wcastle;
	else:
		def friends onlylower;
		def friend islower #0;
		set cspaces var bcastle;
	endif;

	store;

 // Can any piece legally move?
	for (from piece) fn friends:
		for to fn join const alias #piece "-Range" #from:
			if fn const alias #piece #from #to and not fn friend space #to and onboard #to:
				move #from #to;
				if not sub checked cond == #from #kingpos #to #kingpos:
					setlegal "{#piece} {#from}-{#to}";
				endif;
			endif;
			restore;
		next;
	next;

	// Castling moves are handled separately
	if > count var cspaces 0 and flag #kingpos:
		for mvs var cspaces:
			if sub castlepos2 #mvs.0 #mvs.1 #mvs.2 #mvs.3 and == #kingpos #mvs.0:
				set pr alias space #mvs.2;
				setlegal "{#king} {#mvs.0}-{#mvs.1}; {#pr} {#mvs.2}-{#mvs.3}";
			endif;
		next;
	endif;
	
	setsystem autorules sub describe_rules;

	// All done. Set $legalmoves and return;
	return cond count system legalmoves false true;
endsub;

// In case the developer has not written a description of the rules,
// this compiles one from the descriptions of the pieces used in the game.
// By measuring piece range on selected spaces, it calculates a rough estimate
// of piece value, which it uses to arrange the pieces by value.
// It normally gets placed in stalemated subroutines, because one is expected
// to be called in the Post-Game code.

sub describe_rules:
	my c piecenames notation values val id rules desc name codename rangefn;
	
	// Selected coordinates for measuring piece range
	set c.0 join filename 0 rankname 0;
	set c.1 join filename >> lastfile 1 rankname 1;
	set c.2 join filename inc >> lastfile 1 rankname 1;
	set c.3 join filename >> lastfile 1 rankname inc >> lastrank 1;
	set c.4 join filename inc >> lastfile 1 rankname >> lastrank 1;
	set c.5 join filename >> lastfile 1 rankname dec lastrank;
	set c.6 join filename inc >> lastfile 1 rankname dec lastrank;
	set c.7 join filename lastfile rankname lastrank;

	foreach p keys $pieces:
		if isconst alias #p:
			set codename const alias #p;
			set name alias #codename;
			set notation.{#name} alias #p;
			if match #codename const alias space #kpos const alias space #Kpos:
				set values.{#name} * 8 count spaces;
			else:
				set rangefn join #codename "-Range";
				set values.{#name} sum lambda (count fn #rangefn #0) #c;
			endif;
		endif;
	next;
	set values reverse asort #values;
	
	set rules "<DIV STYLE='display: flex; flex-flow: row wrap;'>";
	foreach (name val) #values:
		set codename realname #name;
		set desc join #codename "-Desc";
		set desc str_replace "%s" #name var #desc;
		set id realname #notation.{#name};
		set rules join #rules "<DIV STYLE='flex: 1 4 400px;'>[pc {#id} {#name}]{#desc}[/pc]</DIV>";
	next;
	set rules join #rules "</DIV>";
	return #rules;
endsub;