# restart; read `d:/Aek/Rook/Rook.txt`;

# July 26th, 2013
# Rook Program:
# No restriction, rook moves freely.
# This program is mostly to find 
# the number of moves to checkmate 
# in a given position P.

print(`Welcome to Rook, a Maple package written by`):
print(`Thotsaporn (Aek) Thanatipanonda with help from his`):
print(`brother Thotsaphon. First Version: July 26th, 2013 `):
print():
print(`It accompanies the article: `):
print(`Rook Endgame Problem in Chess `):
print(` by Thotsaporn (Aek) Thanatipanonda`):
print(`available from authors' website`):

Help := proc()

if args = NULL then
print(` Main Function: BoardRook(m,n);`);
print(` Input: the width and height of the board `);
print(` Output: the maximum of number of checkmate`); 
print(` from all positions of rook endgame on an.`);
print(` m by n board.`);
print(` `);
print(` Try  " BoardRook(5,7);  " or`);
print(` " seq(BoardRook(3,i),i=3..10);  "`);
fi:
end:


# Section 1: BoardRook 
# runs all the positions on m by n boards.
# For the largest number of moves on an
# m by n board try: BoardRook(m,n);

# Section 2: rook, programmed by A
# find a number of moves to mate
# in a given position.

# Section 3: Compare
# Check to see answers from 
# section 1 and 2 agree.

# Speedwise, BoardRook is much faster than rook
# Try: 
# t:= time():BoardRook(5,7): time()-t;
# t:= time():rook(5,7,[2,3],[1,1],[1,2]);time()-t;

##################################
# Section 1: 
# Main Function: BoardRook
# Other Functions: MateInOne
#                  
# Aux Functons: BMBT, BM, WM, 
#		GenBKMoveBT, GenBKMove, GenWKMove,
#       GenWRMove, InCheck 
# Speedup Functions: SBoard, HBoard
##################################

# board := [width, height, BK, WK, RK]:
# Run all the positions of an m by n board
# by using backward calculation.

# Output: no print info

# Try: BoardRook(5,5);
BoardRook := proc(m,n)  option remember:
global MT:
local ret,TempGone, Gone, P, numMate, board, s;

#Check Input
if m < 3 or n < 3 then
	ERROR("BoardRook");
fi:

# Update mate in one position
numMate := 0;
TempGone := MateInOne(m,n);
Gone := {};

while TempGone <> {} do
	numMate := numMate+1;
	Gone := TempGone union Gone;
	
	# Qualify positions
	P := {seq(op(BMBT(s)),s in TempGone)};
	TempGone := {};

	# board is a target position.
	for s in P do 	
		if BM(s) subset Gone then
			for board in WM(s) do 
			if not(InCheck(board)) and 
			not(member(board,Gone)) then
				TempGone := TempGone union {board};			
				MT[op(board)] := numMate;			
			fi:
			
			od:
		fi:
	od:  
od: 

print(`Board of size`,m,`by`,n,`mate in`,numMate);
return():

end:

#########################################
MateInOne := proc(m,n)
global MT:
local s,P,i,j,k;

# Vertical check
P := {
seq(seq(seq(SBoard([m,n,[1,i],[3,i],[j,k]])
,i=k+2..n),j=2..m),k=1..n-2),
seq(seq(seq(SBoard([m,n,[1,i],[3,i],[j,k]])
,i=1..k-2),j=2..m),k=3..n),
seq(seq(seq(SBoard([m,n,[m,i],[m-2,i],[j,k]])
,i=k+2..n),j=1..m-1),k=1..n-2),
seq(seq(seq(SBoard([m,n,[m,i],[m-2,i],[j,k]])
,i=1..k-2),j=1..m-1),k=3..n),

# Horizontal check
seq(seq(seq(SBoard([m,n,[i,n],[i,n-2],[j,k]])
,j=1..i-2),i=1..m),k=1..n-1),
seq(seq(seq(SBoard([m,n,[i,n],[i,n-2],[j,k]])
,j=i+2..m),i=1..m),k=1..n-1),
seq(seq(seq(SBoard([m,n,[i,1],[i,3],[j,k]])
,j=1..i-2),i=1..m),k=2..n),
seq(seq(seq(SBoard([m,n,[i,1],[i,3],[j,k]])
,j=i+2..m),i=1..m),k=2..n),

# Corner
seq(seq(SBoard([m,n,[1,1],[2,3],[j,k]])
,j=3..m),k=2..n),
seq(seq(SBoard([m,n,[1,1],[3,2],[j,k]])
,j=2..m),k=3..n)}:

for s in P do
	MT[op(s)] := 1; 
od:
P;
end:



#####################################################
BMBT := proc(board) option remember;
local aek;

{seq(SBoard([board[1],board[2],aek,board[4],board[5]]),
aek in GenBKMoveBT(board))};
end:


BM := proc(board) option remember;
local aek;

{seq(SBoard([board[1],board[2],aek,board[4],board[5]]),
aek in GenBKMove(board))};
end:


WM := proc(board) option remember;
local aek;
{seq(SBoard([board[1],board[2],board[3],board[4],aek]),
aek in GenWRMove(board))} union 
{seq(SBoard([board[1],board[2],board[3],aek,board[5]]),
aek in GenWKMove(board))};
end:


GenBKMoveBT := proc(board) option remember;
local ret, posWK, posWR, posBK, direct, directKing:

directKing := [[-1,  1], [0,  1], [1,  1], 
               [-1,  0],          [1,  0],
               [-1, -1], [0, -1], [1, -1]]:	

ret   := [];
posWK := board[4];
posWR := board[5];

for direct in directKing do
  posBK := [board[3][1]+direct[1], 
			board[3][2]+direct[2]];
        
  if posBK[1] >= 1 and posBK[1] <= board[1]
     and posBK[2] >= 1 and posBK[2] <= board[2]
     and max(abs(posBK[1]-posWK[1]), 
			 abs(posBK[2]-posWK[2])) > 1 
	 and posBK <> posWR 

	 then
     ret := [op(ret) , posBK];
   fi;
od;

ret;
end:


# Output: list of possible black move.
# Try: GenBKMove([5,5,[2,2],[4,4],[5,2]]);

GenBKMove := proc(board) option remember;
local ret, posWK, posWR, posBK, direct, directKing:

directKing := [[-1,  1], [0,  1], [1,  1], 
               [-1,  0],          [1,  0],
               [-1, -1], [0, -1], [1, -1]]:	

ret   := [];
posWK := board[4];
posWR := board[5];

for direct in directKing do
  posBK := [board[3][1]+direct[1], 
			board[3][2]+direct[2]];
        
  if posBK[1] >= 1 and posBK[1] <= board[1]
     and posBK[2] >= 1 and posBK[2] <= board[2]
     and (not (posBK[1] = posWR[1] xor 
			posBK[2] = posWR[2])
     or (posBK[1] = posWR[1] and posBK[1] = posWK[1] 
         and ((posWK[2] > posBK[2] and 
				posWK[2] < posWR[2]) 
         or (posWK[2] > posWR[2] and 
			posWK[2] < posBK[2])))
     or (posBK[2] = posWR[2] and posBK[2] = posWK[2] 
         and ((posWK[1] > posBK[1] and
				posWK[1] < posWR[1]) 
         or (posWK[1] > posWR[1] 
			and posWK[1] < posBK[1]))))
     and max(abs(posBK[1]-posWK[1]), 
			 abs(posBK[2]-posWK[2])) > 1 then
        ret := [op(ret) , posBK];
   fi;
od;

ret;
end:



# Output: List of possible White King move.
# Try: GenWKMove([5,5,[2,4],[4,4],[5,5]]);

GenWKMove := proc(board) option remember;
local ret, posWK, posWR, posBK, direct, directKing;

directKing := [[-1,  1], [0,  1], [1,  1], 
               [-1,  0],          [1,  0],
               [-1, -1], [0, -1], [1, -1]]:	

ret   := [];
posBK := board[3];
posWR := board[5];

for direct in directKing do
    posWK := [board[4][1]+direct[1], 
			  board[4][2]+direct[2]];
        
    if posWK[1] >= 1 and posWK[1] <= board[1]
       and posWK[2] >= 1 and posWK[2] <= board[2]
       and posWK <> posWR 
       and max(abs(posWK[1]-posBK[1]), 
		   abs(posWK[2]-posBK[2])) > 1 then
       ret := [op(ret) , posWK];
    fi;
od;

ret;
end:

# Output: List of possible White Rook move
#         with constraint.
# Try: GenWRMove([5,5,[1,2],[3,2],[4,2]]);

GenWRMove := proc(board)   option remember;
local ret, posWK, posWR, posBK, direct, directRook;

directRook := [[1, 0], [-1, 0], [0, 1], [0, -1]]:
ret   := [];
posBK := board[3];    
posWK := board[4];
    
for direct in directRook do
    posWR := [board[5][1]+direct[1], 
			  board[5][2]+direct[2]];
        
    while posWR[1] >= 1 and posWR[1] <= board[1]
          and posWR[2] >= 1 and posWR[2] <= board[2]
		  and posWR <> posWK 
		  do
         ret := [op(ret), posWR];

         posWR := [posWR[1]+direct[1], 
				   posWR[2]+direct[2]];
    od;
od;

ret;
end:



InCheck := proc(board) option remember;
local wrPos,bkPos,wkPos;

bkPos := board[3];
wkPos := board[4];
wrPos := board[5];

if (wrPos[1] = bkPos[1] 
	and (wkPos[1] <> wrPos[1] 
		 or wkPos[2] > max(wrPos[2], bkPos[2]) 
		 or wkPos[2] < min(wrPos[2], bkPos[2])))
or (wrPos[2] = bkPos[2]  
	and (wkPos[2] <> wrPos[2] 
		 or wkPos[1] > max(wrPos[1], bkPos[1]) 
		 or wkPos[1] < min(wrPos[1], bkPos[1]))) then
	return(true);
else
	return(false)
fi:
end:


#########################
# Speed up the program
#########################

# Reverse Board
SBoard := proc(board) option remember;
local ret,h,width,BKCol,WKCol,WRCol;

BKCol := board[3][1];
WKCol := board[4][1];
WRCol := board[5][1];
width := board[1];
h := ceil(width/2):

if BKCol > h or  ( width mod 2 = 1 and
((BKCol = h and WKCol > h) or
(BKCol = h and WKCol = h and WRCol > h)))
then
	ret := [board[1],board[2],
    [(width+1)-BKCol,board[3][2]],
	[(width+1)-WKCol,board[4][2]],
	[(width+1)-WRCol,board[5][2]]   ];
		
else
	ret := board;
fi:

return(HBoard(ret));
end:


# Reverse Board
HBoard := proc(board) option remember;
local h,height,BKRow,WKRow,WRRow;

BKRow := board[3][2];
WKRow := board[4][2];
WRRow := board[5][2];
height := board[2];
h := ceil(height/2):

if BKRow > h or  (height mod 2 = 1 and
((BKRow = h and WKRow > h) or
(BKRow = h and WKRow = h and WRRow > h)))
then
	return [board[1],board[2],
    [board[3][1],(height+1)-BKRow],
	[board[4][1],(height+1)-WKRow],
	[board[5][1],(height+1)-WRRow]   ];
		
else
	return(board);
fi:
end:






###################################################
# Section 2 : Basic Rook program
#
# Main Function: rook
# Other Functions: checkInput, evalWBoard, evalBBoard, 
#                  makeMove, genMove, genWKMove,
#                  genWRMove, genBKMove
# Speed Up:  StBoard
###################################################

# Input: width, height, [bkCol, bkRow], 
#        [wkCol, wkRow], [wrCol, wrRow]
#        position is according to x,y co-ordinate.
# Output: Number of Move to Mate

# Try: rook(3, 8, [3, 8], [3, 1], [1, 1]);
rook := proc(width, height, bkPos, wkPos, wrPos)
option remember;

local board, depth;

# Check Input
if CheckInput(width, height, bkPos, wkPos, wrPos) <> "" then
   return CheckInput(width, height, bkPos, wkPos, wrPos);
fi;

# Process
board := [1, width, height, bkPos, wkPos, wrPos];
depth := 1;

while evalWBoard(board, depth) = 0 do
    depth := depth+2;
od;

return((depth+1)/2);
end:

##########################
# Other functions
##########################
#
# Check Input
#
CheckInput := proc(width, height, bkPos, wkPos, wrPos)
    
if width <= 2 or height <= 2 then
   return("M 3 x 3");
elif wkPos[1] < 1 or wkPos[1] > width
     or wkPos[2] < 1 or wkPos[2] > height
     or wrPos[1] < 1 or wrPos[1] > width
     or wrPos[2] < 1 or wrPos[2] > height
     or bkPos[1] < 1 or bkPos[1] > width
     or bkPos[2] < 1 or bkPos[2] > height then
	return("Piece out of Board");
elif wkPos = wrPos or wkPos = bkPos or 
     wrPos = bkPos then
    return("X");
elif max(abs(wkPos[1]-bkPos[1]), 
         abs(wkPos[2]-bkPos[2])) <= 1 then
    return("X");
elif (wrPos[1] = bkPos[1] and (wkPos[1] <> wrPos[1] 
	  or wkPos[2] > max(wrPos[2], bkPos[2]) 
	  or wkPos[2] < min(wrPos[2], bkPos[2])))
	  or (wrPos[2] = bkPos[2]  
	and (wkPos[2] <> wrPos[2] 
		or wkPos[1] > max(wrPos[1], bkPos[1]) 
		or wkPos[1] < min(wrPos[1], bkPos[1]))) then
	return("In Check");
else
    return("");
fi;
end:

#
# Evaluate White Move Board
#
evalWBoard := proc(board, depth) option remember;
local ret, moveList, i, score;

if board[4] = board[6] then   # White Rook is captured
   return(0);

else                          # Find Winning Move
    ret      := -1;
    moveList := genMove(board);

   for i from 1 while i <= nops(moveList) 
					  and ret < 1 do
      score := -evalBBoard(makeMove(board, moveList[i])
	                       , depth-1);

      if score > ret then
         ret := score;
      fi;
   od;

return(ret);
fi;
end:

#
# Evaluate Black Move Board
#
evalBBoard := proc(board, depth)   option remember;
local ret, moveList, i, score;

moveList := genMove(board);

if nops(moveList) = 0 then
   if board[4][1] = board[6][1] 
     or board[4][2] = board[6][2] then    # Checkmate
      return(-1);  
   else                                   # Stalemate
      return(0);   
   fi;

elif depth = 0 then            # Unknown Result
   return(0);       
else                           # Find Surviving Move
   ret := -1;

   for i from 1 while i <= nops(moveList) and 
                ret < 0 do
      score := -evalWBoard(makeMove(board, moveList[i])
	             , depth-1);

      if score > ret then
         ret:= score;
      fi;
   od;

return(ret);
fi;
end:

#
# Make Move
#
makeMove := proc(board, move)  option remember;
local ret;

ret := board;
ret[move[1]] := move[2];
ret[1]       := ret[1] mod 2 + 1;   # Swap Side
    
StBoard(ret);
end:

#
# Generate Move
# Move Format: [kind, [toCol, toRow]]
#
genMove := proc(board)  option remember;

if board[1] = 1 then
  return [op(genWKMove(board)), 
		  op(genWRMove(board))];
else
  return genBKMove(board);
fi;
end:

#
# Generate Black King Move
#
genBKMove := proc(board) option remember;
local ret, posWK, posWR, posBK, direct, directKing;

directKing := [[-1,  1], [0,  1], [1,  1], 
               [-1,  0],          [1,  0],
               [-1, -1], [0, -1], [1, -1]]:
ret   := [];
posWK := board[5];
posWR := board[6];

for direct in directKing do
    posBK := [board[4][1]+direct[1], 
	      board[4][2]+direct[2]];
        
    if posBK[1] >= 1 and posBK[1] <= board[2]
       and posBK[2] >= 1 and posBK[2] <= board[3]
       and (not (posBK[1] = posWR[1] xor 
                 posBK[2] = posWR[2])
            or (posBK[1] = posWR[1] and 
	        posBK[1] = posWK[1] 
               and ((posWK[2] > posBK[2] and 
	             posWK[2] < posWR[2]) 
                   or (posWK[2] > posWR[2] and 
		       posWK[2] < posBK[2])))
            or (posBK[2] = posWR[2] and 
	        posBK[2] = posWK[2] 
               and ((posWK[1] > posBK[1] and 
	             posWK[1] < posWR[1]) 
                  or (posWK[1] > posWR[1] and 
		      posWK[1] < posBK[1]))))
           and max(abs(posBK[1]-posWK[1]), 
	           abs(posBK[2]-posWK[2])) > 1 then
         ret := [op(ret) , [4, posBK]];
   fi;
od;
ret;
end:



#
# Generate White King Move
#
genWKMove := proc(board)  option remember;
local ret, posWK, posWR, posBK, direct, directKing;

directKing := [[-1,  1], [0,  1], [1,  1], 
               [-1,  0],          [1,  0],
               [-1, -1], [0, -1], [1, -1]]:
ret   := [];
posBK := board[4];
posWR := board[6];

for direct in directKing do
    posWK := [board[5][1]+direct[1], 
	          board[5][2]+direct[2]];
        
    if posWK[1] >= 1 and posWK[1] <= board[2]
       and posWK[2] >= 1 and posWK[2] <= board[3]
       and posWK <> posWR 
       and max(abs(posWK[1]-posBK[1]), abs(posWK[2]-posBK[2])) > 1 then
       ret := [op(ret) , [5, posWK]];
    fi;
od;

ret;
end:

#
# Generate White Rook Move
#
genWRMove := proc(board)  option remember;
local ret, posWK, posWR, posBK, direct, directRook;

directRook := [[1, 0], [-1, 0], [0, 1], [0, -1]]:
ret   := [];
posBK := board[4];
posWK := board[5];


for direct in directRook do
   posWR := [board[6][1]+direct[1], 
             board[6][2]+direct[2]];
        
   while posWR[1] >= 1 and posWR[1] <= board[2]
         and posWR[2] >= 1 and posWR[2] <= board[3]
		 and posWR <> posWK do
         ret := [op(ret), [6, posWR]];

         posWR := [posWR[1]+direct[1], 
	               posWR[2]+direct[2]];
   od;
od;
ret;
end:

###############################################
# Reverse Board
StBoard := proc(board) option remember;
local h,width,BKCol,WKCol,WRCol;

BKCol := board[4][1];
WKCol := board[5][1];
WRCol := board[6][1];
width := board[2];
h := ceil(width/2):

if BKCol > h or  ( width mod 2 = 1 and
((BKCol = h and WKCol > h) or
(BKCol = h and WKCol = h and WRCol > h)))
then
	return([board[1],board[2],board[3],
    [(width+1)-BKCol,board[4][2]],
	[(width+1)-WKCol,board[5][2]],
	[(width+1)-WRCol,board[6][2]]   ]);
		
else
	return(board);
fi:
end:




###################
# Section 3: 
# Compare, AllPos
###################

# Double check my BoardRook and rook to
# see whether it agrees.
# Try:  Compare(5,5);
Compare := proc(M,N)
local m,n,l,pos:

for m from 3 to M do
for n from 3 to N do
	BoardRook(m,n);
for pos in AllPos(m,n) do 
	if rook(op(pos)) <> MT[op(pos)]  then
		print("Problem at",pos
		,rook(op(pos)),MT[op(pos)]);
	fi:
od:od:od:
print("Done");
end:

# All positions on m by n board that I consider.
# Try: AllPos(3,3);
AllPos := proc(m,n) option remember;
local s, All, Now, P, board;

All := {};
Now := MateInOne(m,n); 

while Now <> {} do
	All := Now union All;
	
	# Qualify positions
	P := {seq(op(BMBT(s)),s in Now)};
	Now := {};

	# board is a target position.
	for s in P do 	
		if BM(s) subset All then
			for board in WM(s) do 
			if not(InCheck(board)) and 
			not(member(board,All)) then
				Now := Now union {board};						
			fi:
			od:
		fi:
	od:  
od: 
All;
end: