hcheckers-0.1.0.0: src/Rules/Generic.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
module Rules.Generic where
import Data.List
import Data.Maybe
import Core.Types
import Core.Board
import Core.BoardMap
-- | Describes one jump during capture move;
-- capture can conssit of several jumps.
data Capture = Capture {
cSrc :: Address -- ^ Source piece position
, cDirection :: PlayerDirection -- ^ Direction of jump
, cInitSteps :: Int -- ^ Number of steps by free fields that we have to do before the actual capture.
-- If a piece is a man, this is obviously always 0.
, cVictim :: Address -- ^ Position of piece being captured
, cFreeSteps :: Int -- ^ Number of steps by free fields that we are doing after actual capture.
-- For man, this is always 1.
, cDst :: Address -- ^ End position of capture.
, cPromote :: Bool -- ^ Whether the piece should be promoted at the end of this jump.
}
-- | State that we have to track during single capture move.
data CaptureState = CaptureState {
ctPrevDirection :: Maybe PlayerDirection -- ^ Previous capture direction
, ctCaptured :: LabelSet -- ^ Fields that were already captured; we have to track this to prevent one piece being captured twice
, ctPiece :: Piece -- ^ Piece that is performing the capture
, ctBoard :: Board -- ^ Current board state
, ctCurrent :: Address -- ^ Current position of the piece
, ctSource :: Address -- ^ Starting position of capture
}
-- | Initial capture state
initState :: Piece -> Board -> Address -> CaptureState
initState piece board src = CaptureState Nothing emptyLabelSet piece board src src
-- | An `Abstract class` for game rules
data GenericRules = GenericRules {
gPossibleMoves :: Side -> Board -> [PossibleMove]
, gMobilityScore :: Side -> Board -> Int
, gPossibleSimpleMoves1 :: Board -> Address -> [PossibleMove]
, gPossibleCaptures1 :: Board -> Address -> [PossibleMove]
, gManSimpleMoves :: Side -> Board -> Address -> [PossibleMove]
, gKingSimpleMoves :: Side -> Board -> Address -> [PossibleMove]
, gManCaptures :: CaptureState -> [PossibleMove]
, gKingCaptures :: CaptureState -> [PossibleMove]
, gPieceCaptures1 :: CaptureState -> [Capture]
, gPieceCaptures :: CaptureState -> [PossibleMove]
, gManCaptures1 :: CaptureState -> [Capture]
, gKingCaptures1 :: CaptureState -> [Capture]
, gCanCaptureFrom :: CaptureState -> Bool
, gManSimpleMoveDirections :: [PlayerDirection]
, gKingSimpleMoveDirections :: [PlayerDirection]
, gManCaptureDirections :: [PlayerDirection]
, gKingCaptureDirections :: [PlayerDirection]
, gBoardOrientation :: BoardOrientation
, gCaptureMax :: Bool
}
instance HasBoardOrientation GenericRules where
boardOrientation = gBoardOrientation
translateCapture :: Piece -> Capture -> [PossibleMove]
translateCapture piece@(Piece _ side) capture =
[PossibleMove {
pmBegin = src,
pmEnd = dst,
pmVictims = [victim],
pmMove = Move src (steps $ cFreeSteps capture),
pmPromote = promote,
pmResult = [Take src, RemoveCaptured victim, Put dst piece']
}]
where
steps n = replicate (cInitSteps capture) (Step dir False False) ++
[Step dir True False] ++
replicate (n-1) (Step dir False False) ++
[Step dir False promote]
dir = cDirection capture
promote = cPromote capture
src = cSrc capture
dst = cDst capture
victim = cVictim capture
piece' = if promote then promotePiece piece else piece
freeFields :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Board -> (Int, [Address])
freeFields rules side dir addr board =
case myNeighbour rules side dir addr of
Nothing -> (0, [])
Just a' -> if isFree a' board
then let (n, prev) = freeFields rules side dir a' board
in (n+1, a' : prev)
else (0, [])
genericNextMoves :: GenericRules -> CaptureState -> Bool -> PossibleMove -> [PossibleMove]
genericNextMoves rules ct@(CaptureState {..}) continuePromoted pm =
gPieceCaptures rules $ ct {
ctPrevDirection = Just (firstMoveDirection m),
ctCaptured = captured',
ctPiece = piece',
ctBoard = b,
ctCurrent = pmEnd pm
}
where
m = pmMove pm
promoted = if pmPromote pm
then promotePiece ctPiece
else ctPiece
piece' = if continuePromoted
then promoted
else ctPiece
b = setPiece (pmEnd pm) piece' $ removePiece ctCurrent ctBoard
captured' = foldr insertLabelSet ctCaptured (map aLabel $ pmVictims pm)
abstractRules :: GenericRules -> GenericRules
abstractRules =
let
possibleMoves rules side board =
-- let (simpleMoves, captures) = searchMoves rules side board False ([], [])
let simpleMoves = concatMap (gManSimpleMoves rules side board) (filter (manHasSimpleMoves rules side board) $ myMenA side board) ++
concatMap (gKingSimpleMoves rules side board) (myKingsA side board)
captures = concatMap (manCaptures' rules side board) (filter (manHasCaptures rules side board) $ myMenA side board) ++
concatMap (kingCaptures' rules side board) (myKingsA side board)
-- concatMap (gPossibleCaptures1 rules board) (allMyAddresses side board)
in if gCaptureMax rules
then
if null captures
then simpleMoves
else
let captures' = sortOn (negate . length . pmVictims) captures
n = length $ pmVictims (head captures')
in filter (\c -> length (pmVictims c) == n) captures'
else if null captures
then simpleMoves
else captures
-- searchMoves _ _ _ _ (accSimple, accCaptures) [] = (accSimple, accCaptures)
-- searchMoves rules side board False (accSimple, accCaptures) ((addr, pieceKind) : rest) =
-- case pieceKind of
-- Man | manHasCaptures rules side board addr ->
-- let captures = manCaptures' rules side board addr
-- in searchMoves rules side board True ([], captures ++ accCaptures) rest
-- | manHasSimpleMoves rules side board addr ->
-- let moves = gManSimpleMoves rules side board addr
-- in searchMoves rules side board False (moves ++ accSimple, accCaptures) rest
-- | otherwise ->
-- searchMoves rules side board False (accSimple, accCaptures) rest
-- King -> let captures = kingCaptures' rules side board addr
-- simple = gKingSimpleMoves rules side board addr
-- in if null captures
-- then searchMoves rules side board False (simple ++ accSimple, accCaptures) rest
-- else searchMoves rules side board True ([], captures ++ accCaptures) rest
-- searchMoves rules side board True (accSimple, accCaptures) ((addr, pieceKind) : rest) =
-- case pieceKind of
-- Man | manHasCaptures rules side board addr ->
-- let captures = manCaptures' rules side board addr
-- in searchMoves rules side board True ([], captures ++ accCaptures) rest
-- | otherwise ->
-- searchMoves rules side board True (accSimple, accCaptures) rest
-- King -> let captures = kingCaptures' rules side board addr
-- in searchMoves rules side board True ([], captures ++ accCaptures) rest
mobility rules side board =
let (men, kings) = myCounts side board
in if kings > 0
then kings * 4
else sum $ map (manSimpleMovesCount rules side board) (myMenA side board)
manCaptures' rules side board src =
gManCaptures rules $ initState (Piece Man side) board src
kingCaptures' rules side board src =
gKingCaptures rules $ initState (Piece King side) board src
possibleSimpleMoves1 rules board src =
case getPiece src board of
Nothing -> error $ "possibleSimpleMoves1: not my field"
Just (Piece Man side) -> gManSimpleMoves rules side board src
Just (Piece King side) -> gKingSimpleMoves rules side board src
possibleCaptures1 rules board src =
case getPiece src board of
Nothing -> error $ "possibleCaptures: not my field"
Just piece@(Piece Man _) -> gManCaptures rules $ initState piece board src
Just piece@(Piece King _) -> gKingCaptures rules $ initState piece board src
pieceCaptures rules ct@(CaptureState {..}) =
case ctPiece of
(Piece Man _) -> gManCaptures rules ct
(Piece King _) -> gKingCaptures rules ct
manHasSimpleMoves rules side board src = any check (gManSimpleMoveDirections rules)
where
check dir =
case myNeighbour rules side dir src of
Nothing -> False
Just dst -> isFree dst board
manSimpleMovesCount rules side board src = sum $ map check (gManSimpleMoveDirections rules)
where
check dir =
case myNeighbour rules side dir src of
Nothing -> 0
Just dst -> if isFree dst board then 1 else 0
manSimpleMoves rules side board src =
mapMaybe check (gManSimpleMoveDirections rules)
where
check dir =
case myNeighbour rules side dir src of
Nothing -> Nothing
Just dst -> if isFree dst board
then let move = Move src [Step dir False promote]
promote = isLastHorizontal side dst
piece' = if promote then Piece King side else Piece Man side
in Just $ PossibleMove {
pmBegin = src,
pmEnd = dst,
pmVictims = [],
pmMove = move,
pmPromote = promote,
pmResult = [Take src, Put dst piece']
}
else Nothing
pieceCaptures1 rules ct@(CaptureState {..}) =
case ctPiece of
(Piece Man _) -> gManCaptures1 rules ct
(Piece King _) -> gKingCaptures1 rules ct
manHasCaptures rules side board src = any check (gManCaptureDirections rules)
where
check dir =
case myNeighbour rules side dir src of
Nothing -> False
Just victimAddr ->
if isPieceAt victimAddr board (opposite side)
then case myNeighbour rules side dir victimAddr of
Nothing -> False
Just dst -> isFree dst board
else False
manCaptures1 rules (CaptureState {..}) =
mapMaybe (check ctCurrent) $ filter allowedDir (gManCaptureDirections rules)
where
side = pieceSide ctPiece
allowedDir dir =
case ctPrevDirection of
Nothing -> True
Just prevDir -> oppositeDirection prevDir /= dir
check a dir =
case myNeighbour rules side dir a of
Just victimAddr | not (aLabel victimAddr `labelSetMember` ctCaptured) ->
if isPieceAt victimAddr ctBoard (opposite side)
then case myNeighbour rules side dir victimAddr of
Nothing -> Nothing
Just freeAddr -> if isFree freeAddr ctBoard
then Just $ Capture {
cSrc = a,
cDirection = dir,
cInitSteps = 0,
cVictim = victimAddr,
cFreeSteps = 1,
cDst = freeAddr,
cPromote = isLastHorizontal side freeAddr
}
else Nothing
else Nothing
_ -> Nothing
-- This is a most popular implementation, which fits most rules
-- except for english / checkers.
kingCaptures1 rules (CaptureState {..}) =
concatMap check $ filter allowedDir (gKingCaptureDirections rules)
where
side = pieceSide ctPiece
allowedDir dir =
case ctPrevDirection of
Nothing -> True
Just prevDir -> oppositeDirection prevDir /= dir
check dir =
case search dir ctCurrent of
Nothing -> []
Just (victimAddr, initSteps) ->
case freeFields rules side dir victimAddr ctBoard of
(0,_) -> []
(nFree, fields) ->
[mkCapture dir initSteps victimAddr freeSteps (fields !! (freeSteps-1)) | freeSteps <- [1 .. nFree]]
mkCapture dir init victim free dst =
Capture {
cSrc = ctCurrent,
cDirection = dir,
cInitSteps = init,
cVictim = victim,
cFreeSteps = free,
cDst = dst,
cPromote = False
}
search :: PlayerDirection -> Address -> Maybe (Address, Int)
search dir a =
case myNeighbour rules side dir a of
Nothing -> Nothing
Just a' -> case getPiece a' ctBoard of
Nothing -> case search dir a' of
Nothing -> Nothing
Just (victimAddr, steps) -> Just (victimAddr, steps + 1)
Just p -> if isOpponentPiece side p && not (aLabel a' `labelSetMember` ctCaptured)
then Just (a', 0)
else Nothing
-- This is most popular implementation, which fits most rules
-- except for english / checkers
kingCaptures rules ct@(CaptureState {..}) =
let side = pieceSide ctPiece
captures = gPieceCaptures1 rules ct
grouped = groupBy (\c1 c2 -> cDirection c1 == cDirection c2) $ sortOn cDirection captures
capturesByDirection = [(cDirection (head cs), cs) | cs <- grouped]
nextMoves pm = genericNextMoves rules ct False pm
in nub $ concat $ flip map capturesByDirection $ \(dir, captures) ->
let moves1 c = translateCapture ctPiece c
allNext c = map nextMoves (moves1 c)
isLast c = all null (allNext c)
in if all isLast captures
then concatMap moves1 captures
else [catPMoves move1 move2 | c <- captures, move1 <- moves1 c, move2 <- nextMoves move1]
-- This is most popular implementation, which fits most rules
-- except for english / checkers
kingSimpleMoves rules side board src =
concatMap check (gKingSimpleMoveDirections rules)
where
check dir =
let (nFree,free) = freeFields rules side dir src board
piece = Piece King side
in [PossibleMove {
pmBegin = src,
pmEnd = free !! (n-1),
pmVictims = [],
pmMove = Move src (replicate n (Step dir False False)),
pmPromote = False,
pmResult = [Take src, Put (free !! (n-1)) piece]
} | n <- [1..nFree]]
canCaptureFrom rules ct@(CaptureState {ctPiece = Piece Man side}) =
not $ null (gManCaptures1 rules ct)
canCaptureFrom rules ct@(CaptureState {ctPiece = Piece King side}) =
not $ null (gKingCaptures1 rules ct)
manSimpleMoveDirections rules = [ForwardLeft, ForwardRight]
orientation rules = FirstAtBottom
rules this = GenericRules {
gPossibleMoves = possibleMoves this
, gMobilityScore = mobility this
, gPossibleSimpleMoves1 = possibleSimpleMoves1 this
, gPossibleCaptures1 = possibleCaptures1 this
, gManSimpleMoves = manSimpleMoves this
, gKingSimpleMoves = kingSimpleMoves this
, gKingCaptures1 = kingCaptures1 this
, gKingCaptures = kingCaptures this
, gPieceCaptures1 = pieceCaptures1 this
, gPieceCaptures = pieceCaptures this
, gManCaptures1 = manCaptures1 this
, gManCaptures = error "gManCaptures has to be implemented in specific rules"
, gCanCaptureFrom = canCaptureFrom this
, gManSimpleMoveDirections = manSimpleMoveDirections this
, gKingSimpleMoveDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight]
, gManCaptureDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight]
, gKingCaptureDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight]
, gBoardOrientation = orientation this
, gCaptureMax = False
}
in rules