module InterpUtils where import GenUtils import DataTypes import Data.Array -- 1.3 findCastleKMove brd = (castleK,makeACastleK brd) findCastleQMove brd = (castleQ,makeACastleQ brd) findAPawnMove :: ExBoardPos -> ExBoardPos -> Maybe Piece -> Board -> (String,Board) 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 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]] 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 findAMove :: Piece -> ExBoardPos -> ExBoardPos -> Board -> (String,Board) findAMove move_piece move_src move_dest 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) ++ "\nDEST :" ++ unwords (map userFormat correct_dest) ++ "\nSRC :" ++ unwords (map userFormat correct_move) ++ "\n") -} id all_moves = allValidMoves brd move_piece (const True) 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 ] getAllMovesFor :: Board -> (Piece,Int,Int) -> [PlayMove] 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) ] 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] 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