+++ /dev/null
-> module InterpUtils where
-
-> import GenUtils
-> import DataTypes
-> import Array -- 1.3
-
-%------------------------------------------------------------------------------
-
-This part computes the effect a move has on its board.
-
-> findCastleKMove brd = (castleK,makeACastleK brd)
-> findCastleQMove brd = (castleQ,makeACastleQ brd)
-
-> findAPawnMove
-> :: ExBoardPos
-> -> ExBoardPos
-> -> Maybe Piece
-> -> Board
-> -> (String,Board)
-
-First the pawns. They are seprate because:
- 1. There are many pawns, so knowing the file helps.
- 2. You dont need to dis-ambiguate a pawn move. exf7 is fine.
-
-> findAPawnMove move_src move_dest queen brd@(Board arr mv _)
-> = debug (move_txt,new_brd)
-> where
-
-> move_colour = getMoveColour mv
-
-> debug = {- trace (
-> {- userFormat brd ++ -}
-> userFormat (getMoveColour mv) ++
-> -- " (" ++ userFormat absmove ++ ")" ++
-> "\nALL :" ++ unwords (map userFormat all_moves) ++
-> "\n") -} id
-
-Now get all valid moves (for the correct piece), including some
-illegal moves (ie. pinned pieces).
-
-> correct_src = concat (map (getAllMovesFor brd) currPieces)
-
-> currPieces =
-> [ (Pawn,x,y) |
-> (x,y) <- start_range,
-> r <- [arr ! (x,y)],
-> lookupSquare move_colour r == Friendly,
-> (Just Pawn) <- [getSquarePiece r]]
-
-Now filter out the moves it *cant* be.
-
-> start_range
-> = case (move_src,move_dest) of
-> ((Just f,Just r),_) -> [(f,r)]
-> ((Just f,_),_) -> [(f,r) | r <- [2..7]]
-> -- no capture !
-> (_,(Just f,_)) -> [(f,r) | r <- [2..7]]
-> _ -> error "strange pawn move:"
-
-> the_correct_move = if (length correct_move /= 1)
-> then error ("\nAmbiguous move:"
-> ++ show (unwords (map userFormat correct_move))
-> ++ ":" ++ {- userFormat absmove ++ -} "\n"
-> ++ userFormat brd)
-> else head correct_move
-
-> correct_move =
-> filter (sameQueening queen.extractSpecialFromPlayMove)
-> (filter (compExBPandBP move_dest.extractDestFromPlayMove)
-> correct_src)
-> sameQueening (Just p) (Queening p') = p == p'
-> sameQueening Nothing (Queening p') = Queen == p'
-> sameQueening _ _ = True
-
-> move_txt = createShortMove the_correct_move "" brd
-> corr_txt =
-> userFormatBoardPos
-> (extractSrcFromPlayMove the_correct_move) ++
-> userFormatBoardPos
-> (extractDestFromPlayMove the_correct_move)
-> {- queening ?? -}
-> new_brd = makeAMove brd the_correct_move
-
-Now castling, which is very obvious.
-
-Now piece movement.
-
-> findAMove
-> :: Piece
-> -> ExBoardPos
-> -> ExBoardPos
-> -> Board
-> -> (String,Board)
-
-> findAMove move_piece move_src move_dest brd@(Board arr mv _)
-> = debug (move_txt,new_brd)
-> where
-
-First get char's about this move
-
-> move_colour = getMoveColour mv
-
-> debug = {- trace (
-> {- userFormat brd ++ -}
-> userFormat (getMoveColour mv) ++
-> " (" ++ {- userFormat absmove ++ -} ")" ++
-> "\nALL :" ++ unwords (map userFormat all_moves) ++
-> "\nDEST :" ++ unwords (map userFormat correct_dest) ++
-> "\nSRC :" ++ unwords (map userFormat correct_move) ++
-> "\n") -} id
->
-
-Now get all valid moves (for the correct piece), including some
-illegal moves (ie. pinned pieces).
-
-> all_moves = allValidMoves brd move_piece (const True)
-
-Now filter out the moves it *cant* be.
-
-> correct_dest = filter
-> (compExBPandBP move_dest.extractDestFromPlayMove)
-> all_moves
-> correct_move = filter
-> (compExBPandBP move_src.extractSrcFromPlayMove)
-> correct_dest
-> the_correct_move = if (length correct_move /= 1)
-> then error ("\nAmbiguous move:"
-> ++ show (unwords (map userFormat correct_move))
-> ++ ":" {- ++ userFormat absmove -} ++ "\n"
-> ++ userFormat brd)
-> else head correct_move
-> disamb = case move_dest of
-> (Just _,Nothing) -> "" -- fg => fxg4, no disambig.
-> _ -> disAmb
-> (extractSrcFromPlayMove the_correct_move)
-> (map (extractSrcFromPlayMove) correct_dest)
-
-> move_txt = createShortMove the_correct_move disamb brd
-> corr_txt =
-> userFormatBoardPos
-> (extractSrcFromPlayMove the_correct_move) ++
-> userFormatBoardPos
-> (extractDestFromPlayMove the_correct_move)
-> {- queening -}
-> new_brd = makeAMove brd the_correct_move
-> --partain: findAMove _ _ _ brd = error ("strange move: ")
-
-> allValidMoves :: Board -> Piece -> (ChessFile -> Bool) -> [PlayMove]
-> allValidMoves brd piece corr_file
-> = concat (map (getAllMovesFor brd) (getCurrPieces brd piece corr_file))
-
-> getCurrPieces
-> :: Board
-> -> Piece
-> -> (ChessFile -> Bool)
-> -> [(Piece,ChessFile,ChessRank)]
-> getCurrPieces (Board arr (MoveNumber _ col) _) pc corr_file =
-> [ (p,x,y) |
-> ((x,y), r) <- assocs arr,
-> lookupSquare col r == Friendly,
-> (Just p) <- [getSquarePiece r],
-> p == pc,
-> corr_file x
-> ]
-
-%------------------------------------------------------------------------------
-
-Given a board and a particular piece,
-where can it get to ?
-
-> getAllMovesFor :: Board -> (Piece,Int,Int) -> [PlayMove]
-
-First the easy pieces, the gliders.
-
-> getAllMovesFor brd (Rook,x,y) =
-> [ mkPlayMove Rook (x,y) (x',y')
-> | (x',y') <- (
-> movePiece 0 1 brd x y ++
-> movePiece 0 (-1) brd x y ++
-> movePiece 1 0 brd x y ++
-> movePiece (-1) 0 brd x y) ]
-> getAllMovesFor brd (Bishop,x,y) =
-> [ mkPlayMove Bishop (x,y) (x',y')
-> | (x',y') <- (
-> movePiece 1 1 brd x y ++
-> movePiece 1 (-1) brd x y ++
-> movePiece (-1) 1 brd x y ++
-> movePiece (-1) (-1) brd x y) ]
-> getAllMovesFor brd (Queen,x,y) =
-> [ mkPlayMove Queen (x,y) (x',y')
-> | (x',y') <- (
-> movePiece 0 1 brd x y ++
-> movePiece 0 (-1) brd x y ++
-> movePiece 1 0 brd x y ++
-> movePiece (-1) 0 brd x y ++
-> movePiece 1 1 brd x y ++
-> movePiece 1 (-1) brd x y ++
-> movePiece (-1) 1 brd x y ++
-> movePiece (-1) (-1) brd x y) ]
-
-Now the `hoppers'.
-
-> getAllMovesFor brd (Knight,x,y) =
-> [ mkPlayMove Knight (x,y) (x',y')
-> | (xd,yd) <- concat
-> [ [(d1,d2 * 2),(d1 * 2,d2)]
-> | d1 <- [1,-1], d2 <- [1,-1]],
-> x' <- [xd + x],
-> y' <- [yd + y],
-> case lookupBoard brd (x',y') of
-> Vacant -> True
-> Friendly -> False
-> Baddy -> True
-> OffBoard -> False]
-
-> getAllMovesFor brd (King,x,y) =
-> [ mkPlayMove King (x,y) (x',y')
-> | (xd,yd) <- [(1,1),(1,0),(1,-1),(0,1),
-> (0,-1),(-1,1),(-1,0),(-1,-1)],
-> x' <- [xd + x],
-> y' <- [yd + y],
-> case lookupBoard brd (x',y') of
-> Vacant -> True
-> Friendly -> False
-> Baddy -> True
-> OffBoard -> False]
-
-Now the *special* case, the pawn! Pain in the neck.
-ToDo: add en-passant
-
-> getAllMovesFor brd@(Board _ (MoveNumber _ col) may_ep) (Pawn,x,y)
-> = real_pawn_moves
-> where
-> pawn_moves =
-> case lookupBoard brd (x,y+del) of
-> Friendly -> []
-> Baddy -> []
-> Vacant -> (mkPlayMove Pawn (x,y) (x,y+del) :
-> if y /= sta then [] else
-> case lookupBoard brd (x,y+del*2) of
-> Friendly -> []
-> Baddy -> []
-> Vacant ->
-> [ PlayMove Pawn (x,y) (x,y+del*2) BigPawnMove])
-> left_pc = case lookupBoard brd (x-1,y+del) of
-> Baddy -> [mkPlayMove Pawn (x,y) (x-1,y+del) ]
-> _ -> []
-> right_pc = case lookupBoard brd (x+1,y+del) of
-> Baddy -> [mkPlayMove Pawn (x,y) (x+1,y+del) ]
-> _ -> []
-> all_pawn_moves = pawn_moves ++ left_pc ++ right_pc
-> real_pawn_moves = en_passant ++
-> (if y + del == qn -- if can queens
-> then concat [ let fn = PlayMove Pawn f t . Queening
-> in
-> [ fn Queen,
-> fn Rook,
-> fn Bishop,
-> fn Knight ]
-> | PlayMove _ f t _ <- all_pawn_moves ]
-> else all_pawn_moves)
-> en_passant =
-> case (y == ep,may_ep) of
-> (True,Just f) | f == x+1 || f == x-1
-> -> [PlayMove Pawn (x,y) (f,y+del) EnPassant]
-> _ -> []
-> del,sta,qn,ep :: Int
-> (del,sta,qn,ep) -- delta (direction), start, Queening and E.P. Rank
-> = case col of
-> White -> (1,2,8,5)
-> Black -> (-1,7,1,4)
-
-> movePiece xd yd brd x y =
-> case lookupBoard brd (x',y') of
-> OffBoard -> []
-> Friendly -> []
-> Baddy -> [(x',y')]
-> Vacant -> (x',y') : movePiece xd yd brd x' y'
-> where
-> x' = x + xd
-> y' = y + yd
-
-
-%------------------------------------------------------------------------------
-
-> makeAMove :: Board -> PlayMove -> Board
-> makeAMove board@(Board brd mv@(MoveNumber _ col) _)
-> move@(PlayMove piece pos pos' NothingSpecial) =
-> Board (brd // [ pos =: VacantSq,
-> pos' =: mkColBoardSq col piece ])
-> (incMove mv) Nothing
-> makeAMove board@(Board brd mv@(MoveNumber _ col) _)
-> move@(PlayMove piece pos@(f,_) pos' BigPawnMove) =
-> Board (brd // [ pos =: VacantSq,
-> pos' =: mkColBoardSq col piece ])
-> (incMove mv) (Just f)
-> makeAMove board@(Board brd mv@(MoveNumber _ col) _)
-> move@(PlayMove piece pos@(f,_) pos' (Queening q)) =
-> Board (brd // [ pos =: VacantSq,
-> pos' =: mkColBoardSq col q])
-> (incMove mv) (Just f)
-> makeAMove board@(Board brd mv@(MoveNumber _ col) _) -- ASSERT ?
-> move@(PlayMove piece (f,_) (f',_) EnPassant) =
-> Board (brd // [ (f,st) =: VacantSq,
-> (f',fn) =: mkColBoardSq col Pawn,
-> (f',st) =: VacantSq ])
-> (incMove mv) Nothing
-> where (st,fn) = case col of
-> White -> (5,6)
-> Black -> (4,3)
-
-> makeACastleK (Board brd mv@(MoveNumber _ White) _) =
-> Board (brd //
-> [ (5,1) =: VacantSq,
-> (6,1) =: mkColBoardSq White Rook,
-> (7,1) =: mkColBoardSq White King,
-> (8,1) =: VacantSq ]) (incMove mv) Nothing
-> makeACastleK (Board brd mv@(MoveNumber _ Black) _) =
-
-> Board (brd //
-> [ (5,8) =: VacantSq,
-> (6,8) =: mkColBoardSq Black Rook,
-> (7,8) =: mkColBoardSq Black King,
-> (8,8) =: VacantSq ]) (incMove mv) Nothing
-> makeACastleQ (Board brd mv@(MoveNumber _ White) _) =
-> Board (brd //
-> [ (5,1) =: VacantSq,
-> (4,1) =: mkColBoardSq White Rook,
-> (3,1) =: mkColBoardSq White King,
-> (1,1) =: VacantSq ]) (incMove mv) Nothing
-> makeACastleQ (Board brd mv@(MoveNumber _ Black) _) =
-> Board (brd //
-> [ (5,8) =: VacantSq,
-> (4,8) =: mkColBoardSq Black Rook,
-> (3,8) =: mkColBoardSq Black King,
-> (1,8) =: VacantSq ]) (incMove mv) Nothing
-
-> disAmb _ [_] = ""
-> disAmb (a,b) t@[(n,m),(x,y)]
-> | n == x = userFormatRank b
-> | otherwise = userFormatFile a
-> disAmb src lst = error ("PANIC: cant disambiguate: " ++ show src ++ show lst)
-
-> createShortMove :: PlayMove -> String -> Board -> String
-> createShortMove (PlayMove Pawn (f,r) dest q) "" brd =
-> (if lookupBoard brd dest == Baddy || EnPassant == q
-> then userFormatFile f ++ "x" ++ userFormatBoardPos dest
-> else userFormatBoardPos dest) ++
-> case q of
-> Queening p -> "=" ++ userFormat p
-> _ -> ""
-> createShortMove (PlayMove p _ dest _) extra brd =
-> userFormat p ++ extra ++ capt ++ userFormatBoardPos dest
-> where
-> capt = if lookupBoard brd dest == Baddy
-> then "x"
-> else ""
-
-> getEPStart :: Colour -> ChessFile
-> getEPStart White = 5
-> getEPStart Black = 4
-
-> getEPEnd :: Colour -> ChessFile
-> getEPEnd White = 6
-> getEPEnd Black = 3
-
-> getHomeRank :: Colour -> ChessRank
-> getHomeRank White = 1
-> getHomeRank Black = 8
-
projects / ghc-hetmet.git / blobdiff