1 module Move ( 2 Move(Move), MoveInFull(MoveInFull), 3 showMoveInFull, showMoves, moveDetailsFor, kingincheck) where 4 5 import Board 6 7 data Move = Move 8 Square -- to here 9 (Maybe Piece) -- capturing this 10 (Maybe Piece) -- gaining promotion to this 11 deriving (Eq,Ord) 12 13 data MoveInFull = MoveInFull Piece Square Move 14 deriving (Eq, Ord) 15 16 showMoveInFull :: MoveInFull -> String 17 showMoveInFull = showMove True 18 19 showMove withPiece (MoveInFull p@(c,k) sq (Move sq' mcp mpp)) = 20 let capt = mcp /= Nothing 21 prom = mpp /= Nothing in 22 ( if withPiece then 23 showPiece p ++ 24 (if k==King || k==Pawn && not (capt||prom) then "" 25 else "/" ++ showSquare c sq) 26 else "" ) ++ 27 (maybe "-" (\cp -> "x" ++ showPiece cp ++ "/") mcp) ++ 28 showSquare c sq' ++ 29 (maybe "" (\pp -> "(" ++ showPiece pp ++ ")") mpp) 30 31 showMoves (mif:mifs) = showMoveInFull mif ++ showMovesAfter mif mifs 32 33 showMovesAfter _ [] = "" 34 showMovesAfter (MoveInFull p' sq' _) (mif@(MoveInFull p sq _):mifs) = 35 ", " ++ showMove (p/=p' || sq/=sq') mif ++ showMovesAfter mif mifs 36 37 moveDetailsFor :: Colour -> Board -> [(MoveInFull,Board)] 38 moveDetailsFor c bd = 39 foldr ( \ksq ms -> 40 foldr (\rm ms' -> maybe id (:) (tryMove c ksq rm bd) ms') 41 ms 42 (rawmoves c ksq bd) ) 43 [] 44 (forcesColoured c bd) 45 46 tryMove :: Colour -> (Kind,Square) -> Move -> Board -> Maybe (MoveInFull,Board) 47 tryMove c ksq@(k,sq) m@(Move sq' mcp mpp) bd = 48 if not (kingincheck c bd2) then Just (MoveInFull p sq m, bd2) 49 else Nothing 50 where 51 p = (c,k) 52 bd1 = rmPieceAt c sq bd 53 p' = maybe p id mpp 54 bd2 = maybe (putPieceAt sq' p' bd1) 55 (const (putPieceAt sq' p' (rmPieceAt (opponent c) sq' bd1))) 56 mcp 57 58 -- NB raw move = might illegally leave the king in check. 59 rawmoves :: Colour -> (Kind,Square) -> Board -> [Move] 60 rawmoves c (k,sq) bd = m c sq bd 61 where 62 m = case k of 63 King -> kingmoves 64 Queen -> queenmoves 65 Rook -> rookmoves 66 Bishop -> bishopmoves 67 Knight -> knightmoves 68 Pawn -> pawnmoves 69 70 bishopmoves :: Colour -> Square -> Board -> [Move] 71 bishopmoves c sq bd = 72 ( moveLine bd c sq (\(x,y) -> (x-1,y+1)) $ 73 moveLine bd c sq (\(x,y) -> (x+1,y+1)) $ 74 moveLine bd c sq (\(x,y) -> (x-1,y-1)) $ 75 moveLine bd c sq (\(x,y) -> (x+1,y-1)) id 76 ) [] 77 78 rookmoves :: Colour -> Square -> Board -> [Move] 79 rookmoves c sq bd = 80 ( moveLine bd c sq (\(x,y) -> (x-1,y)) $ 81 moveLine bd c sq (\(x,y) -> (x+1,y)) $ 82 moveLine bd c sq (\(x,y) -> (x,y-1)) $ 83 moveLine bd c sq (\(x,y) -> (x,y+1)) id 84 ) [] 85 86 moveLine :: Board -> Colour -> Square -> (Square->Square) -> ([Move]->a) -> [Move] -> a 87 moveLine bd c sq inc cont = ml sq 88 where 89 ml sq ms = 90 let sq' = inc sq in 91 if onboard sq' then 92 case pieceAt bd sq' of 93 Nothing -> ml sq' (Move sq' Nothing Nothing : ms) 94 Just p' -> if colourOf p' /= c then 95 cont (Move sq' (Just p') Nothing : ms) 96 else cont ms 97 else cont ms 98 99 kingmoves :: Colour -> Square -> Board -> [Move] 100 kingmoves c (p,q) bd = 101 sift c bd [] [(p-1,q+1), (p,q+1), (p+1,q+1), 102 (p-1,q), (p+1,q), 103 (p-1,q-1), (p,q-1), (p+1,q-1)] 104 105 knightmoves :: Colour -> Square -> Board -> [Move] 106 knightmoves c (p,q) bd = 107 sift c bd [] [ (p-1,q+2),(p+1,q+2), 108 (p-2,q+1), (p+2,q+1), 109 (p-2,q-1), (p+2,q-1), 110 (p-1,q-2),(p+1,q-2) ] 111 112 sift :: Colour -> Board -> [Move] -> [Square] -> [Move] 113 sift _ _ ms [] = ms 114 sift c bd ms (sq:sqs) = 115 if onboard sq then 116 case pieceAt bd sq of 117 Nothing -> sift c bd (Move sq Nothing Nothing : ms) sqs 118 Just p' -> if colourOf p' == c then sift c bd ms sqs 119 else sift c bd (Move sq (Just p') Nothing : ms) sqs 120 else sift c bd ms sqs 121 122 pawnmoves :: Colour -> Square -> Board -> [Move] 123 pawnmoves c (p,q) bd = movs ++ caps 124 where 125 movs = let on1 = (p,q+fwd) 126 on2 = (p,q+2*fwd) in 127 if pieceAt bd on1 == Nothing then 128 promote on1 Nothing ++ 129 if (q==2 && c==White || q==7 && c==Black) && 130 pieceAt bd on2 == Nothing then [Move on2 Nothing Nothing] 131 else [] 132 else [] 133 caps = concat [ promote sq mcp 134 | sq <- [(p+1,q+fwd), (p-1,q+fwd)], 135 mcp@(Just p') <- [pieceAt bd sq], colourOf p'/=c ] 136 fwd = case c of 137 White -> 1 138 Black -> -1 139 promote sq@(x,y) mcp = 140 if (c==Black && y==1 || c==White && y==8) then 141 map (Move sq mcp . Just) 142 [(c,Queen), (c,Rook), (c,Bishop), (c,Knight)] 143 else [Move sq mcp Nothing] 144 145 queenmoves :: Colour -> Square -> Board -> [Move] 146 queenmoves c sq bd = bishopmoves c sq bd ++ rookmoves c sq bd 147 148 kingincheck :: Colour -> Board -> Bool 149 kingincheck c bd = 150 any givesCheck (forcesColoured (opponent c) bd) 151 where 152 givesCheck (k,(x,y)) = kthreat k 153 where 154 kthreat King = 155 abs (x-xk) <= 1 && abs (y-yk) <= 1 156 kthreat Queen = 157 kthreat Rook || kthreat Bishop 158 kthreat Rook = 159 x==xk && 160 emptyAtAll bd (\(xe,ye) -> xe==xk && min y yk < ye && ye < max y yk) || 161 y==yk && 162 emptyAtAll bd (\(xe,ye) -> ye==yk && min x xk < xe && xe < max x xk) 163 kthreat Bishop = 164 x+y==xk+yk && 165 emptyAtAll bd (\(xe,ye) -> xe+ye==xk+yk && min x xk < xe && xe < max x xk) || 166 x-y==xk-yk && 167 emptyAtAll bd (\(xe,ye) -> xe-ye==xk-yk && min x xk < xe && xe < max x xk) 168 kthreat Knight = 169 abs (x-xk) == 2 && abs (y-yk) == 1 || 170 abs (x-xk) == 1 && abs (y-yk) == 2 171 kthreat Pawn = 172 abs (x-xk) == 1 && 173 case c of 174 Black -> yk == y+1 175 White -> yk == y-1 176 (xk,yk) = kingSquare c bd 177