summaryrefslogtreecommitdiff
path: root/testsuite/tests/programs/andy_cherry/InterpUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/programs/andy_cherry/InterpUtils.hs')
-rw-r--r--testsuite/tests/programs/andy_cherry/InterpUtils.hs371
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
+
View Lorry Controller Status