ghc/tests/programs/andy_cherry/InterpUtils.lhs

   1 > module InterpUtils where
   2
   3 > import GenUtils
   4 > import DataTypes
   5 > import Array -- 1.3
   6
   7 %------------------------------------------------------------------------------
   8
   9 This part computes the effect a move has on its board.
  10
  11 > findCastleKMove brd = (castleK,makeACastleK brd)
  12 > findCastleQMove brd = (castleQ,makeACastleQ brd)
  13
  14 > findAPawnMove
  15 >       :: ExBoardPos
  16 >       -> ExBoardPos
  17 >       -> Maybe Piece
  18 >       -> Board
  19 >       -> (String,Board)
  20
  21 First the pawns. They are seprate because:
  22  1. There are many pawns, so knowing the file helps.
  23  2. You dont need to dis-ambiguate a pawn move. exf7 is fine.
  24
  25 > findAPawnMove move_src move_dest queen brd@(Board arr mv _)
  26 >       = debug (move_txt,new_brd)
  27 >   where
  28
  29 >       move_colour = getMoveColour mv
  30
  31 >       debug   = {- trace (
  32 >               {- userFormat brd ++ -}
  33 >               userFormat (getMoveColour mv) ++
  34 >               -- " (" ++ userFormat absmove ++ ")" ++
  35 >               "\nALL   :" ++ unwords (map userFormat all_moves) ++
  36 >               "\n") -} id
  37
  38 Now get all valid moves (for the correct piece), including some
  39 illegal moves (ie. pinned pieces).
  40
  41 >       correct_src = concat (map (getAllMovesFor brd) currPieces)
  42
  43 >       currPieces  =
  44 >               [ (Pawn,x,y) |
  45 >                       (x,y) <- start_range,
  46 >                       r <- [arr ! (x,y)],
  47 >                       lookupSquare move_colour r == Friendly,
  48 >                       (Just Pawn) <- [getSquarePiece r]]
  49
  50 Now filter out the moves it *cant* be.
  51
  52 >       start_range
  53 >          = case (move_src,move_dest) of
  54 >               ((Just f,Just r),_) -> [(f,r)]
  55 >               ((Just f,_),_) -> [(f,r) | r <- [2..7]]
  56 >               -- no capture !
  57 >               (_,(Just f,_)) -> [(f,r) | r <- [2..7]]
  58 >               _ -> error "strange pawn move:"
  59
  60 >       the_correct_move = if (length correct_move /= 1)
  61 >                          then error ("\nAmbiguous move:"
  62 >               ++ show (unwords (map userFormat correct_move))
  63 >               ++ ":" ++ {- userFormat absmove ++ -} "\n"
  64 >               ++ userFormat brd)
  65 >               else head correct_move
  66
  67 >       correct_move =
  68 >               filter (sameQueening queen.extractSpecialFromPlayMove)
  69 >               (filter (compExBPandBP move_dest.extractDestFromPlayMove)
  70 >                       correct_src)
  71 >       sameQueening (Just p) (Queening p') = p == p'
  72 >       sameQueening Nothing  (Queening p') = Queen == p'
  73 >       sameQueening _ _ = True
  74
  75 >       move_txt = createShortMove the_correct_move "" brd
  76 >       corr_txt =
  77 >           userFormatBoardPos
  78 >               (extractSrcFromPlayMove the_correct_move) ++
  79 >           userFormatBoardPos
  80 >               (extractDestFromPlayMove the_correct_move)
  81 >               {- queening ?? -}
  82 >       new_brd = makeAMove brd the_correct_move
  83
  84 Now castling, which is very obvious.
  85
  86 Now piece movement.
  87
  88 > findAMove
  89 >       :: Piece
  90 >       -> ExBoardPos
  91 >       -> ExBoardPos
  92 >       -> Board
  93 >       -> (String,Board)
  94
  95 > findAMove move_piece move_src move_dest brd@(Board arr mv _)
  96 >       = debug (move_txt,new_brd)
  97 >   where
  98
  99 First get char's about this move
 100
 101 >       move_colour = getMoveColour mv
 102
 103 >       debug   = {- trace (
 104 >               {- userFormat brd ++ -}
 105 >               userFormat (getMoveColour mv) ++
 106 >               " (" ++ {- userFormat absmove ++ -} ")" ++
 107 >               "\nALL   :" ++ unwords (map userFormat all_moves) ++
 108 >               "\nDEST  :" ++ unwords (map userFormat correct_dest) ++
 109 >               "\nSRC   :" ++ unwords (map userFormat correct_move) ++
 110 >               "\n") -} id
 111 >
 112
 113 Now get all valid moves (for the correct piece), including some
 114 illegal moves (ie. pinned pieces).
 115
 116 >       all_moves = allValidMoves brd move_piece (const True)
 117
 118 Now filter out the moves it *cant* be.
 119
 120 >       correct_dest = filter
 121 >               (compExBPandBP move_dest.extractDestFromPlayMove)
 122 >                       all_moves
 123 >       correct_move = filter
 124 >               (compExBPandBP move_src.extractSrcFromPlayMove)
 125 >                       correct_dest
 126 >       the_correct_move = if (length correct_move /= 1)
 127 >                          then error ("\nAmbiguous move:"
 128 >               ++ show (unwords (map userFormat correct_move))
 129 >               ++ ":" {- ++ userFormat absmove -} ++ "\n"
 130 >               ++ userFormat brd)
 131 >               else head correct_move
 132 >       disamb = case move_dest of
 133 >                 (Just _,Nothing) -> ""        -- fg => fxg4, no disambig.
 134 >                 _ -> disAmb
 135 >                    (extractSrcFromPlayMove the_correct_move)
 136 >                    (map (extractSrcFromPlayMove) correct_dest)
 137
 138 >       move_txt = createShortMove the_correct_move disamb brd
 139 >       corr_txt =
 140 >           userFormatBoardPos
 141 >               (extractSrcFromPlayMove the_correct_move) ++
 142 >           userFormatBoardPos
 143 >               (extractDestFromPlayMove the_correct_move)
 144 >               {- queening -}
 145 >       new_brd = makeAMove brd the_correct_move
 146 > --partain: findAMove _ _ _ brd = error ("strange move: ")
 147
 148 > allValidMoves :: Board -> Piece -> (ChessFile -> Bool) -> [PlayMove]
 149 > allValidMoves brd piece corr_file
 150 >   = concat (map (getAllMovesFor brd) (getCurrPieces brd piece corr_file))
 151
 152 > getCurrPieces
 153 >       :: Board
 154 >       -> Piece
 155 >       -> (ChessFile -> Bool)
 156 >       -> [(Piece,ChessFile,ChessRank)]
 157 > getCurrPieces (Board arr (MoveNumber _ col) _) pc corr_file =
 158 >       [ (p,x,y) |
 159 >               ((x,y), r) <- assocs arr,
 160 >               lookupSquare col r == Friendly,
 161 >               (Just p) <- [getSquarePiece r],
 162 >               p == pc,
 163 >               corr_file x
 164 >                ]
 165
 166 %------------------------------------------------------------------------------
 167
 168 Given a board and a particular piece,
 169 where can it get to ?
 170
 171 > getAllMovesFor :: Board -> (Piece,Int,Int) -> [PlayMove]
 172
 173 First the easy pieces, the gliders.
 174
 175 > getAllMovesFor brd (Rook,x,y) =
 176 >       [ mkPlayMove Rook (x,y) (x',y')
 177 >         | (x',y') <- (
 178 >               movePiece 0    1 brd x y ++
 179 >               movePiece 0 (-1) brd x y ++
 180 >               movePiece 1    0 brd x y ++
 181 >               movePiece (-1) 0 brd x y) ]
 182 > getAllMovesFor brd (Bishop,x,y) =
 183 >       [ mkPlayMove Bishop (x,y) (x',y')
 184 >         | (x',y') <- (
 185 >               movePiece 1      1  brd x y ++
 186 >               movePiece 1    (-1) brd x y ++
 187 >               movePiece (-1)   1  brd x y ++
 188 >               movePiece (-1) (-1) brd x y) ]
 189 > getAllMovesFor brd (Queen,x,y) =
 190 >       [ mkPlayMove Queen (x,y) (x',y')
 191 >         | (x',y') <- (
 192 >               movePiece 0    1    brd x y ++
 193 >               movePiece 0 (-1)    brd x y ++
 194 >               movePiece 1    0    brd x y ++
 195 >               movePiece (-1) 0    brd x y ++
 196 >               movePiece 1      1  brd x y ++
 197 >               movePiece 1    (-1) brd x y ++
 198 >               movePiece (-1)   1  brd x y ++
 199 >               movePiece (-1) (-1) brd x y) ]
 200
 201 Now the `hoppers'.
 202
 203 > getAllMovesFor brd (Knight,x,y) =
 204 >       [ mkPlayMove Knight (x,y) (x',y')
 205 >           | (xd,yd) <- concat
 206 >                       [ [(d1,d2 * 2),(d1 * 2,d2)]
 207 >                               | d1 <- [1,-1], d2 <- [1,-1]],
 208 >               x' <- [xd + x],
 209 >               y' <- [yd + y],
 210 >               case lookupBoard brd (x',y') of
 211 >                 Vacant -> True
 212 >                 Friendly -> False
 213 >                 Baddy -> True
 214 >                 OffBoard -> False]
 215
 216 > getAllMovesFor brd (King,x,y) =
 217 >       [ mkPlayMove King (x,y) (x',y')
 218 >           | (xd,yd) <- [(1,1),(1,0),(1,-1),(0,1),
 219 >                         (0,-1),(-1,1),(-1,0),(-1,-1)],
 220 >               x' <- [xd + x],
 221 >               y' <- [yd + y],
 222 >               case lookupBoard brd (x',y') of
 223 >                 Vacant -> True
 224 >                 Friendly -> False
 225 >                 Baddy -> True
 226 >                 OffBoard -> False]
 227
 228 Now the *special* case, the pawn! Pain in the neck.
 229 ToDo: add en-passant
 230
 231 > getAllMovesFor brd@(Board _ (MoveNumber _ col) may_ep) (Pawn,x,y)
 232 >       = real_pawn_moves
 233 >   where
 234 >       pawn_moves =
 235 >               case lookupBoard brd (x,y+del) of
 236 >                 Friendly -> []
 237 >                 Baddy -> []
 238 >                 Vacant -> (mkPlayMove Pawn (x,y) (x,y+del) :
 239 >                    if y /= sta then [] else
 240 >                    case lookupBoard brd (x,y+del*2) of
 241 >                       Friendly -> []
 242 >                       Baddy -> []
 243 >                       Vacant ->
 244 >                         [ PlayMove Pawn (x,y) (x,y+del*2) BigPawnMove])
 245 >       left_pc = case lookupBoard brd (x-1,y+del) of
 246 >                        Baddy -> [mkPlayMove Pawn (x,y) (x-1,y+del) ]
 247 >                        _ -> []
 248 >       right_pc = case lookupBoard brd (x+1,y+del) of
 249 >                        Baddy -> [mkPlayMove Pawn (x,y) (x+1,y+del) ]
 250 >                        _ -> []
 251 >       all_pawn_moves = pawn_moves ++ left_pc ++ right_pc
 252 >       real_pawn_moves = en_passant ++
 253 >               (if y + del == qn       -- if can queens
 254 >               then concat [ let fn = PlayMove Pawn f t . Queening
 255 >                             in
 256 >                               [ fn Queen,
 257 >                                 fn Rook,
 258 >                                 fn Bishop,
 259 >                                 fn Knight ]
 260 >                               | PlayMove _ f t _ <- all_pawn_moves ]
 261 >                 else all_pawn_moves)
 262 >       en_passant =
 263 >           case (y == ep,may_ep) of
 264 >               (True,Just f) | f == x+1 || f == x-1
 265 >                 -> [PlayMove Pawn (x,y) (f,y+del) EnPassant]
 266 >               _ -> []
 267 >       del,sta,qn,ep :: Int
 268 >       (del,sta,qn,ep) -- delta (direction), start, Queening and E.P. Rank
 269 >           = case col of
 270 >               White -> (1,2,8,5)
 271 >               Black -> (-1,7,1,4)
 272
 273 > movePiece xd yd brd x y =
 274 >       case lookupBoard brd (x',y') of
 275 >         OffBoard -> []
 276 >         Friendly -> []
 277 >         Baddy    -> [(x',y')]
 278 >         Vacant   ->  (x',y') : movePiece xd yd brd x' y'
 279 >       where
 280 >           x' = x + xd
 281 >           y' = y + yd
 282
 283
 284 %------------------------------------------------------------------------------
 285
 286 > makeAMove :: Board -> PlayMove -> Board
 287 > makeAMove board@(Board brd mv@(MoveNumber _ col) _)
 288 >       move@(PlayMove piece pos pos' NothingSpecial)  =
 289 >       Board (brd //  [ pos =: VacantSq,
 290 >                       pos' =: mkColBoardSq col piece ])
 291 >                       (incMove mv) Nothing
 292 > makeAMove board@(Board brd mv@(MoveNumber _ col) _)
 293 >       move@(PlayMove piece pos@(f,_) pos' BigPawnMove)  =
 294 >       Board (brd //  [ pos =: VacantSq,
 295 >                       pos' =: mkColBoardSq col piece ])
 296 >                       (incMove mv) (Just f)
 297 > makeAMove board@(Board brd mv@(MoveNumber _ col) _)
 298 >       move@(PlayMove piece pos@(f,_) pos' (Queening q))  =
 299 >       Board (brd //  [ pos =: VacantSq,
 300 >                       pos' =: mkColBoardSq col q])
 301 >                       (incMove mv) (Just f)
 302 > makeAMove board@(Board brd mv@(MoveNumber _ col) _)   -- ASSERT ?
 303 >       move@(PlayMove piece (f,_) (f',_) EnPassant) =
 304 >       Board (brd // [ (f,st) =: VacantSq,
 305 >                       (f',fn) =: mkColBoardSq col Pawn,
 306 >                       (f',st) =: VacantSq ])
 307 >                       (incMove mv) Nothing
 308 >   where (st,fn) = case col of
 309 >                     White -> (5,6)
 310 >                     Black -> (4,3)
 311
 312 > makeACastleK (Board brd mv@(MoveNumber _ White) _) =
 313 >       Board (brd //
 314 >             [ (5,1) =: VacantSq,
 315 >               (6,1) =: mkColBoardSq White Rook,
 316 >               (7,1) =: mkColBoardSq White King,
 317 >               (8,1) =: VacantSq ]) (incMove mv) Nothing
 318 > makeACastleK (Board brd mv@(MoveNumber _ Black) _) =
 319
 320 >       Board (brd //
 321 >             [ (5,8) =: VacantSq,
 322 >               (6,8) =: mkColBoardSq Black Rook,
 323 >               (7,8) =: mkColBoardSq Black King,
 324 >               (8,8) =: VacantSq ]) (incMove mv) Nothing
 325 > makeACastleQ (Board brd mv@(MoveNumber _ White) _) =
 326 >       Board (brd //
 327 >             [ (5,1) =: VacantSq,
 328 >               (4,1) =: mkColBoardSq White Rook,
 329 >               (3,1) =: mkColBoardSq White King,
 330 >               (1,1) =: VacantSq ]) (incMove mv) Nothing
 331 > makeACastleQ (Board brd mv@(MoveNumber _ Black) _) =
 332 >       Board (brd //
 333 >             [ (5,8) =: VacantSq,
 334 >               (4,8) =: mkColBoardSq Black Rook,
 335 >               (3,8) =: mkColBoardSq Black King,
 336 >               (1,8) =: VacantSq ]) (incMove mv) Nothing
 337
 338 > disAmb _ [_] = ""
 339 > disAmb (a,b) t@[(n,m),(x,y)]
 340 >       | n == x    = userFormatRank b
 341 >       | otherwise = userFormatFile a
 342 > disAmb src lst = error ("PANIC: cant disambiguate: " ++ show src ++ show lst)
 343
 344 > createShortMove :: PlayMove -> String -> Board -> String
 345 > createShortMove (PlayMove Pawn (f,r) dest q) "" brd =
 346 >       (if lookupBoard brd dest == Baddy || EnPassant == q
 347 >        then userFormatFile f ++ "x" ++ userFormatBoardPos dest
 348 >        else userFormatBoardPos dest) ++
 349 >       case q of
 350 >         Queening p -> "=" ++ userFormat p
 351 >         _ -> ""
 352 > createShortMove (PlayMove p _ dest _) extra brd =
 353 >       userFormat p ++ extra ++ capt ++ userFormatBoardPos dest
 354 >   where
 355 >       capt = if lookupBoard brd dest == Baddy
 356 >              then "x"
 357 >              else ""
 358
 359 > getEPStart :: Colour -> ChessFile
 360 > getEPStart White = 5
 361 > getEPStart Black = 4
 362
 363 > getEPEnd :: Colour -> ChessFile
 364 > getEPEnd White = 6
 365 > getEPEnd Black = 3
 366
 367 > getHomeRank :: Colour -> ChessRank
 368 > getHomeRank White = 1
 369 > getHomeRank Black = 8
 370