diff options
Diffstat (limited to 'testsuite/tests/programs/andy_cherry/InterpUtils.hs')
| -rw-r--r-- | testsuite/tests/programs/andy_cherry/InterpUtils.hs | 371 |
1 files changed, 371 insertions, 0 deletions
diff --git a/testsuite/tests/programs/andy_cherry/InterpUtils.hs b/testsuite/tests/programs/andy_cherry/InterpUtils.hs new file mode 100644 index 0000000000..820163e8fd --- /dev/null +++ b/testsuite/tests/programs/andy_cherry/InterpUtils.hs @@ -0,0 +1,371 @@ + + 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 + |