Commit c69bb36e authored by sof's avatar sof

[project @ 2005-04-27 17:03:17 by sof]

de^Monised
parent 315bc1f6
module Move (
Move(Move), MoveInFull(MoveInFull),
showMoveInFull, showMoves, moveDetailsFor, kingincheck) where
import Board
data Move = Move
Square -- to here
(Maybe Piece) -- capturing this
(Maybe Piece) -- gaining promotion to this
deriving (Eq,Ord)
data MoveInFull = MoveInFull Piece Square Move
deriving (Eq, Ord)
showMoveInFull :: MoveInFull -> String
showMoveInFull = showMove True
showMove withPiece (MoveInFull p@(c,k) sq (Move sq' mcp mpp)) =
let capt = mcp /= Nothing
prom = mpp /= Nothing in
( if withPiece then
showPiece p ++
(if k==King || k==Pawn && not (capt||prom) then ""
else "/" ++ showSquare c sq)
else "" ) ++
(maybe "-" (\cp -> "x" ++ showPiece cp ++ "/") mcp) ++
showSquare c sq' ++
(maybe "" (\pp -> "(" ++ showPiece pp ++ ")") mpp)
showMoves (mif:mifs) = showMoveInFull mif ++ showMovesAfter mif mifs
showMovesAfter _ [] = ""
showMovesAfter (MoveInFull p' sq' _) (mif@(MoveInFull p sq _):mifs) =
", " ++ showMove (p/=p' || sq/=sq') mif ++ showMovesAfter mif mifs
moveDetailsFor :: Colour -> Board -> [(MoveInFull,Board)]
moveDetailsFor c bd =
foldr ( \ksq ms ->
foldr (\rm ms' -> maybe id (:) (tryMove c ksq rm bd) ms')
ms
(rawmoves c ksq bd) )
[]
(forcesColoured c bd)
tryMove :: Colour -> (Kind,Square) -> Move -> Board -> Maybe (MoveInFull,Board)
tryMove c ksq@(k,sq) m@(Move sq' mcp mpp) bd =
if not (kingincheck c bd2) then Just (MoveInFull p sq m, bd2)
else Nothing
where
p = (c,k)
bd1 = rmPieceAt c sq bd
p' = maybe p id mpp
bd2 = maybe (putPieceAt sq' p' bd1)
(const (putPieceAt sq' p' (rmPieceAt (opponent c) sq' bd1)))
mcp
-- NB raw move = might illegally leave the king in check.
rawmoves :: Colour -> (Kind,Square) -> Board -> [Move]
rawmoves c (k,sq) bd = m c sq bd
where
m = case k of
King -> kingmoves
Queen -> queenmoves
Rook -> rookmoves
Bishop -> bishopmoves
Knight -> knightmoves
Pawn -> pawnmoves
bishopmoves :: Colour -> Square -> Board -> [Move]
bishopmoves c sq bd =
( moveLine bd c sq (\(x,y) -> (x-1,y+1)) $
moveLine bd c sq (\(x,y) -> (x+1,y+1)) $
moveLine bd c sq (\(x,y) -> (x-1,y-1)) $
moveLine bd c sq (\(x,y) -> (x+1,y-1)) id
) []
rookmoves :: Colour -> Square -> Board -> [Move]
rookmoves c sq bd =
( moveLine bd c sq (\(x,y) -> (x-1,y)) $
moveLine bd c sq (\(x,y) -> (x+1,y)) $
moveLine bd c sq (\(x,y) -> (x,y-1)) $
moveLine bd c sq (\(x,y) -> (x,y+1)) id
) []
moveLine :: Board -> Colour -> Square -> (Square->Square) -> ([Move]->a) -> [Move] -> a
moveLine bd c sq inc cont = ml sq
where
ml sq ms =
let sq' = inc sq in
if onboard sq' then
case pieceAt bd sq' of
Nothing -> ml sq' (Move sq' Nothing Nothing : ms)
Just p' -> if colourOf p' /= c then
cont (Move sq' (Just p') Nothing : ms)
else cont ms
else cont ms
kingmoves :: Colour -> Square -> Board -> [Move]
kingmoves c (p,q) bd =
sift c bd [] [(p-1,q+1), (p,q+1), (p+1,q+1),
(p-1,q), (p+1,q),
(p-1,q-1), (p,q-1), (p+1,q-1)]
knightmoves :: Colour -> Square -> Board -> [Move]
knightmoves c (p,q) bd =
sift c bd [] [ (p-1,q+2),(p+1,q+2),
(p-2,q+1), (p+2,q+1),
(p-2,q-1), (p+2,q-1),
(p-1,q-2),(p+1,q-2) ]
sift :: Colour -> Board -> [Move] -> [Square] -> [Move]
sift _ _ ms [] = ms
sift c bd ms (sq:sqs) =
if onboard sq then
case pieceAt bd sq of
Nothing -> sift c bd (Move sq Nothing Nothing : ms) sqs
Just p' -> if colourOf p' == c then sift c bd ms sqs
else sift c bd (Move sq (Just p') Nothing : ms) sqs
else sift c bd ms sqs
pawnmoves :: Colour -> Square -> Board -> [Move]
pawnmoves c (p,q) bd = movs ++ caps
where
movs = let on1 = (p,q+fwd)
on2 = (p,q+2*fwd) in
if pieceAt bd on1 == Nothing then
promote on1 Nothing ++
if (q==2 && c==White || q==7 && c==Black) &&
pieceAt bd on2 == Nothing then [Move on2 Nothing Nothing]
else []
else []
caps = concat [ promote sq mcp
| sq <- [(p+1,q+fwd), (p-1,q+fwd)],
mcp@(Just p') <- [pieceAt bd sq], colourOf p'/=c ]
fwd = case c of
White -> 1
Black -> -1
promote sq@(x,y) mcp =
if (c==Black && y==1 || c==White && y==8) then
map (Move sq mcp . Just)
[(c,Queen), (c,Rook), (c,Bishop), (c,Knight)]
else [Move sq mcp Nothing]
queenmoves :: Colour -> Square -> Board -> [Move]
queenmoves c sq bd = bishopmoves c sq bd ++ rookmoves c sq bd
kingincheck :: Colour -> Board -> Bool
kingincheck c bd =
any givesCheck (forcesColoured (opponent c) bd)
where
givesCheck (k,(x,y)) = kthreat k
where
kthreat King =
abs (x-xk) <= 1 && abs (y-yk) <= 1
kthreat Queen =
kthreat Rook || kthreat Bishop
kthreat Rook =
x==xk &&
emptyAtAll bd (\(xe,ye) -> xe==xk && min y yk < ye && ye < max y yk) ||
y==yk &&
emptyAtAll bd (\(xe,ye) -> ye==yk && min x xk < xe && xe < max x xk)
kthreat Bishop =
x+y==xk+yk &&
emptyAtAll bd (\(xe,ye) -> xe+ye==xk+yk && min x xk < xe && xe < max x xk) ||
x-y==xk-yk &&
emptyAtAll bd (\(xe,ye) -> xe-ye==xk-yk && min x xk < xe && xe < max x xk)
kthreat Knight =
abs (x-xk) == 2 && abs (y-yk) == 1 ||
abs (x-xk) == 1 && abs (y-yk) == 2
kthreat Pawn =
abs (x-xk) == 1 &&
case c of
Black -> yk == y+1
White -> yk == y-1
(xk,yk) = kingSquare c bd
module Move (
Move(Move), MoveInFull(MoveInFull),
showMoveInFull, showMoves, moveDetailsFor, kingincheck) where
import Board
data Move = Move
Square -- to here
(Maybe Piece) -- capturing this
(Maybe Piece) -- gaining promotion to this
deriving (Eq,Ord)
data MoveInFull = MoveInFull Piece Square Move
deriving (Eq, Ord)
showMoveInFull :: MoveInFull -> String
showMoveInFull = showMove True
showMove withPiece (MoveInFull p@(c,k) sq (Move sq' mcp mpp)) =
let capt = mcp /= Nothing
prom = mpp /= Nothing in
( if withPiece then
showPiece p ++
(if k==King || k==Pawn && not (capt||prom) then ""
else "/" ++ showSquare c sq)
else "" ) ++
(maybe "-" (\cp -> "x" ++ showPiece cp ++ "/") mcp) ++
showSquare c sq' ++
(maybe "" (\pp -> "(" ++ showPiece pp ++ ")") mpp)
showMoves (mif:mifs) = showMoveInFull mif ++ showMovesAfter mif mifs
showMovesAfter _ [] = ""
showMovesAfter (MoveInFull p' sq' _) (mif@(MoveInFull p sq _):mifs) =
", " ++ showMove (p/=p' || sq/=sq') mif ++ showMovesAfter mif mifs
moveDetailsFor :: Colour -> Board -> [(MoveInFull,Board)]
moveDetailsFor c bd =
foldr ( \ksq ms ->
foldr (\rm ms' -> maybe id (:) (tryMove c ksq rm bd) ms')
ms
(rawmoves c ksq bd) )
[]
(forcesColoured c bd)
tryMove :: Colour -> (Kind,Square) -> Move -> Board -> Maybe (MoveInFull,Board)
tryMove c ksq@(k,sq) m@(Move sq' mcp mpp) bd =
if not (kingincheck c bd2) then Just (MoveInFull p sq m, bd2)
else Nothing
where
p = (c,k)
bd1 = rmPieceAt c sq bd
p' = maybe p id mpp
bd2 = maybe (putPieceAt sq' p' bd1)
(const (putPieceAt sq' p' (rmPieceAt (opponent c) sq' bd1)))
mcp
-- NB raw move = might illegally leave the king in check.
rawmoves :: Colour -> (Kind,Square) -> Board -> [Move]
rawmoves c (k,sq) bd = m c sq bd
where
m = case k of
King -> kingmoves
Queen -> queenmoves
Rook -> rookmoves
Bishop -> bishopmoves
Knight -> knightmoves
Pawn -> pawnmoves
bishopmoves :: Colour -> Square -> Board -> [Move]
bishopmoves c sq bd =
( moveLine bd c sq (\(x,y) -> (x-1,y+1)) $
moveLine bd c sq (\(x,y) -> (x+1,y+1)) $
moveLine bd c sq (\(x,y) -> (x-1,y-1)) $
moveLine bd c sq (\(x,y) -> (x+1,y-1)) id
) []
rookmoves :: Colour -> Square -> Board -> [Move]
rookmoves c sq bd =
( moveLine bd c sq (\(x,y) -> (x-1,y)) $
moveLine bd c sq (\(x,y) -> (x+1,y)) $
moveLine bd c sq (\(x,y) -> (x,y-1)) $
moveLine bd c sq (\(x,y) -> (x,y+1)) id
) []
moveLine :: Board -> Colour -> Square -> (Square->Square) -> ([Move]->a) -> [Move] -> a
moveLine bd c sq inc cont = ml sq
where
ml sq ms =
let sq' = inc sq in
if onboard sq' then
case pieceAt bd sq' of
Nothing -> ml sq' (Move sq' Nothing Nothing : ms)
Just p' -> if colourOf p' /= c then
cont (Move sq' (Just p') Nothing : ms)
else cont ms
else cont ms
kingmoves :: Colour -> Square -> Board -> [Move]
kingmoves c (p,q) bd =
sift c bd [] [(p-1,q+1), (p,q+1), (p+1,q+1),
(p-1,q), (p+1,q),
(p-1,q-1), (p,q-1), (p+1,q-1)]
knightmoves :: Colour -> Square -> Board -> [Move]
knightmoves c (p,q) bd =
sift c bd [] [ (p-1,q+2),(p+1,q+2),
(p-2,q+1), (p+2,q+1),
(p-2,q-1), (p+2,q-1),
(p-1,q-2),(p+1,q-2) ]
sift :: Colour -> Board -> [Move] -> [Square] -> [Move]
sift _ _ ms [] = ms
sift c bd ms (sq:sqs) =
if onboard sq then
case pieceAt bd sq of
Nothing -> sift c bd (Move sq Nothing Nothing : ms) sqs
Just p' -> if colourOf p' == c then sift c bd ms sqs
else sift c bd (Move sq (Just p') Nothing : ms) sqs
else sift c bd ms sqs
pawnmoves :: Colour -> Square -> Board -> [Move]
pawnmoves c (p,q) bd = movs ++ caps
where
movs = let on1 = (p,q+fwd)
on2 = (p,q+2*fwd) in
if pieceAt bd on1 == Nothing then
promote on1 Nothing ++
if (q==2 && c==White || q==7 && c==Black) &&
pieceAt bd on2 == Nothing then [Move on2 Nothing Nothing]
else []
else []
caps = concat [ promote sq mcp
| sq <- [(p+1,q+fwd), (p-1,q+fwd)],
mcp@(Just p') <- [pieceAt bd sq], colourOf p'/=c ]
fwd = case c of
White -> 1
Black -> -1
promote sq@(x,y) mcp =
if (c==Black && y==1 || c==White && y==8) then
map (Move sq mcp . Just)
[(c,Queen), (c,Rook), (c,Bishop), (c,Knight)]
else [Move sq mcp Nothing]
queenmoves :: Colour -> Square -> Board -> [Move]
queenmoves c sq bd = bishopmoves c sq bd ++ rookmoves c sq bd
kingincheck :: Colour -> Board -> Bool
kingincheck c bd =
any givesCheck (forcesColoured (opponent c) bd)
where
givesCheck (k,(x,y)) = kthreat k
where
kthreat King =
abs (x-xk) <= 1 && abs (y-yk) <= 1
kthreat Queen =
kthreat Rook || kthreat Bishop
kthreat Rook =
x==xk &&
emptyAtAll bd (\(xe,ye) -> xe==xk && min y yk < ye && ye < max y yk) ||
y==yk &&
emptyAtAll bd (\(xe,ye) -> ye==yk && min x xk < xe && xe < max x xk)
kthreat Bishop =
x+y==xk+yk &&
emptyAtAll bd (\(xe,ye) -> xe+ye==xk+yk && min x xk < xe && xe < max x xk) ||
x-y==xk-yk &&
emptyAtAll bd (\(xe,ye) -> xe-ye==xk-yk && min x xk < xe && xe < max x xk)
kthreat Knight =
abs (x-xk) == 2 && abs (y-yk) == 1 ||
abs (x-xk) == 1 && abs (y-yk) == 2
kthreat Pawn =
abs (x-xk) == 1 &&
case c of
Black -> yk == y+1
White -> yk == y-1
(xk,yk) = kingSquare c bd
- - - - - - - -
- - - - - - - -
- - - - - - - -
- - - - P - - -
- - - - p - k b
- P n - K - - -
- P - - - - - -
- q - - - - - -
White to move and mate in 3
1. N/QB3-QR2,
if P/QN6xN/QR7; 2. Q-QB2, ... ; 3. B/KR4-KB2 ++
if K-K7; 2. N/QR2-QN4,
if K-K6; 3. Q-Q3 ++
if K-Q7; 3. Q-K1 ++
if K-Q7; 2. K-KB3, P/QN6xN/QR7; 3. B/KR4-K1 ++
if K-Q5; 2. B/KR4-KB2, K-QB5; 3. Q-KB1 ++
- - - - - - - -
- - - - - - - -
- - - - - - - -
- - - - P - - -
- - - - p - k b
- P n - K - - -
- P - - - - - -
- q - - - - - -
White to move and mate in 3
1. N/QB3-QR2,
if P/QN6xN/QR7; 2. Q-QB2, ... ; 3. B/KR4-KB2 ++
if K-K7; 2. N/QR2-QN4,
if K-K6; 3. Q-Q3 ++
if K-Q7; 3. Q-K1 ++
if K-Q7; 2. K-KB3, P/QN6xN/QR7; 3. B/KR4-K1 ++
if K-Q5; 2. B/KR4-KB2, K-QB5; 3. Q-KB1 ++
- - - - - - - K
- - - - - - - -
- - - - - n - p
- - - - - - - -
- - - - - - - -
- - - - - B P -
- - - - - - - -
b - - - - - k -
White to move and mate in 5
- - - - - - - K
- - - - - - - -
- - - - - n - p
- - - - - - - -
- - - - - - - -
- - - - - B P -
- - - - - - - -
b - - - - - k -
White to move and mate in 5
- N - - - - n -
- - - - r - P k
- - - P - - - -
- - P b - K - P
- - - P - - - p
- P - - P - p -
- - - - p p P -
Q N - - q - - B
White to move and mate in 3
1. Q-QB3,
if QxQ/QB6; 2. R/K7xP/KN7, ... ; 3. R/KN7-KN5 ++
if P/Q5xQ/QB6; 2. R/K7xP/K3, ... ; 3. B/Q5-K6 ++
if P-Q6; 2. QxP/Q3, K-KN5; 3. B/Q5-K6 ++
if N/QN8-Q7; 2. Q-Q3,
if N/Q7-K5; 3. QxN/K4 ++
if K-KN5; 3. B/Q5-K6 ++
if P/K6xP/KB7; 2. Q-KB3 ++
if N/QN8xQ/QB6; 2. KxP/KN7,
if K-KN5; 3. B/Q5-K6 ++
... ; 3. N/KN8-KR6 ++
if K-KN5; 2. B/Q5-K6 ++
if P-QB5, Q-QR3; 2. KxP/KN7,
if P/K6xP/KB7; 3. Q-KB3 ++
if K-KN5; 3. B/Q5-K6 ++
... ; 3. N/KN8-KR6 ++
if P/KN7-KN8(B), -KN8(N), -KN8(Q), -KN8(R); 2. Q-Q3,
if B/KR8-K5; 3. QxB/K4 ++
if K-KN5; 3. B/Q5-K6 ++
... ; 2. Q-Q3, K-KN5; 3. B/Q5-K6 ++
- N - - - - n -
- - - - r - P k
- - - P - - - -
- - P b - K - P
- - - P - - - p
- P - - P - p -
- - - - p p P -
Q N - - q - - B
White to move and mate in 3
1. Q-QB3,
if QxQ/QB6; 2. R/K7xP/KN7, ... ; 3. R/KN7-KN5 ++
if P/Q5xQ/QB6; 2. R/K7xP/K3, ... ; 3. B/Q5-K6 ++
if P-Q6; 2. QxP/Q3, K-KN5; 3. B/Q5-K6 ++
if N/QN8-Q7; 2. Q-Q3,
if N/Q7-K5; 3. QxN/K4 ++
if K-KN5; 3. B/Q5-K6 ++
if P/K6xP/KB7; 2. Q-KB3 ++
if N/QN8xQ/QB6; 2. KxP/KN7,
if K-KN5; 3. B/Q5-K6 ++
... ; 3. N/KN8-KR6 ++
if K-KN5; 2. B/Q5-K6 ++
if P-QB5, Q-QR3; 2. KxP/KN7,
if P/K6xP/KB7; 3. Q-KB3 ++
if K-KN5; 3. B/Q5-K6 ++
... ; 3. N/KN8-KR6 ++
if P/KN7-KN8(B), -KN8(N), -KN8(Q), -KN8(R); 2. Q-Q3,
if B/KR8-K5; 3. QxB/K4 ++
if K-KN5; 3. B/Q5-K6 ++
... ; 2. Q-Q3, K-KN5; 3. B/Q5-K6 ++
- K - - - - - -
P P P - - - - -
- - - - - - - -
- - - - - - - -
- - - - - - - -
- p - - - - - -
- - p - - - - -
- k - r - - - -
White to move and mate in 1
1. R/Q1-Q8 mate.
- K - - - - - -
P P P - - - - -
- - - - - - - -
- - - - - - - -
- - - - - - - -
- p - - - - - -
- - p - - - - -
- k - r - - - -
White to move and mate in 1
1. R/Q1-Q8 mate.
- - k - - - - -
r - - - - - - -
- - - p K - - -
- - - - P - - -
- - - p p b - -
- - - p - p - -
- - - - - - - -
- - - - - - - -
White to move and mate in 3
1. P-Q7,
if P/K4xP/Q5; 2. P/Q7-Q8(R), K-KB3; 3. R/Q8-Q6 ++
if K-K2; 2. P/Q7-Q8(Q), K-K3; 3. Q-K7 ++
if K-Q3; 2. P/Q7-Q8(N), P/K4xB/KB5; 3. R/QR7-Q7 ++
if P/K4xB/KB5; 2. P/Q7-Q8(B), K-Q3; 3. R/QR7-QR6 ++
... ; 2. P/Q7-Q8(Q),
if K-KN3; 3. Q-KN5 ++
if K-K3; 3. Q-K7 ++
- - k - - - - -
r - - - - - - -
- - - p K - - -
- - - - P - - -
- - - p p b - -
- - - p - p - -
- - - - - - - -
- - - - - - - -
White to move and mate in 3
1. P-Q7,
if P/K4xP/Q5; 2. P/Q7-Q8(R), K-KB3; 3. R/Q8-Q6 ++
if K-K2; 2. P/Q7-Q8(Q), K-K3; 3. Q-K7 ++
if K-Q3; 2. P/Q7-Q8(N), P/K4xB/KB5; 3. R/QR7-Q7 ++
if P/K4xB/KB5; 2. P/Q7-Q8(B), K-Q3; 3. R/QR7-QR6 ++
... ; 2. P/Q7-Q8(Q),
if K-KN3; 3. Q-KN5 ++
if K-K3; 3. Q-K7 ++
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment