diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,6 +19,10 @@ HCheckers does not contain any pre-populated openings or endgames database, and it actually does not know how to play checkers - it only knows the rules. +But this is not either a "look-what-i-did-in-one-evening" project. HCheckers +has full support of several rules, has decent UI, supports UI localization, and +plays not so bad for amateur. + ## Project goals * Fun of development. For not-so-seasoned Haskell programmers, or people who are @@ -42,6 +46,8 @@ * International draughts (10x10) * Brazilian (rules of international draughts on 8x8 board) * Canadian draughts (12x12) +* Turkish draughts (orthogonal) +* Armenian draughts (Tama) It is possible to implement different AI algorithms; currently there is only one, based on standard alpha-beta pruning. The algorithm has some number of @@ -52,14 +58,13 @@ ## Current state -At the moment, HCheckers has most of core functionality implemented. +At the moment, HCheckers has most of core functionality implemented, but there +are some outstanding issues (please refer to github's issue tracker). Most wanted planned things to do are: * User documentation (#22) * Code documentation (#1) * Spectators support (#9) -* Distributed computing support (#17) -* Packaging (#23, #24) ## Installation @@ -69,9 +74,10 @@ ### Ubuntu package -I will put ubuntu package under github's releases once I'm sure it is working. +Last package that I released is available in github releases. Please refer to +https://github.com/portnov/hcheckers/releases . -To build the package, +To build a newer package, ``` $ git clone https://github.com/portnov/hcheckers.git @@ -106,15 +112,18 @@ $ sudo pip3 install . ``` -2) Using debian package (on debian-based systems). To build a debian package, execute +2) Using debian package (on debian-based systems). +Last package that I released is available in github releases. Please refer to +https://github.com/portnov/hcheckers/releases . + +To build a newer package, execute + ``` $ sudo apt-get install python3-stdeb $ cd hcheckers/python/ $ ./build_deb.sh ``` - -I will put debian package into github's releases once I'm sure it is correctly working. To install a package, do diff --git a/hcheckers.cabal b/hcheckers.cabal --- a/hcheckers.cabal +++ b/hcheckers.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: d512e48c2cc22041414eaea25593830ebf236845a10392a60a9a09b8b784f68d +-- hash: 635560919d6a9de9e4c5b6a6b7f636cc443c21aa7be4d1d72d363288b4404426 name: hcheckers -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Implementation of checkers ("draughts") board game - server application description: Please see the README on GitHub at category: Games @@ -35,10 +35,12 @@ executable hcheckersd main-is: Main.hs other-modules: + AI AI.AlphaBeta AI.AlphaBeta.Cache AI.AlphaBeta.Persistent AI.AlphaBeta.Types + Battle Core.Board Core.BoardMap Core.Checkers @@ -58,8 +60,10 @@ Formats.Pdn Formats.Types Learn + Rules.Armenian Rules.Brazilian Rules.Canadian + Rules.Czech Rules.Diagonal Rules.English Rules.Generic @@ -67,6 +71,7 @@ Rules.Russian Rules.Simple Rules.Spancirety + Rules.Turkish Paths_hcheckers hs-source-dirs: src @@ -99,10 +104,12 @@ , monad-metrics , mtl , mwc-random + , network , optparse-applicative , psqueues , random , random-access-file + , random-shuffle , scotty , stm , stm-containers @@ -113,6 +120,9 @@ , unix , unix-bytestring , unordered-containers + , vector + , wai + , warp , yaml if flag(verbose) cpp-options: -DVERBOSE diff --git a/src/AI.hs b/src/AI.hs new file mode 100644 --- /dev/null +++ b/src/AI.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +module AI where + +import Data.Maybe +import Data.Default +import Data.Aeson + +import Core.Types +import Core.Board +import Core.Logging +import Core.Supervisor +import Core.Evaluator +import AI.AlphaBeta.Types + +loadAi :: (GameRules rules) => String -> rules -> FilePath -> IO (AlphaBeta rules (EvaluatorForRules rules)) +loadAi name rules path = do + r <- decodeFileStrict path + case r of + Nothing -> fail $ "Cannot load AI from " ++ path + Just value -> do + let rules' = SomeRules rules + ai = AlphaBeta def rules (dfltEvaluator rules) + return $ updateAi ai value + diff --git a/src/AI/AlphaBeta.hs b/src/AI/AlphaBeta.hs --- a/src/AI/AlphaBeta.hs +++ b/src/AI/AlphaBeta.hs @@ -12,17 +12,20 @@ -} module AI.AlphaBeta - ( runAI, scoreMove + ( runAI, scoreMove, scoreMoveGroup ) where import Control.Monad import Control.Monad.State +import Control.Monad.Reader import Control.Monad.Except import Control.Concurrent.STM import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as H import Data.Maybe import Data.Default -import Data.List (sortOn) +import Data.List (sortOn, transpose) import Data.Text.Format.Heavy import Data.Aeson import System.Log.Heavy @@ -31,12 +34,26 @@ import Core.Types import Core.Board +import Core.BoardMap (labelSetMember) +import Core.Game import Core.Parallel import Core.Logging import qualified Core.Monitoring as Monitoring import AI.AlphaBeta.Types import AI.AlphaBeta.Cache +chunksOf :: Int -> [a] -> [[a]] +chunksOf n list + | length list <= n = [list] + | otherwise = + let (first, other) = splitAt n list + in first : chunksOf n other + +concatE :: [Int] -> [Either e [a]] -> [Either e a] +concatE _ [] = [] +concatE (n : ns) (Left e : rest) = replicate n (Left e) ++ concatE ns rest +concatE (n : ns) (Right xs : rest) = map Right xs ++ concatE ns rest + instance FromJSON AlphaBetaParams where parseJSON = withObject "AlphaBetaParams" $ \v -> AlphaBetaParams <$> v .: "depth" @@ -47,19 +64,44 @@ <*> v .:? "moves_bound_low" .!= 4 <*> v .:? "moves_bound_high" .!= 8 <*> v .:? "time" + <*> v .:? "random_opening_depth" .!= abRandomOpeningDepth def + <*> v .:? "random_opening_options" .!= abRandomOpeningOptions def +instance ToJSON AlphaBetaParams where + toJSON p = object [ + "depth" .= abDepth p, + "start_depth" .= abStartDepth p, + "max_combination_depth" .= abCombinationDepth p, + "dynamic_depth" .= abDynamicDepth p, + "deeper_if_bad" .= abDeeperIfBad p, + "moves_bound_low" .= abMovesLowBound p, + "moves_bound_high" .= abMovesHighBound p, + "time" .= abBaseTime p, + "random_opening_depth" .= abRandomOpeningDepth p, + "random_opening_options" .= abRandomOpeningOptions p + ] + +instance ToJSON eval => ToJSON (AlphaBeta rules eval) where + toJSON (AlphaBeta params rules eval) = + let Object paramsV = toJSON params + Object evalV = toJSON eval + in Object $ H.union paramsV evalV + instance (GameRules rules, Evaluator eval) => GameAi (AlphaBeta rules eval) where type AiStorage (AlphaBeta rules eval) = AICacheHandle rules eval createAiStorage ai = do - cache <- loadAiCache scoreMove ai + cache <- loadAiCache scoreMoveGroup ai return cache saveAiStorage (AlphaBeta params rules _) cache = do -- saveAiCache rules params cache return () + resetAiStorage ai cache = do + resetAiCache cache + chooseMove ai storage gameId side board = do (moves, _) <- runAI ai storage gameId side board -- liftIO $ atomically $ writeTVar (aichCurrentCounts storage) $ calcBoardCounts board @@ -67,13 +109,45 @@ updateAi ai@(AlphaBeta _ rules eval) json = case fromJSON json of - Error _ -> ai + Error e -> error $ "Can't load AI settings: " ++ show e Success params -> AlphaBeta params rules (updateEval eval json) aiName _ = "default" +instance (GameRules rules, VectorEvaluator eval) => VectorAi (AlphaBeta rules eval) where + type VectorAiSupport (AlphaBeta rules eval) r = (VectorEvaluatorSupport eval r, rules ~ r) + + aiToVector (AlphaBeta params rules eval) = aiVector V.++ evalVector + where + aiVector = V.fromList $ map fromIntegral $ [ + abDepth params + , abCombinationDepth params + , abDynamicDepth params + ] + + evalVector = evalToVector eval + + aiFromVector rules v = AlphaBeta params rules eval + where + params = AlphaBetaParams { + abDepth = round (v V.! 0) + , abStartDepth = Nothing + , abCombinationDepth = round (v V.! 1) + , abDynamicDepth = round (v V.! 2) + , abDeeperIfBad = False + , abMovesLowBound = abMovesLowBound def + , abMovesHighBound = abMovesHighBound def + , abBaseTime = Nothing + , abRandomOpeningDepth = 1 + , abRandomOpeningOptions = 1 + } + + v' = V.drop 3 v + + eval = evalFromVector rules v' + -- | Calculate score of one possible move. -scoreMove :: (GameRules rules, Evaluator eval) => ScoreMoveInput rules eval -> Checkers (PossibleMove, Score) +scoreMove :: (GameRules rules, Evaluator eval) => ScoreMoveInput rules eval -> Checkers MoveAndScore scoreMove (ScoreMoveInput {..}) = do let AlphaBeta params rules eval = smiAi score <- Monitoring.timed "ai.score.move" $ do @@ -83,11 +157,36 @@ $info "doScore: move {}, depth {}: {}" (show smiMove, dpTarget smiDepth, show e) throwError e ) - $info "Check: {} (depth {}) => {}" (show smiMove, dpTarget smiDepth, show score) + $info "Check: {} ([{} - {}], depth {}) => {}" (show smiMove, show smiAlpha, show smiBeta, dpTarget smiDepth, show score) return score - return (smiMove, score) + return $ MoveAndScore smiMove score +scoreMoveGroup :: (GameRules rules, Evaluator eval) => [ScoreMoveInput rules eval] -> Checkers [MoveAndScore] +scoreMoveGroup inputs = go worst [] inputs + where + input0 = head inputs + side = smiSide input0 + alpha = smiAlpha input0 + beta = smiBeta input0 + maximize = side == First + minimize = not maximize + worst = if maximize then alpha else beta + + go _ acc [] = return acc + go best acc (input : rest) = do + let input' + | maximize = input {smiAlpha = prevScore best} + | otherwise = input {smiBeta = nextScore best} + + result@(MoveAndScore move score) <- scoreMove input' + let best' + | maximize && score > best = score + | minimize && score < best = score + | otherwise = best + + go best' (acc ++ [result]) rest + rememberScoreShift :: AICacheHandle rules eval -> GameId -> ScoreBase -> Checkers () rememberScoreShift handle gameId shift = liftIO $ atomically $ do shifts <- readTVar (aichLastMoveScoreShift handle) @@ -129,6 +228,121 @@ -- else Monitoring.increment "ai.possible_moves.miss" -- return result +class Monad m => EvalMoveMonad m where + checkPrimeVariation :: (GameRules rules, Evaluator eval) => AICacheHandle rules eval -> AlphaBetaParams -> Board -> DepthParams -> m (Maybe PerBoardData) + getKillerMove :: Int -> m (Maybe MoveAndScore) + +instance EvalMoveMonad Checkers where + checkPrimeVariation var params board dp = do + lookupAiCache params board dp var + + getKillerMove _ = return Nothing + +-- ScoreM instance +instance EvalMoveMonad (StateT (ScoreState rules eval) Checkers) where + checkPrimeVariation var params board dp = do + lift $ lookupAiCache params board dp var + + getKillerMove = getGoodMove + +evalMove :: (EvalMoveMonad m, GameRules rules, Evaluator eval) + => AlphaBetaParams + -> AICacheHandle rules eval + -> Side + -> DepthParams + -> Board + -> Maybe PossibleMove + -> LabelSet + -> PossibleMove -> m Int +evalMove params var side dp board mbPrevMove attacked move = do + prime <- checkPrimeVariation var params board dp + let victimFields = pmVictims move + -- nVictims = sum $ map victimWeight victimFields + promotion = if isPromotion move then 1 else 0 + attackPrevPiece = case mbPrevMove of + Nothing -> 0 + Just prevMove -> if pmEnd prevMove `elem` victimFields + then 5 + else 0 + + maximize = side == First + minimize = not maximize + + victimWeight a = case getPiece a board of + Nothing -> 0 + Just (Piece Man _) -> 1 + Just (Piece King _) -> 3 + + isAttackPrevPiece = case mbPrevMove of + Nothing -> False + Just prevMove -> pmEnd prevMove `elem` victimFields + + isAttackKing = any isKing victimFields + + isKing a = case getPiece a board of + Just (Piece King _) -> True + _ -> False + + attackedPiece = let begin = aLabel $ pmBegin move + in if begin `labelSetMember` attacked + then getPiece' begin board + else Nothing + + case prime of + Nothing -> if isCapture move + then if isAttackPrevPiece + then return $ 20 + 3*promotion + else if isAttackKing + then return $ 10 + 3*promotion + else return $ 5*promotion + 3*pmVictimsCount move + else case attackedPiece of + Nothing -> return promotion + Just (Piece King _) -> return 20 + Just (Piece Man _) -> return 10 + Just primeData -> do + let score = scoreValue $ itemScore primeData + signedScore = if maximize then score else -score + return $ fromIntegral signedScore + +sortMoves :: (EvalMoveMonad m, GameRules rules, Evaluator eval) + => AlphaBetaParams + -> AICacheHandle rules eval + -> Side + -> DepthParams + -> Board + -> Maybe PossibleMove + -> [PossibleMove] + -> m [PossibleMove] +sortMoves params var side dp board mbPrevMove moves = do +-- if length moves >= 4 +-- then do + let rules = aichRules var + attacked = boardAttacked side board + interest <- mapM (evalMove params var side dp board mbPrevMove attacked) moves + if any (/= 0) interest + then return $ map fst $ sortOn (negate . snd) $ zip moves interest + else return moves +-- else return moves + +rememberGoodMove :: Int -> Side -> PossibleMove -> Score -> ScoreM rules eval () +rememberGoodMove depth side move score = do + goodMoves <- gets ssBestMoves + let goodMoves' = case M.lookup depth goodMoves of + Nothing -> M.insert depth (MoveAndScore move score) goodMoves + Just (MoveAndScore _ prevScore) + | (maximize && score > prevScore) || (minimize && score < prevScore) + -> M.insert depth (MoveAndScore move score) goodMoves + | otherwise -> goodMoves + maximize = side == First + minimize = not maximize + modify $ \st -> st {ssBestMoves = goodMoves'} + +getGoodMove :: Int -> ScoreM rules eval (Maybe MoveAndScore) +getGoodMove depth = do + goodMoves <- gets ssBestMoves + return $ M.lookup depth goodMoves + + -- | General driver / controller for Alpha-Beta prunning algorithm. -- This method is responsible in running scoreAB method on all possible moves -- and selecting the best move. @@ -185,8 +399,7 @@ -> Board -> Checkers AiOutput runAI ai@(AlphaBeta params rules eval) handle gameId side board = do - preOptions <- preselect - options <- depthDriver preOptions + options <- depthDriver =<< getPossibleMoves handle side board output <- select options let bestScore = sNumeric $ snd output let shift = bestScore - sNumeric score0 @@ -200,75 +413,133 @@ | maximize = s1 > s2 | otherwise = s1 < s2 - worseThan s1 s2 = not (betterThan s1 s2) - - preselect = - getPossibleMoves handle side board + worseThan s1 s2 + | maximize = s1 < s2 + | otherwise = s1 > s2 --- preselect :: Checkers [PossibleMove] -- preselect = do -- moves <- getPossibleMoves handle side board --- if length moves <= abMovesHighBound params --- then return moves --- else do --- let simple = DepthParams { --- dpTarget = 2 --- , dpCurrent = -1 --- , dpMax = 4 --- , dpMin = 2 --- , dpForcedMode = False --- } --- $info "Preselecting; number of possible moves = {}, depth = {}" (length moves, dpTarget simple) --- options <- scoreMoves' moves simple (loose, win) --- let key = if maximize --- then negate . snd --- else snd --- let sorted = sortOn key options --- bestOptions = take (abMovesHighBound params) sorted --- let result = map fst sorted --- $debug "Pre-selected options: {}" (Single $ show result) --- return result +-- let simple = DepthParams { +-- dpInitialTarget = 2 +-- , dpTarget = 2 +-- , dpCurrent = -1 +-- , dpMax = 4 +-- , dpMin = 2 +-- , dpForcedMode = False +-- , dpStaticMode = False +-- } +-- result <- sortMoves params handle side simple board Nothing moves +-- $debug "Pre-selected options: {}" (Single $ show result) +-- return result + preselect :: Depth -> [PossibleMove] -> Checkers [Score] + preselect depth moves = do + let simple = DepthParams { + dpInitialTarget = depth + , dpTarget = depth + , dpCurrent = -1 + , dpMax = 6 + , dpMin = depth + , dpForcedMode = False + , dpStaticMode = False + , dpReductedMode = False + } + $info "Preselecting; number of possible moves = {}, depth = {}" (length moves, dpTarget simple) + options <- scoreMoves' False moves simple (loose, win) + let key = if maximize + then negate . rScore + else rScore + return $ map key options +-- let sorted = sortOn key options +-- bestOptions = take (abMovesHighBound params) sorted +-- let result = map fst sorted +-- $debug "Pre-selected options: {}" (Single $ show result) +-- return result + + depthStep :: Depth + depthStep = 5 + depthDriver :: [PossibleMove] -> Checkers DepthIterationOutput depthDriver moves = case abBaseTime params of - Nothing -> do - (result, _) <- go (params, moves, Nothing) - return result - Just time -> repeatTimed' "runAI" time goTimed (params, moves, Nothing) + Nothing -> do + let target = abDepth params + preselectDepth = + if target <= depthStep + then target + else let m = target `mod` depthStep + in head $ filter (>= 2) [m + depthStep, m + depthStep + depthStep .. target] + startDepth = case abStartDepth params of + Nothing -> Nothing + Just start -> Just $ max 2 $ preselectDepth + start - target + input = DepthIterationInput { + diiParams = params {abDepth = preselectDepth, abStartDepth = startDepth}, + diiMoves = moves, + diiPrevResult = Nothing, + diiSortKeys = Nothing + } + goIterative target input + Just time -> do + let input = DepthIterationInput { + diiParams = params, + diiMoves = moves, + diiPrevResult = Nothing, + diiSortKeys = Nothing + } + repeatTimed' "runAI" time goTimed input + goTimed :: DepthIterationInput -> Checkers (DepthIterationOutput, Maybe DepthIterationInput) - goTimed (params, moves, prevResult) = do - ret <- tryC $ go (params, moves, prevResult) + goTimed input = do + ret <- tryC $ go input case ret of Right result -> return result Left TimeExhaused -> - case prevResult of + case diiPrevResult input of Just result -> return (result, Nothing) - Nothing -> return ([(move, 0) | move <- moves], Nothing) + Nothing -> return ([MoveAndScore move 0 | move <- diiMoves input], Nothing) Left err -> throwError err + goIterative :: Depth -> DepthIterationInput -> Checkers DepthIterationOutput + goIterative target input = do + (output, mbNextInput) <- go input + case mbNextInput of + Nothing -> do + let bad (MoveAndScore _ score) = (maximize && score <= score0 - 1) || (minimize && score >= score0 + 1) + if abDeeperIfBad params && all bad output + then do + let nextInput = deeper (abDepth $ diiParams input) 1 output input + $info "All moves seem bad, re-think one step further" () + (output', _) <- go nextInput + return output' + else return output + Just nextInput -> + if abDepth (diiParams nextInput) <= target + then goIterative target nextInput + else return output + go :: DepthIterationInput -> Checkers (DepthIterationOutput, Maybe DepthIterationInput) - go (params, moves, prevResult) = do - let depth = abDepth params - if length moves <= 1 -- Just one move possible + go input@(DepthIterationInput {..}) = do + let depth = abDepth diiParams + if length diiMoves <= 1 -- Just one move possible then do $info "There is only one move possible; just do it." () - return ([(move, score0) | move <- moves], Nothing) + return ([MoveAndScore move score0 | move <- diiMoves], Nothing) else do let var = aichData handle - $info "Selecting a move. Side = {}, depth = {}, number of possible moves = {}" (show side, depth, length moves) - dp <- updateDepth params moves $ DepthParams { + $info "Selecting a move. Side = {}, depth = {}, number of possible moves = {}" (show side, depth, length diiMoves) + dp <- updateDepth params diiMoves $ DepthParams { dpInitialTarget = depth , dpTarget = depth , dpCurrent = -1 - , dpMax = abCombinationDepth params + depth - , dpMin = fromMaybe depth (abStartDepth params) + , dpMax = abCombinationDepth diiParams + depth + , dpMin = min depth $ fromMaybe depth (abStartDepth diiParams) , dpStaticMode = False , dpForcedMode = False + , dpReductedMode = False } let needDeeper = abDeeperIfBad params && score0 `worseThan` 0 let dp' @@ -276,25 +547,49 @@ dpTarget = min (dpMax dp) (dpTarget dp + 1) } | otherwise = dp - result <- widthController True True prevResult moves dp' =<< initInterval + + sortedMoves <- + case diiSortKeys of + Nothing -> return diiMoves + Just keys -> do + let moves' = map snd $ sortOn fst $ zip keys diiMoves + $debug "Sort moves: {} => {}" (show $ zip keys diiMoves, show moves') + return moves' + + result <- widthController True True diiPrevResult sortedMoves dp' =<< mkInitInterval depth (isQuiescene diiMoves) + $debug "Depth iteration result: {}" (Single $ show result) -- In some corner cases, there might be 1 or 2 possible moves, -- so the timeout would allow us to calculate with very big depth; -- too big depth does not decide anything in such situations. if depth < 50 then do - let params' = params {abDepth = depth + 1, abStartDepth = Nothing} - return (result, Just (params', moves, Just result)) + let input' = deeper depth depthStep result input + return (result, Just input') else return (result, Nothing) + deeper :: Depth -> Depth -> DepthIterationOutput -> DepthIterationInput -> DepthIterationInput + deeper depth step prevOutput input = + let start' = fmap (+step) (abStartDepth params) + params' = params {abDepth = depth + step, abStartDepth = start'} + keys = map rScore prevOutput + moves' = map rMove prevOutput + signedKeys = if maximize then map negate keys else keys + in input { + diiParams = params', + diiPrevResult = Just prevOutput, + diiMoves = moves', + diiSortKeys = Just signedKeys + } + score0 = evalBoard eval First board -- | Initial (alpha, beta) interval - initInterval :: Checkers (Score, Score) - initInterval = do - let delta = 1 --- | abs score0 < 4 = 1 --- | abs score0 < 8 = 2 --- | otherwise = 4 + mkInitInterval :: Depth -> Bool -> Checkers (Score, Score) + mkInitInterval depth quiescene = do + let delta + | depth < abDepth params = fromIntegral $ max 1 $ abDepth params - depth + | not quiescene = Score 1 500 + | otherwise = Score 0 600 mbPrevShift <- getLastScoreShift handle gameId case mbPrevShift of Nothing -> do @@ -317,25 +612,30 @@ | s > 100 = 5 | otherwise = 2 + scale :: ScoreBase -> Score -> Score + scale k s + | sNumeric s < 1 = Score 1 (sPositional s) + | otherwise = k `scaleScore` s + nextInterval :: (Score, Score) -> (Score, Score) nextInterval (alpha, beta) = let width = (beta - alpha) - width' = selectScale width `scaleScore` width + width' = selectScale width `scale` width alpha' = prevScore alpha beta' = nextScore beta in if maximize - then (beta', max beta' (beta' + width')) - else (min alpha' (alpha' - width'), alpha') + then (alpha, max beta' (beta' + width')) + else (min alpha' (alpha' - width'), beta) prevInterval :: (Score, Score) -> (Score, Score) prevInterval (alpha, beta) = let width = (beta - alpha) - width' = selectScale width `scaleScore` width + width' = selectScale width `scale` width alpha' = prevScore alpha beta' = nextScore beta in if minimize - then (beta', max beta' (beta' + width')) - else (min alpha' (alpha' - width'), alpha') + then (alpha, max beta' (beta' + width')) + else (min alpha' (alpha' - width'), beta) widthController :: Bool -- ^ Allow to shift (alpha,beta) segment to bigger values? -> Bool -- ^ Allow to shift (alpha,beta) segment to lesser values? @@ -348,21 +648,26 @@ if alpha == beta then do $info "Empty scores interval: [{}]. We have to think that all moves have this score." (Single alpha) - return [(move, alpha) | move <- moves] + return [MoveAndScore move alpha | move <- moves] else do results <- widthIteration prevResult moves dp interval - let (good, badScore, badMoves) = selectBestEdge interval moves results - (bestMoves, bestResults) = unzip good + let (bestResults, badScore, badMoves) = selectBestEdge interval moves results + bestMoves = map rMove bestResults if length badMoves == length moves then if allowPrev - then do - let interval' = prevInterval interval - $info "All moves are `too bad'; consider worse scores interval: [{} - {}]" interval' - widthController False True prevResult badMoves dp interval' + then + if (maximize && alpha <= loose) || (minimize && beta >= win) + then do + $info "All moves are `too bad'; but there is no worse interval, return all what we have" () + return [MoveAndScore move badScore | move <- moves] + else do + let interval' = prevInterval interval + $info "All moves are `too bad'; consider worse scores interval: [{} - {}]" interval' + widthController False True prevResult badMoves dp interval' else do $info "All moves are `too bad' ({}), but we have already checked worse interval; so this is the real score." (Single badScore) - return [(move, badScore) | move <- moves] + return [MoveAndScore move badScore | move <- moves] else case bestResults of [] -> return results @@ -371,71 +676,107 @@ return bestResults _ -> if allowNext - then do - let interval'@(alpha',beta') = nextInterval interval - $info "Some moves ({} of them) are `too good'; consider better scores interval: [{} - {}]" (length bestMoves, alpha', beta') - widthController True False prevResult bestMoves dp interval' - else do - $info "Some moves ({} of them) are `too good'; but we have already checked better interval; so this is the real score" (Single $ length bestMoves) - return bestResults + then + if (maximize && beta >= win) || (minimize && alpha <= loose) + then do + $info "Some moves ({} of them) are `too good'; but there is no better interval, return all of them." (Single $ length bestMoves) + return bestResults + else do + let interval'@(alpha',beta') = nextInterval interval + $info "Some moves ({} of them) are `too good'; consider better scores interval: [{} - {}]" (length bestMoves, alpha', beta') + widthController True False prevResult bestMoves dp interval' + else do + $info "Some moves ({} of them) are `too good'; but we have already checked better interval; so this is the real score" (Single $ length bestMoves) + return bestResults - scoreMoves :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers [Either Error (PossibleMove, Score)] - scoreMoves moves dp (alpha, beta) = do + getJobIndicies :: Int -> Checkers [Int] + getJobIndicies count = liftIO $ atomically $ do + lastIndex <- readTVar (aichJobIndex handle) + let nextIndex = lastIndex + count + writeTVar (aichJobIndex handle) nextIndex + return [lastIndex+1 .. nextIndex] + + scoreMoves :: Bool -> [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers [Either Error MoveAndScore] + scoreMoves byOne moves dp (alpha, beta) = do + nThreads <- asks (aiThreads . gcAiConfig . csConfig) let var = aichData handle let processor = aichProcessor handle + n = length moves + indicies <- getJobIndicies n let inputs = [ ScoreMoveInput { smiAi = ai, smiCache = handle, smiGameId = gameId, smiSide = side, + smiIndex = index, smiDepth = dp, smiBoard = board, smiMove = move, smiAlpha = alpha, smiBeta = beta - } | move <- moves ] - process' processor inputs - - scoreMoves' :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers DepthIterationOutput - scoreMoves' moves dp (alpha, beta) = do - results <- scoreMoves moves dp (alpha, beta) + } | (move, index) <- zip moves indicies ] + + groups + | byOne = [[input] | input <- inputs] + | otherwise = transpose $ chunksOf nThreads inputs + + results <- process' processor groups + return $ concatE (map length groups) results + + scoreMoves' :: Bool -> [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers DepthIterationOutput + scoreMoves' byOne moves dp (alpha, beta) = do + results <- scoreMoves byOne moves dp (alpha, beta) case sequence results of Right result -> return result Left err -> throwError err widthIteration :: Maybe DepthIterationOutput -> [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers DepthIterationOutput widthIteration prevResult moves dp (alpha, beta) = do - $info "`- Considering scores interval: [{} - {}], depth = {}" (alpha, beta, dpTarget dp) - results <- scoreMoves moves dp (alpha, beta) + $info "`- Considering scores interval: [{} - {}], depth = {}, number of moves = {}" (alpha, beta, dpTarget dp, length moves) + results <- scoreMoves False moves dp (alpha, beta) joinResults prevResult results - joinResults :: Maybe DepthIterationOutput -> [Either Error (PossibleMove, Score)] -> Checkers DepthIterationOutput + joinResults :: Maybe DepthIterationOutput -> [Either Error MoveAndScore] -> Checkers DepthIterationOutput joinResults Nothing results = case sequence results of Right result -> return result Left err -> throwError err joinResults (Just prevResults) results = zipWithM joinResult prevResults results - joinResult :: (PossibleMove, Score) -> Either Error (PossibleMove, Score) -> Checkers (PossibleMove, Score) - joinResult prev@(move, score) (Left TimeExhaused) = do + joinResult :: MoveAndScore -> Either Error MoveAndScore -> Checkers MoveAndScore + joinResult prev@(MoveAndScore move score) (Left TimeExhaused) = do $info "Time exhaused while checking move {}, use result from previous depth: {}" (show move, score) return prev joinResult _ (Left err) = throwError err joinResult _ (Right result) = return result + selectBestEdge :: (Score, Score) -> [PossibleMove] -> [MoveAndScore] -> + ([MoveAndScore], Score, [PossibleMove]) selectBestEdge (alpha, beta) moves results = let (good, bad) = if maximize then (beta, alpha) else (alpha, beta) - goodResults = [(move, (goodMoves, score)) | (move, (goodMoves, score)) <- zip moves results, score == good] - badResults = [move | (move, (_, score)) <- zip moves results, score == bad] + goodResults = [result | result <- results, not (rScore result `worseThan` good)] + badResults = [rMove result | result <- results, not (rScore result `betterThan` bad)] in (goodResults, bad, badResults) select :: DepthIterationOutput -> Checkers AiOutput select pairs = do let best = if maximize then maximum else minimum - maxScore = best $ map snd pairs - goodMoves = [move | (move, score) <- pairs, score == maxScore] - return (goodMoves, maxScore) + maxScore = best $ map rScore pairs + game <- getGame gameId + let halfMoves = gameMoveNumber game + moveNumber = halfMoves `div` 2 + nOptions = if moveNumber <= abRandomOpeningDepth params + then abRandomOpeningOptions params + else 1 + if nOptions == 1 + then do + let goodMoves = [rMove result | result <- pairs, rScore result == maxScore] + return (goodMoves, maxScore) + else do + let srt = if maximize then sortOn (negate . rScore) else sortOn rScore + goodMoves = map rMove $ take nOptions $ srt pairs + return (goodMoves, maxScore) -- | Calculate score of the board doScore :: (GameRules rules, Evaluator eval) @@ -457,7 +798,7 @@ where input = ScoreInput side dp alpha beta board Nothing mkInitState = do - now <- liftIO $ getTime Monotonic + now <- liftIO $ getTime RealtimeCoarse let timeout = case abBaseTime params of Nothing -> Nothing Just sec -> Just $ TimeSpec (fromIntegral sec) 0 @@ -486,17 +827,17 @@ mbItem <- lift $ lookupAiCache params board dp var mbCached <- case mbItem of Just item -> do - let score = itemScore item + let cachedScore = itemScore item -- it is possible that this value was put to cache with different -- values of alpha/beta; but we have to maintain the property of -- AB-section: alpha <= result <= beta. So here we clamp the value -- that we got from cache. case itemBound item of - Exact -> return $ Just $ ScoreOutput (clamp alpha beta score) False - Alpha -> if score <= alpha + Exact -> return $ Just $ ScoreOutput (clamp alpha beta cachedScore) False + Alpha -> if cachedScore <= alpha then return $ Just $ ScoreOutput alpha False else return Nothing - Beta -> if score >= beta + Beta -> if cachedScore >= beta then return $ Just $ ScoreOutput beta False else return Nothing Nothing -> return Nothing @@ -512,9 +853,9 @@ -- we can only put the result to the cache if we know -- that this score was not clamped by alpha or beta -- (so this is a real score, not alpha/beta bound) - item = PerBoardData (dpLast dp) score bound Nothing - item' = PerBoardData (dpLast dp) (negate score) bound Nothing - when (bound == Exact && soQuiescene out) $ do + item = PerBoardData (dpLast dp) score bound + item' = PerBoardData (dpLast dp) (negate score) bound + when (bound == Exact && soQuiescene out && not (dpStaticMode dp)) $ do lift $ putAiCache params board item var lift $ putAiCache params (flipBoard board) item' var return out @@ -540,26 +881,36 @@ updateDepth :: (Monad m, HasLogging m, MonadIO m) => AlphaBetaParams -> [PossibleMove] -> DepthParams -> m DepthParams updateDepth params moves dp | deepen = do - let delta = nMoves - 1 + let delta = fromIntegral nMoves - 1 let target = min (dpTarget dp + 1) (dpMax dp - delta) - let indent = replicate (2*dpCurrent dp) ' ' + let indent = replicate (fromIntegral $ 2*dpCurrent dp) ' ' let static = dpCurrent dp > dpInitialTarget dp + abDynamicDepth params $verbose "{}| there is only one move, increase target depth to {}" (indent, target) - return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target, dpForcedMode = True, dpStaticMode = static} - | nMoves > abMovesHighBound params && isQuiescene moves = do - let target = max (dpCurrent dp + 1) (dpMin dp) - let indent = replicate (2*dpCurrent dp) ' ' + return $ dp { + dpCurrent = dpCurrent dp + 1, + dpTarget = target, + dpForcedMode = forced || dpForcedMode dp, + dpStaticMode = static + } + | nMoves > abMovesHighBound params && canRazor = do + let target = max (dpCurrent dp + 1) (dpInitialTarget dp) + let indent = replicate (fromIntegral $ 2*dpCurrent dp) ' ' $verbose "{}| there are too many moves, decrease target depth to {}" (indent, target) - return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target} + return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target, dpReductedMode = True} | otherwise = return $ dp {dpCurrent = dpCurrent dp + 1} where nMoves = length moves + forced = any isCapture moves || any isPromotion moves deepen = if dpCurrent dp <= dpInitialTarget dp then nMoves <= abMovesLowBound params - else any isCapture moves || any isPromotion moves + else forced + canRazor = isQuiescene moves && + dpForcedMode dp && + not (dpReductedMode dp) + isQuiescene :: [PossibleMove] -> Bool isQuiescene moves = not (any isCapture moves || any isPromotion moves) @@ -571,7 +922,7 @@ Nothing -> return False Just delta -> do start <- gets ssStartTime - now <- liftIO $ getTime Monotonic + now <- liftIO $ getTime RealtimeCoarse return $ start + delta <= now -- | Calculate score for the board. @@ -582,6 +933,11 @@ -> ScoreInput -> ScoreM rules eval ScoreOutput scoreAB var params input + | alpha == beta = do + $verbose "Alpha == Beta == {}, return it" (Single $ show alpha) + quiescene <- checkQuiescene + return $ ScoreOutput alpha quiescene + | isTargetDepth dp = do -- target depth is achieved, calculate score of current board directly evaluator <- gets ssEvaluator @@ -589,29 +945,52 @@ $verbose " X Side: {}, A = {}, B = {}, score0 = {}" (show side, show alpha, show beta, show score0) quiescene <- checkQuiescene return $ ScoreOutput score0 quiescene + | otherwise = do evaluator <- gets ssEvaluator - -- first, let "best" be the worse possible value - let best - | dpStaticMode dp = evalBoard' evaluator board - | maximize = alpha - | otherwise = beta - - push best - $verbose "{}V Side: {}, A = {}, B = {}" (indent, show side, show alpha, show beta) - rules <- gets ssRules - moves <- lift $ getPossibleMoves var side board + let score0 = evalBoard' evaluator board + futilePrunned <- checkFutility + case futilePrunned of + Just out@(ScoreOutput score0 quiescene) -> do + $verbose "Further search is futile, return current score0 = {}" (Single $ show score0) + return out + Nothing -> do + + moves <- lift $ getPossibleMoves var side board + let quiescene = isQuiescene moves + let worst + | maximize = alpha + | otherwise = beta - -- this actually means that corresponding side lost. - when (null moves) $ - $verbose "{}`—No moves left." (Single indent) + if null moves + -- this actually means that corresponding side lost. + then do + $verbose "{}`—No moves left." (Single indent) + return $ ScoreOutput worst True + else + if dpStaticMode dp && isQuiescene moves + -- In static mode, we are considering forced moves only. + -- If we have reached a quiescene, then that's all. + then do + $verbose "Reached quiescene in static mode; return current score0 = {}" (Single $ show score0) + return $ ScoreOutput score0 True + else do + -- first, let "best" be the worse possible value + let best + | dpStaticMode dp = evalBoard' evaluator board + | otherwise = worst - dp' <- updateDepth params moves dp - let prevMove = siPrevMove input - moves' <- sortMoves prevMove moves - out <- iterateMoves (zip [1..] moves') dp' - pop - return out + push best + $verbose "{}V Side: {}, A = {}, B = {}" (indent, show side, show alpha, show beta) + rules <- gets ssRules + dp' <- updateDepth params moves dp + let prevMove = siPrevMove input + moves' <- sortMoves params var side dp board prevMove moves +-- let depths = correspondingDepths (length moves') score0 quiescene dp' + let depths = repeat dp' + out <- iterateMoves $ zip3 [1..] moves' depths + pop + return out where @@ -621,13 +1000,53 @@ beta = siBeta input board = siBoard input + canReduceDepth :: Score -> Bool -> Bool + canReduceDepth score0 quiescene = + not (dpForcedMode dp) && + not (dpReductedMode dp) && + dpCurrent dp >= 4 && + quiescene && + score0 > alpha && + score0 < beta && + score0 > -10 && + score0 < 10 + + correspondingDepths :: Int -> Score -> Bool -> DepthParams -> [DepthParams] + correspondingDepths nMoves score0 quiescene depth = + if (nMoves <= abMovesHighBound params) || not (canReduceDepth score0 quiescene) + then replicate nMoves depth + else let reducedDepth = depth { + dpTarget = min (dpMin dp) (dpTarget depth), + dpReductedMode = True + } + in replicate (abMovesHighBound params) depth ++ repeat reducedDepth + + checkFutility :: ScoreM rules eval (Maybe ScoreOutput) + checkFutility = do + evaluator <- gets ssEvaluator + quiescene <- checkQuiescene + let score0 = evalBoard' evaluator board + best = if maximize then alpha else beta + isBad = if maximize + then score0 <= alpha + 1 + else score0 >= beta - 1 + + if (dpCurrent dp >= dpTarget dp - 1) && + not (dpForcedMode dp) && + quiescene && + score0 >= -10 && + score0 <= 10 && + isBad + then return $ Just $ ScoreOutput score0 quiescene + else return Nothing + evalBoard' :: eval -> Board -> Score evalBoard' evaluator board = result where score = evalBoard evaluator First board result - | maximize && sNumeric score == sNumeric win = score - Score 0 (fromIntegral $ dpCurrent dp) - | minimize && sNumeric score == sNumeric loose = score + Score 0 (fromIntegral $ dpCurrent dp) + | maximize && sNumeric score == sNumeric win = score - Score (fromIntegral $ dpCurrent dp) 0 + | minimize && sNumeric score == sNumeric loose = score + Score (fromIntegral $ dpCurrent dp) 0 | otherwise = score checkQuiescene :: ScoreM rules eval Bool @@ -644,46 +1063,6 @@ pop = modify $ \st -> st {ssBestScores = tail (ssBestScores st)} - evalMove :: Maybe PossibleMove -> PossibleMove -> ScoreM rules eval Int - evalMove mbPrevMove move = do - let victims = pmVictims move - nVictims = length victims - promotion = if isPromotion move then 1 else 0 - attackPrevPiece = case mbPrevMove of - Nothing -> 0 - Just prevMove -> if pmEnd prevMove `elem` victims - then 2 - else 0 - - let board' = applyMoveActions (pmResult move) board - let dp0 = dp {dpCurrent = dpTarget dp} - mbCached <- lift $ lookupAiCache params board' dp0 var - let primeVariation = case mbCached of - Nothing -> 0 - Just item -> - let score = sNumeric (itemScore item) - scoreSigned = if maximize then score else negate score - in fromIntegral $ 1 + scoreSigned - - goodCheck <- getGoodMove (dpCurrent dp) - let good = case goodCheck of - Nothing -> 0 - Just (goodMove, goodScore) - | goodMove == move -> if maximize then sNumeric goodScore else negate (sNumeric goodScore) - | otherwise -> 0 - - return $ nVictims + promotion + attackPrevPiece + primeVariation + fromIntegral good - - sortMoves :: Maybe PossibleMove -> [PossibleMove] -> ScoreM rules eval [PossibleMove] - sortMoves mbPrevMove moves = - if length moves >= 4 - then do - interest <- mapM (evalMove mbPrevMove) moves - if any (> 0) interest - then return $ map fst $ sortOn (negate . snd) $ zip moves interest - else return moves - else return moves - distance :: PossibleMove -> PossibleMove -> Line distance prev pm = let Label col row = aLabel (pmEnd prev) @@ -698,7 +1077,7 @@ then "Maximum" else "Minimum" - indent = replicate (2*dpCurrent dp) ' ' + indent = replicate (fromIntegral $ 2*dpCurrent dp) ' ' getBest = gets (head . ssBestScores) @@ -709,22 +1088,6 @@ $verbose "{}| {} for depth {} : {} => {}" (indent, bestStr, dpCurrent dp, show oldBest, show best) modify $ \st -> st {ssBestScores = best : tail (ssBestScores st)} - rememberGoodMove :: Int -> PossibleMove -> Score -> ScoreM rules eval () - rememberGoodMove depth move score = do - goodMoves <- gets ssBestMoves - let goodMoves' = case M.lookup depth goodMoves of - Nothing -> M.insert depth (move, score) goodMoves - Just (_, prevScore) - | (maximize && score > prevScore) || (minimize && score < prevScore) - -> M.insert depth (move, score) goodMoves - | otherwise -> goodMoves - modify $ \st -> st {ssBestMoves = goodMoves'} - - getGoodMove :: Int -> ScoreM rules eval (Maybe (PossibleMove, Score)) - getGoodMove depth = do - goodMoves <- gets ssBestMoves - return $ M.lookup depth goodMoves - opponentMoves :: ScoreM rules eval [PossibleMove] opponentMoves = do rules <- gets ssRules @@ -735,22 +1098,25 @@ let victims = concatMap pmVictims opMoves return $ {- pmBegin move `elem` victims || -} length (pmVictims move) >= 2 || isPromotion move - mkIntervals (alpha, beta) = - let mid = (alpha + beta) `divideScore` 2 - in if maximize - then [(alpha, prevScore mid), (mid, beta)] - else [(mid, beta), (alpha, nextScore mid)] + mkIntervals zero (alpha, beta) + | maximize = + let mid = min (alpha + zero) beta + in [(alpha, mid), (alpha, beta)] + | otherwise = + let mid = max (beta - zero) alpha + in [(mid, beta), (alpha, beta)] - checkMove :: AICacheHandle rules eval -> AlphaBetaParams -> ScoreInput -> PossibleMove -> ScoreM rules eval ScoreOutput - checkMove var params input move = do + checkMove :: AICacheHandle rules eval -> AlphaBetaParams -> ScoreInput -> Int -> ScoreM rules eval ScoreOutput + checkMove var params input i = do let alpha = siAlpha input beta = siBeta input width = beta - alpha + zeroWidth = Score 0 300 intervals <- do - interesting <- isInteresting move - if interesting || width <= 2 + let interesting = i <= 1 + if interesting || width <= zeroWidth then return [(alpha, beta)] - else return $ mkIntervals (alpha, beta) + else return $ mkIntervals zeroWidth (alpha, beta) let inputs = [input {siAlpha = alpha, siBeta = beta} | (alpha, beta) <- intervals] go inputs where @@ -763,13 +1129,13 @@ else return out - iterateMoves :: [(Int,PossibleMove)] -> DepthParams -> ScoreM rules eval ScoreOutput - iterateMoves [] _ = do + iterateMoves :: [(Int,PossibleMove, DepthParams)] -> ScoreM rules eval ScoreOutput + iterateMoves [] = do best <- getBest $verbose "{}`—All moves considered at this level, return best = {}" (indent, show best) quiescene <- checkQuiescene return $ ScoreOutput best quiescene - iterateMoves ((i,move) : moves) dp = do + iterateMoves ((i,move, dp) : moves) = do timeout <- isTimeExhaused when timeout $ do -- $info "Timeout exhaused for depth {}." (Single $ dpCurrent dp) @@ -787,7 +1153,7 @@ then beta else min beta best , siPrevMove = Just move - , siBoard = applyMoveActions (pmResult move) board + , siBoard = markAttacked rules $ applyMoveActions (pmResult move) board , siDepth = dp } out <- cachedScoreAB var params input' @@ -799,15 +1165,15 @@ setBest score if (maximize && score >= beta) || (minimize && score <= alpha) then do - rememberGoodMove (dpCurrent dp) move score + -- rememberGoodMove (dpCurrent dp) side move score Monitoring.distribution "ai.section.at" $ fromIntegral i $verbose "{}`—Return {} for depth {} = {}" (indent, bestStr, dpCurrent dp, show score) quiescene <- checkQuiescene return $ ScoreOutput score quiescene - else iterateMoves moves dp + else iterateMoves moves else do - iterateMoves moves dp + iterateMoves moves instance (Evaluator eval, GameRules rules) => Evaluator (AlphaBeta rules eval) where evaluatorName (AlphaBeta _ _ eval) = evaluatorName eval diff --git a/src/AI/AlphaBeta/Cache.hs b/src/AI/AlphaBeta/Cache.hs --- a/src/AI/AlphaBeta/Cache.hs +++ b/src/AI/AlphaBeta/Cache.hs @@ -10,6 +10,7 @@ ( loadAiCache, lookupAiCache, putAiCache, + resetAiCache ) where import Control.Monad @@ -44,11 +45,11 @@ -- | Prepare AI storage instance. -- This also contains Processor instance with several threads. loadAiCache :: (GameRules rules, Evaluator eval) - => (ScoreMoveInput rules eval -> Checkers (PossibleMove, Score)) + => ([ScoreMoveInput rules eval] -> Checkers [MoveAndScore]) -> AlphaBeta rules eval -> Checkers (AICacheHandle rules eval) loadAiCache scoreMove (AlphaBeta params rules eval) = do - let getKey input = pmResult (smiMove input) + let getKey inputs = map smiIndex inputs aiCfg <- asks (gcAiConfig . csConfig) processor <- runProcessor (aiThreads aiCfg) getKey scoreMove cache <- liftIO newTBoardMap @@ -106,9 +107,11 @@ counts <- liftIO $ atomically $ newTVar $ BoardCounts 50 50 50 50 moves <- liftIO newTBoardMap scoreShift <- liftIO $ atomically $ newTVar M.empty + index <- liftIO $ atomically $ newTVar 0 let handle = AICacheHandle { aichRules = rules, aichData = cache, + aichJobIndex = index, aichProcessor = processor, aichPossibleMoves = moves, aichLastMoveScoreShift = scoreShift, @@ -171,10 +174,8 @@ Monitoring.increment "cache.miss" return Nothing Just file -> do - let mbStats = checkStats =<< boardStats file - let file' = file {boardStats = mbStats} - putAiCache params board file' handle - return $ Just file' + putAiCache params board file handle + return $ Just file where @@ -203,15 +204,19 @@ lookupFile' :: Board -> DepthParams -> Checkers (Maybe PerBoardData) lookupFile' board depth = do - let bc = calcBoardCounts board - let total = bcFirstMen bc + bcSecondMen bc + bcFirstKings bc + bcSecondKings bc - cfg <- asks (gcAiConfig . csConfig) - if {-total <= aiUseCacheMaxPieces cfg &&-} dpTarget depth >= aiUseCacheMaxDepth cfg - then runStorage handle (lookupFile board depth) - `catch` - \(e :: SomeException) -> do - $reportError "Exception: lookupFile: {}" (Single $ show e) - return Nothing + load <- asks (aiLoadCache . gcAiConfig . csConfig) + if load + then do + let bc = calcBoardCounts board + let total = bcFirstMen bc + bcSecondMen bc + bcFirstKings bc + bcSecondKings bc + cfg <- asks (gcAiConfig . csConfig) + if {-total <= aiUseCacheMaxPieces cfg &&-} dpTarget depth >= aiUseCacheMaxDepth cfg + then runStorage handle (lookupFile board depth) + `catch` + \(e :: SomeException) -> do + $reportError "Exception: lookupFile: {}" (Single $ show e) + return Nothing + else return Nothing else return Nothing -- | Put an item to the cache. @@ -226,7 +231,7 @@ cfg <- asks (gcAiConfig . csConfig) let needWriteFile = {-total <= aiUpdateCacheMaxPieces cfg &&-} depth > aiUpdateCacheMaxDepth cfg Monitoring.timed "cache.put.memory" $ do - now <- liftIO $ getTime Monotonic + now <- liftIO $ getTime RealtimeCoarse Monitoring.increment "cache.records.put" fileCacheEnabled <- asks (aiStoreCache . gcAiConfig . csConfig) let cache = aichData handle @@ -236,4 +241,9 @@ when (fileCacheEnabled && needWriteFile) $ putWriteQueue (aichWriteQueue handle) (board, newItem) -- putCleanupQueue (aichCleanupQueue handle) (bc, bk) now + +resetAiCache :: AICacheHandle rules eval -> Checkers () +resetAiCache handle= do + let cache = aichData handle + liftIO $ resetBoardMap cache diff --git a/src/AI/AlphaBeta/Persistent.hs b/src/AI/AlphaBeta/Persistent.hs --- a/src/AI/AlphaBeta/Persistent.hs +++ b/src/AI/AlphaBeta/Persistent.hs @@ -10,13 +10,12 @@ module AI.AlphaBeta.Persistent (lookupFile, - lookupStatsFile, putRecordFile, putStatsFile, putWriteQueue, checkWriteQueue, initFile, - checkDataFile', + -- checkDataFile', loadIndexIO ) where @@ -324,10 +323,10 @@ then Just record else Nothing -lookupStatsFile :: Board -> Storage (Maybe Stats) -lookupStatsFile board = Monitoring.timed "stats.lookup.file" $ do - mbItem <- lookupFileB (encodeBoard board) - return $ join $ boardStats `fmap` mbItem +-- lookupStatsFile :: Board -> Storage (Maybe Stats) +-- lookupStatsFile board = Monitoring.timed "stats.lookup.file" $ do +-- mbItem <- lookupFileB (encodeBoard board) +-- return $ join $ boardStats `fmap` mbItem putRecordFileB :: B.ByteString -> PerBoardData -> Storage () putRecordFileB bstr newData = do @@ -497,22 +496,22 @@ record <- Data.Store.decodeIO bstr :: IO PerBoardData printf "Block #%d: data: %s\n" i (show record) -checkDataFile' :: FilePath -> IO () -checkDataFile' path = do - let params = File.MMapedParams (1024*1024) False - file <- File.initFile params path - nBlocks <- readDataIO file 0 :: IO DataBlockNumber - forM_ [0 .. nBlocks - 1] $ \i -> do - let start = fromIntegral $ calcDataBlockOffset i - size <- readDataIO file start :: IO Word16 - when (size > 0) $ do - bstr <- File.readBytes file (fromIntegral $ start + 2) (fromIntegral size) - record <- Data.Store.decodeIO bstr :: IO PerBoardData - case boardStats record of - Nothing -> return () - Just stats -> - when (statsCount stats > 10) $ - printf "Block #%d: data: %s\n" i (show record) +-- checkDataFile' :: FilePath -> IO () +-- checkDataFile' path = do +-- let params = File.MMapedParams (1024*1024) False +-- file <- File.initFile params path +-- nBlocks <- readDataIO file 0 :: IO DataBlockNumber +-- forM_ [0 .. nBlocks - 1] $ \i -> do +-- let start = fromIntegral $ calcDataBlockOffset i +-- size <- readDataIO file start :: IO Word16 +-- when (size > 0) $ do +-- bstr <- File.readBytes file (fromIntegral $ start + 2) (fromIntegral size) +-- record <- Data.Store.decodeIO bstr :: IO PerBoardData +-- case boardStats record of +-- Nothing -> return () +-- Just stats -> +-- when (statsCount stats > 10) $ +-- printf "Block #%d: data: %s\n" i (show record) data ParserState = ParserState { psIndex :: File.MMaped diff --git a/src/AI/AlphaBeta/Types.hs b/src/AI/AlphaBeta/Types.hs --- a/src/AI/AlphaBeta/Types.hs +++ b/src/AI/AlphaBeta/Types.hs @@ -13,6 +13,7 @@ dpLast, Stats (..), Bound (..), + MoveAndScore (..), PerBoardData (..), AIData, StorageKey, StorageValue, ScoreMoveInput (..), @@ -26,7 +27,7 @@ StorageState (..), ScoreState (..), ScoreM (..), ScoreInput (..), ScoreOutput (..), - DepthIterationInput, DepthIterationOutput, + DepthIterationInput (..), DepthIterationOutput, AiOutput, Storage, runStorage @@ -59,14 +60,16 @@ deriving (Eq, Ord, Show, Typeable) data AlphaBetaParams = AlphaBetaParams { - abDepth :: Int - , abStartDepth :: Maybe Int - , abCombinationDepth :: Int - , abDynamicDepth :: Int + abDepth :: Depth + , abStartDepth :: Maybe Depth + , abCombinationDepth :: Depth + , abDynamicDepth :: Depth , abDeeperIfBad :: Bool , abMovesLowBound :: Int , abMovesHighBound :: Int , abBaseTime :: Maybe Int + , abRandomOpeningDepth :: Int + , abRandomOpeningOptions :: Int } deriving (Eq, Ord, Show) @@ -80,21 +83,24 @@ , abMovesLowBound = 4 , abMovesHighBound = 8 , abBaseTime = Nothing + , abRandomOpeningDepth = 1 + , abRandomOpeningOptions = 1 } -- Calculation depth parameters data DepthParams = DepthParams { - dpInitialTarget :: Int - , dpTarget :: Int -- ^ Target depth: how deep we currently want to calculate the tree - , dpCurrent :: Int -- ^ Currently achieved depth - , dpMax :: Int -- ^ Maximum allowed depth - , dpMin :: Int -- ^ Minimum allowed depth + dpInitialTarget :: Depth + , dpTarget :: Depth -- ^ Target depth: how deep we currently want to calculate the tree + , dpCurrent :: Depth -- ^ Currently achieved depth + , dpMax :: Depth -- ^ Maximum allowed depth + , dpMin :: Depth -- ^ Minimum allowed depth , dpStaticMode :: Bool , dpForcedMode :: Bool + , dpReductedMode :: Bool } deriving (Eq, Ord, Show, Typeable, Generic) -dpLast :: DepthParams -> Int +dpLast :: DepthParams -> Depth dpLast dp = dpMax dp - dpCurrent dp instance Store DepthParams @@ -128,20 +134,19 @@ instance Store Bound data PerBoardData = PerBoardData { - itemDepth :: Int - , itemScore :: Score - , itemBound :: Bound - , boardStats :: Maybe Stats + itemDepth :: {-# UNPACK #-} ! Depth + , itemScore :: {-# UNPACK #-} ! Score + , itemBound :: ! Bound } deriving (Generic, Typeable, Show) instance Semigroup PerBoardData where d1 <> d2 - | itemDepth d1 > itemDepth d2 = d1 {boardStats = liftM2 (<>) (boardStats d1) (boardStats d2)} - | otherwise = d2 {boardStats = liftM2 (<>) (boardStats d1) (boardStats d2)} + | itemDepth d1 > itemDepth d2 = d1 + | otherwise = d2 instance Monoid PerBoardData where - mempty = PerBoardData 0 0 Exact Nothing + mempty = PerBoardData 0 0 Exact instance Binary PerBoardData instance Store PerBoardData @@ -157,12 +162,13 @@ smiAi :: AlphaBeta rules eval , smiCache :: AICacheHandle rules eval , smiGameId :: GameId - , smiSide :: Side - , smiDepth :: DepthParams - , smiBoard :: Board - , smiMove :: PossibleMove - , smiAlpha :: Score - , smiBeta :: Score + , smiSide :: ! Side + , smiIndex :: ! Int + , smiDepth :: {-# UNPACK #-} ! DepthParams + , smiBoard :: {-# UNPACK #-} ! Board + , smiMove :: {-# UNPACK #-} ! PossibleMove + , smiAlpha :: {-# UNPACK #-} ! Score + , smiBeta :: {-# UNPACK #-} ! Score } type QueueKey = (BoardCounts, BoardKey) @@ -175,12 +181,19 @@ type MovesMemo = TBoardMap (Maybe [PossibleMove], Maybe [PossibleMove]) +data MoveAndScore = MoveAndScore { + rMove :: {-# UNPACK #-} ! PossibleMove + , rScore :: {-# UNPACK #-} ! Score + } + deriving (Eq, Show, Generic, Typeable) + -- | Handle to the instance of AI storage -- and related structures data AICacheHandle rules eval = AICacheHandle { aichRules :: rules , aichData :: AIData - , aichProcessor :: Processor [MoveAction] (ScoreMoveInput rules eval) (PossibleMove, Score) + , aichJobIndex :: TVar Int + , aichProcessor :: Processor [Int] [ScoreMoveInput rules eval] [MoveAndScore] , aichPossibleMoves :: MovesMemo , aichLastMoveScoreShift :: TVar (M.Map GameId ScoreBase) , aichWriteQueue :: WriteQueue @@ -249,7 +262,7 @@ , ssEvaluator :: eval , ssGameId :: GameId , ssBestScores :: [Score] -- ^ At each level of depth-first search, there is own "best score" - , ssBestMoves :: M.Map Int (PossibleMove, Score) + , ssBestMoves :: M.Map Int MoveAndScore , ssStartTime :: TimeSpec -- ^ Start time of calculation , ssTimeout :: Maybe TimeSpec -- ^ Nothing for "no timeout" } @@ -293,8 +306,14 @@ St.put st' return result -type DepthIterationInput = (AlphaBetaParams, [PossibleMove], Maybe DepthIterationOutput) -type DepthIterationOutput = [(PossibleMove, Score)] +data DepthIterationInput = DepthIterationInput { + diiParams :: AlphaBetaParams, + diiMoves :: [PossibleMove], + diiSortKeys :: Maybe [Score], + diiPrevResult :: Maybe DepthIterationOutput + } + +type DepthIterationOutput = [MoveAndScore] type AiOutput = ([PossibleMove], Score) runStorage :: (GameRules rules, Evaluator eval) => AICacheHandle rules eval -> Storage a -> Checkers a diff --git a/src/Battle.hs b/src/Battle.hs new file mode 100644 --- /dev/null +++ b/src/Battle.hs @@ -0,0 +1,224 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +module Battle where + +import Control.Monad +import Control.Monad.IO.Class +import Data.List (intercalate, sortOn) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Text.Printf +import System.Random +import System.Random.Shuffle + +import Core.Types +import Core.Board +import Core.Supervisor +import AI.AlphaBeta.Types + +type AB rules = AlphaBeta rules (EvaluatorForRules rules) + +(<+>) :: Num a => V.Vector a -> V.Vector a -> V.Vector a +v1 <+> v2 = V.zipWith (+) v1 v2 + +(<->) :: Num a => V.Vector a -> V.Vector a -> V.Vector a +v1 <-> v2 = V.zipWith (-) v1 v2 + +scale :: Num a => a -> V.Vector a -> V.Vector a +scale a v = V.map (\x -> a*x) v + +norm :: V.Vector Double -> Double +-- norm v = sqrt $ V.sum $ V.map (\x -> x*x) v +norm v = (V.sum $ V.map abs v) / fromIntegral (V.length v) + +cross :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules) => rules -> (AB rules, AB rules) -> Checkers (AB rules) +cross rules (ai1, ai2) = do + let v1 = aiToVector ai1 + v2 = aiToVector ai2 + t <- liftIO $ randomRIO (0.0, 1.0) + let mid = scale (1.0 - t) v1 <+> scale t v2 + p <- liftIO $ randomRIO (0.0, 1.0) :: Checkers Double + v3 <- if p < 0.9 + then return mid + else do + let delta = {-0.5 *-} norm (v1 <-> v2) + dv <- liftIO $ replicateM (V.length v1) $ randomRIO (-delta, delta) + -- liftIO $ print delta + return $ mid <+> V.fromList dv + let v3' = V.take 3 v1 V.++ V.drop 3 v3 + return $ aiFromVector rules v3' + +breed :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules) => rules -> Int -> [AB rules] -> Checkers [AB rules] +breed rules nNew ais = do + let n = length ais + idxPairs = [(i,j) | i <- [0..n-1], j <- [i+1 .. n-1]] + idxPairs' <- liftIO $ shuffleM idxPairs + let ais' = [(ais !! i, ais !! j) | (i,j) <- idxPairs'] + mapM (cross rules) $ take nNew $ cycle ais' + +runGenetics :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules) + => rules -> Int -> Int -> Int -> [AB rules] -> Checkers [AB rules] +runGenetics rules nGenerations generationSize nBest ais = do + generation0 <- breed rules generationSize ais + run 1 generation0 + where + run n generation = do + liftIO $ printf "Generation #%d\n" n + best <- selectBest generation + if n == nGenerations + then return best + else do + generation' <- breed rules generationSize best + run (n+1) generation' + + nGames = 5 + nMatches = generationSize + + selectBest generation = do + results <- runTournament rules generation nMatches nGames + let best = take nBest $ sortOn (negate . snd) $ M.assocs results + idxs = map fst best + return [generation !! i | i <- idxs] + +runTournament :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules)) => rules -> [AlphaBeta rules (EvaluatorForRules rules)] -> Int -> Int -> Checkers (M.Map Int Int) +runTournament rules ais nMatches nGames = do + forM_ ais $ \ai -> + liftIO $ print $ aiToVector ai + let n = length ais + idxPairs = [(i,j) | i <- [0..n-1], j <- [i+1 .. n-1]] + ais' = map SomeAi ais + idxPairs' <- liftIO $ shuffleM idxPairs + stats <- forM (take nMatches idxPairs') $ \(i,j) -> + runMatch (SomeRules rules) (ais' !! i) (ais' !! j) nGames + forM_ (zip idxPairs' stats) $ \((i,j),(first,second,draw)) -> do + liftIO $ printf "AI#%d vs AI#%d: First %d, Second %d, Draw %d\n" i j first second draw + + let results1 = [(i, first - second) | ((i,j), (first,second,draw)) <- zip idxPairs' stats] + results2 = [(j, second - first) | ((i,j), (first,second,draw)) <- zip idxPairs' stats] + results = M.fromListWith (+) (results1 ++ results2) + forM_ (M.toAscList results) $ \(i, value) -> do + liftIO $ printf "AI#%d => %d\n" i value +-- let ai = ais !! i +-- vec = map show $ V.toList (aiToVector ai) ++ [fromIntegral value] +-- str = intercalate "," vec +-- liftIO $ putStrLn str + return results + +runMatch :: SomeRules -> SomeAi -> SomeAi -> Int -> Checkers (Int, Int, Int) +runMatch rules ai1 ai2 nGames = do + (nFirst, nSecond, nDraw) <- go 0 (0, 0, 0) + liftIO $ printf "First: %d, Second: %d, Draws(?): %d\n" nFirst nSecond nDraw + return (nFirst, nSecond, nDraw) + where + go :: Int -> (Int, Int, Int) -> Checkers (Int, Int, Int) + go i (first, second, draw) + | i >= nGames = return (first, second, draw) + | otherwise = do + result <- runBattle rules ai1 ai2 (printf "battle_%d.pdn" i) + let stats = case result of + FirstWin -> (first+1, second, draw) + SecondWin -> (first, second+1, draw) + Draw -> (first, second, draw+1) + go (i+1) stats + +runBattle :: SomeRules -> SomeAi -> SomeAi -> FilePath -> Checkers GameResult +runBattle rules ai1 ai2 path = do + initAiStorage rules ai1 + let firstSide = First + gameId <- newGame rules firstSide Nothing + registerUser gameId First "AI1" + registerUser gameId Second "AI2" + attachAi gameId First ai1 + attachAi gameId Second ai2 + resetAiStorageG gameId First + resetAiStorageG gameId Second + runGame gameId + result <- loopGame path gameId (opposite firstSide) 0 + liftIO $ print result + return result + +hasKing :: Side -> BoardRep -> Bool +hasKing side (BoardRep lst) = any isKing (map snd lst) + where + isKing (Piece King s) = s == side + isKing _ = False + +loopGame :: FilePath -> GameId -> Side -> Int -> Checkers GameResult +loopGame path gameId side i = do + StateRs board status side <- getState gameId + if (i > 100) || (i > 60 && boardRepLen board <= 8 && hasKing First board && hasKing Second board) + then do + liftIO $ putStrLn "Too long a game, probably a draw" + -- pdn <- getPdn gameId + -- liftIO $ TIO.writeFile path pdn + return Draw + else do + history <- getHistory gameId +-- liftIO $ do +-- print $ head history +-- print board + case status of + Ended result -> do + -- pdn <- getPdn gameId + -- liftIO $ TIO.writeFile path pdn + return result + _ -> do + letAiMove gameId side Nothing + loopGame path gameId (opposite side) (i+1) + +variableParameters :: [T.Text] +variableParameters = [ + "mobility_weight", "backyard_weight", "center_weight", + "opposite_side_weight", "backed_weight", "asymetry_weight", + "pre_king_weight", "attacked_man_coef", "attacked_king_coef" + ] + +nVariableParameters :: Int +nVariableParameters = length variableParameters + +updateObject :: [Pair] -> Value -> Value +updateObject pairs (Object v) = Object $ go pairs v + where + go [] v = v + go ((key, value):pairs) v = go pairs (H.insert key value v) +updateObject _ _ = error "invalid object" + +modifyObject :: [(T.Text, ScoreBase)] -> Value -> Value +modifyObject pairs (Object v) = Object $ go pairs v + where + go [] v = v + go ((key, delta):pairs) v = + let v' = H.insertWith modify key (Number (fromIntegral delta)) v + in go pairs v' + + modify (Number v1) (Number v2) = Number (v1+v2) + modify _ _ = error "invalid value in modify" + +generateVariation :: ScoreBase -> Value -> IO Value +generateVariation dv params = do + deltas <- replicateM nVariableParameters $ randomRIO (-dv, dv) + let pairs = [(key, delta) | (key, delta) <- zip variableParameters deltas] + return $ modifyObject pairs params + +generateAiVariations :: Int -> ScoreBase -> FilePath -> IO () +generateAiVariations n dv path = do + r <- decodeFileStrict path + case r of + Nothing -> fail "Cannot load initial AI" + Just initValue -> forM_ [1..n] $ \i -> do + value <- generateVariation dv initValue + encodeFile (printf "ai_variation_%d.json" i) value + diff --git a/src/Core/Board.hs b/src/Core/Board.hs --- a/src/Core/Board.hs +++ b/src/Core/Board.hs @@ -62,6 +62,9 @@ allFields :: Board -> [FieldIndex] allFields b = IM.keys (bAddresses b) +allLabels :: Board -> [Label] +allLabels b = map unpackIndex $ allFields b + allPieces :: Board -> [Maybe Piece] allPieces b = [getPiece' (Label col row) b | col <- [0 .. ncols-1], row <- [0 .. nrows-1]] @@ -73,10 +76,16 @@ boardDirection Bottom ForwardRight = UpRight boardDirection Bottom BackwardLeft = DownLeft boardDirection Bottom BackwardRight = DownRight +boardDirection Bottom Forward = Up +boardDirection Bottom Backward = Down boardDirection Top ForwardLeft = DownRight boardDirection Top ForwardRight = DownLeft boardDirection Top BackwardLeft = UpRight boardDirection Top BackwardRight = UpLeft +boardDirection Top Backward = Up +boardDirection Top Forward = Down +boardDirection _ PRight = ToRight +boardDirection _ PLeft = ToLeft boardSide :: BoardOrientation -> Side -> BoardSide boardSide FirstAtBottom First = Bottom @@ -98,22 +107,36 @@ playerDirection First UpRight = ForwardRight playerDirection First DownLeft = BackwardLeft playerDirection First DownRight = BackwardRight +playerDirection First Up = Forward +playerDirection First Down = Backward playerDirection Second UpLeft = BackwardRight playerDirection Second UpRight = BackwardLeft playerDirection Second DownLeft = ForwardRight playerDirection Second DownRight = ForwardLeft +playerDirection Second Down = Forward +playerDirection Second Up = Backward +playerDirection _ ToRight = PRight +playerDirection _ ToLeft = PLeft oppositeDirection :: PlayerDirection -> PlayerDirection oppositeDirection ForwardLeft = BackwardRight oppositeDirection ForwardRight = BackwardLeft oppositeDirection BackwardLeft = ForwardRight oppositeDirection BackwardRight = ForwardLeft +oppositeDirection Forward = Backward +oppositeDirection Backward = Forward +oppositeDirection PRight = PLeft +oppositeDirection PLeft = PRight neighbour :: BoardDirection -> Address -> Maybe Address neighbour UpLeft a = aUpLeft a neighbour UpRight a = aUpRight a neighbour DownLeft a = aDownLeft a neighbour DownRight a = aDownRight a +neighbour Up a = aUp a +neighbour ToRight a = aRight a +neighbour Down a = aDown a +neighbour ToLeft a = aLeft a myNeighbour :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Maybe Address myNeighbour rules side dir a = neighbour (myDirection rules side dir) a @@ -124,6 +147,10 @@ | aUpRight src == Just dst = Just UpRight | aDownLeft src == Just dst = Just DownLeft | aDownRight src == Just dst = Just DownRight + | aUp src == Just dst = Just Up + | aRight src == Just dst = Just ToRight + | aDown src == Just dst = Just Down + | aLeft src == Just dst = Just ToLeft | otherwise = Nothing getNeighbourDirection' :: Board -> Address -> Label -> Maybe BoardDirection @@ -281,6 +308,13 @@ First -> (IS.size (bFirstMen board), IS.size (bFirstKings board)) Second -> (IS.size (bSecondMen board), IS.size (bSecondKings board)) +totalCount :: Board -> Int +totalCount b = + IS.size (bFirstMen b) + + IS.size (bSecondMen b) + + IS.size (bFirstKings b) + + IS.size (bSecondKings b) + catMoves :: Move -> Move -> Move catMoves m1 m2 = Move (moveBegin m1) (moveSteps m1 ++ moveSteps m2) @@ -291,6 +325,7 @@ pmBegin = pmBegin pm1, pmEnd = pmEnd pm2, pmVictims = pmVictims pm1 ++ pmVictims pm2, + pmVictimsCount = pmVictimsCount pm1 + pmVictimsCount pm2, pmMove = catMoves (pmMove pm1) (pmMove pm2), pmPromote = pmPromote pm1 || pmPromote pm2, pmResult = cat (pmResult pm1) (pmResult pm2) @@ -376,8 +411,12 @@ applyMoveAction (RemoveCaptured a) b = if isFree a b then Left $ printf "RemoveCaptured: no piece at %s; board: %s" (show a) (show b) + else Right $ removePiece a b +applyMoveAction (MarkCaptured a) b = + if isFree a b + then Left $ printf "MarkCaptured: no piece at %s; board: %s" (show a) (show b) else if isCaptured a b - then Left $ printf "RemoveCaptured: piece at %s was already captured; board: %s" (show a) (show b) + then Left $ printf "MarkCaptured: piece at %s was already captured; board: %s" (show a) (show b) else Right $ b {bCaptured = insertLabelSet (aLabel a) (bCaptured b)} applyMoveActions' :: [MoveAction] -> Board -> Either String Board @@ -432,33 +471,6 @@ firstMoveDirection :: Move -> PlayerDirection firstMoveDirection move = sDirection $ head $ moveSteps move -makeLine :: [Label] -> [Address] -makeLine labels = map (\l -> Address l Nothing Nothing Nothing Nothing Nothing) labels - -line1labels :: [Label] -line1labels = ["a1", "c1", "e1", "g1"] - -line2labels :: [Label] -line2labels = ["b2", "d2", "f2", "h2"] - -line3labels :: [Label] -line3labels = ["a3", "c3", "e3", "g3"] - -line4labels :: [Label] -line4labels = ["b4", "d4", "f4", "h4"] - -line5labels :: [Label] -line5labels = ["a5", "c5", "e5", "g5"] - -line6labels :: [Label] -line6labels = ["b6", "d6", "f6", "h6"] - -line7labels :: [Label] -line7labels = ["a7", "c7", "e7", "g7"] - -line8labels :: [Label] -line8labels = ["b8", "d8", "f8", "h8"] - calcBoardHash :: Board -> BoardHash calcBoardHash board = foldr update 0 (boardAssocs board) where @@ -473,11 +485,24 @@ updateBoardHash board label piece = updateBoardHash' (randomTable board) (boardHash board) label piece -buildBoard :: RandomTableProvider rnd => rnd -> BoardOrientation -> BoardSize -> Board -buildBoard rnd orient bsize@(nrows, ncols) = - let mkAddress p = Address (label p) (promote p) (upLeft p) (upRight p) (downLeft p) (downRight p) +buildBoard :: (RandomTableProvider rnd, HasTopology rules) => rnd -> rules -> BoardOrientation -> BoardSize -> Board +buildBoard rnd rules orient bsize@(nrows, ncols) = + let mkAddress p = Address { + aLabel = label p + , aPromotionSide = promote p + , aUpLeft = upLeft p + , aUpRight = upRight p + , aDownLeft = downLeft p + , aDownRight = downRight p + , aUp = up p + , aRight = right p + , aDown = down p + , aLeft = left p + } label (r,c) = Label (c-1) (r-1) + diagonal = boardTopology rules == Diagonal + promote (r,_) | r == 1 = Just $ playerSide orient Top | r == nrows = Just $ playerSide orient Bottom @@ -499,12 +524,31 @@ | r-1 < 1 || c+1 > ncols = Nothing | otherwise = M.lookup (r-1, c+1) addresses + up (r,c) + | r+1 > nrows = Nothing + | otherwise = M.lookup (r+1, c) addresses + + down (r,c) + | r-1 < 1 = Nothing + | otherwise = M.lookup (r-1, c) addresses + + right (r,c) + | c+1 > ncols = Nothing + | otherwise = M.lookup (r, c+1) addresses + + left (r,c) + | c-1 < 1 = Nothing + | otherwise = M.lookup (r, c-1) addresses + addresses = M.fromList [(p, mkAddress p) | p <- coordinates] odds n = [1, 3 .. n] evens n = [2, 4 .. n] - coordinates = [(r, c) | r <- odds nrows, c <- odds ncols] ++ [(r, c) | r <- evens nrows, c <- evens ncols] + coordinates + | diagonal = [(r, c) | r <- odds nrows, c <- odds ncols] ++ [(r, c) | r <- evens nrows, c <- evens ncols] + | otherwise = [(r, c) | r <- [1..nrows], c <- [1..ncols]] + addressByLabel = buildLabelMap nrows ncols [(label p, address) | (p, address) <- M.assocs addresses] n2 = 16*16 @@ -519,8 +563,8 @@ bSecondMen = emptyLabelSet, bFirstKings = emptyLabelSet, bSecondKings = emptyLabelSet, - boardKey = IM.empty, - -- boardCounts = BoardCounts 0 0 0 0, + bFirstAttacked = emptyLabelSet, + bSecondAttacked = emptyLabelSet, bSize = bsize, boardHash = 0, randomTable = table @@ -553,10 +597,19 @@ Just piece -> piece getPiece' :: Label -> Board -> Maybe Piece -getPiece' l b = getPiece a b - where - a = fromMaybe (error $ "getPiece': unknown field: " ++ show l) $ lookupLabel l (bAddresses b) +getPiece' l b + | l `labelSetMember` bFirstKings b = Just $ Piece King First + | l `labelSetMember` bSecondKings b = Just $ Piece King Second + | l `labelSetMember` bFirstMen b = Just $ Piece Man First + | l `labelSetMember` bSecondMen b = Just $ Piece Man Second + | otherwise = Nothing +getPiecesCount :: Piece -> LabelSet -> Board -> Int +getPiecesCount (Piece King First) set board = labelSetSize $ intersectLabelSet set (bFirstKings board) +getPiecesCount (Piece King Second) set board = labelSetSize $ intersectLabelSet set (bSecondKings board) +getPiecesCount (Piece Man First) set board = labelSetSize $ intersectLabelSet set (bFirstMen board) +getPiecesCount (Piece Man Second) set board = labelSetSize $ intersectLabelSet set (bSecondMen board) + getCapturablePiece :: Address -> Board -> Maybe Piece getCapturablePiece a b = if isCaptured a b @@ -612,9 +665,36 @@ setManyPieces' :: [Label] -> Piece -> Board -> Board setManyPieces' labels piece board = foldr (\l b -> setPiece' l piece b) board labels -board8 :: RandomTableProvider rnd => rnd -> Board -board8 rnd = - let board = buildBoard rnd FirstAtBottom (8, 8) +line1labels :: [Label] +line1labels = ["a1", "c1", "e1", "g1"] + +line2labels :: [Label] +line2labels = ["b2", "d2", "f2", "h2"] + +line3labels :: [Label] +line3labels = ["a3", "c3", "e3", "g3"] + +line4labels :: [Label] +line4labels = ["b4", "d4", "f4", "h4"] + +line5labels :: [Label] +line5labels = ["a5", "c5", "e5", "g5"] + +line6labels :: [Label] +line6labels = ["b6", "d6", "f6", "h6"] + +line7labels :: [Label] +line7labels = ["a7", "c7", "e7", "g7"] + +line8labels :: [Label] +line8labels = ["b8", "d8", "f8", "h8"] + +emptyBoard8 :: (RandomTableProvider rnd, HasTopology rules) => rnd -> rules -> Board +emptyBoard8 rnd rules = buildBoard rnd rules FirstAtBottom (8, 8) + +board8 :: (RandomTableProvider rnd, HasTopology rules) => rnd -> rules -> Board +board8 rnd rules = + let board = buildBoard rnd rules FirstAtBottom (8, 8) labels1 = line1labels ++ line2labels ++ line3labels labels2 = line8labels ++ line7labels ++ line6labels in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board @@ -660,7 +740,7 @@ boardRep board = BoardRep $ boardAssocs board parseBoardRep :: (GameRules rules, RandomTableProvider rnd) => rnd -> rules -> BoardRep -> Board -parseBoardRep rnd rules (BoardRep list) = foldr set (buildBoard rnd orient bsize) list +parseBoardRep rnd rules (BoardRep list) = foldr set (buildBoard rnd rules orient bsize) list where set (label, piece) board = setPiece' label piece board bsize = boardSize rules @@ -668,13 +748,11 @@ -- | Generic implementation of @getGameResult@, which suits most rules. -- This can not, however, recognize draws. -genericGameResult :: GameRules rules => rules -> Board -> Maybe GameResult -genericGameResult rules board = - if null (possibleMoves rules First board) - then Just SecondWin - else if null (possibleMoves rules Second board) - then Just FirstWin - else Nothing +genericGameResult :: GameRules rules => rules -> Board -> Side -> Maybe GameResult +genericGameResult rules board side + | side == First && null (possibleMoves rules First board) = Just SecondWin + | side == Second && null (possibleMoves rules Second board) = Just FirstWin + | otherwise = Nothing instance IsString Label where fromString str = @@ -761,4 +839,16 @@ (nrows, ncols) = bSize b flipLabel (Label col row) = Label (ncols - col - 1) (nrows - row - 1) + +boardAttacked :: Side -> Board -> LabelSet +boardAttacked First = bFirstAttacked +boardAttacked Second = bSecondAttacked + +markAttacked :: GameRules rules => rules -> Board -> Board +markAttacked rules board = + let attackedBy side = labelSetFromList $ map aLabel $ concatMap pmVictims $ possibleMoves rules side board + in board { + bFirstAttacked = attackedBy Second, + bSecondAttacked = attackedBy First + } diff --git a/src/Core/BoardMap.hs b/src/Core/BoardMap.hs --- a/src/Core/BoardMap.hs +++ b/src/Core/BoardMap.hs @@ -5,7 +5,7 @@ import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS import Data.Hashable -import qualified STMContainers.Map as SM +import qualified StmContainers.Map as SM import Text.Printf import Core.Types @@ -57,25 +57,21 @@ insertBoard :: Address -> Piece -> Board -> Board insertBoard a p@(Piece Man First) b = b { bFirstMen = insertLabelSet (aLabel a) (bFirstMen b), - boardKey = insertBoardKey a p (boardKey b), bOccupied = insertLabelSet (aLabel a) (bOccupied b) -- boardCounts = insertBoardCounts p (boardCounts b) } insertBoard a p@(Piece Man Second) b = b { bSecondMen = insertLabelSet (aLabel a) (bSecondMen b), - boardKey = insertBoardKey a p (boardKey b), bOccupied = insertLabelSet (aLabel a) (bOccupied b) -- boardCounts = insertBoardCounts p (boardCounts b) } insertBoard a p@(Piece King First) b = b { bFirstKings = insertLabelSet (aLabel a) (bFirstKings b), - boardKey = insertBoardKey a p (boardKey b), bOccupied = insertLabelSet (aLabel a) (bOccupied b) -- boardCounts = insertBoardCounts p (boardCounts b) } insertBoard a p@(Piece King Second) b = b { bSecondKings = insertLabelSet (aLabel a) (bSecondKings b), - boardKey = insertBoardKey a p (boardKey b), bOccupied = insertLabelSet (aLabel a) (bOccupied b) -- boardCounts = insertBoardCounts p (boardCounts b) } @@ -83,25 +79,21 @@ removeBoard :: Address -> Piece -> Board -> Board removeBoard a p@(Piece Man First) b = b { bFirstMen = deleteLabelSet (aLabel a) (bFirstMen b), - boardKey = removeBoardKey a p (boardKey b), bOccupied = deleteLabelSet (aLabel a) (bOccupied b) -- boardCounts = removeBoardCounts p (boardCounts b) } removeBoard a p@(Piece Man Second) b = b { bSecondMen = deleteLabelSet (aLabel a) (bSecondMen b), - boardKey = removeBoardKey a p (boardKey b), bOccupied = deleteLabelSet (aLabel a) (bOccupied b) -- boardCounts = removeBoardCounts p (boardCounts b) } removeBoard a p@(Piece King First) b = b { bFirstKings = deleteLabelSet (aLabel a) (bFirstKings b), - boardKey = removeBoardKey a p (boardKey b), bOccupied = deleteLabelSet (aLabel a) (bOccupied b) -- boardCounts = removeBoardCounts p (boardCounts b) } removeBoard a p@(Piece King Second) b = b { bSecondKings = deleteLabelSet (aLabel a) (bSecondKings b), - boardKey = removeBoardKey a p (boardKey b), bOccupied = deleteLabelSet (aLabel a) (bOccupied b) -- boardCounts = removeBoardCounts p (boardCounts b) } @@ -143,6 +135,9 @@ -- Nothing -> return Nothing -- Just byHash -> SM.lookup (boardHash board) byHash +resetBoardMap :: TBoardMap a -> IO () +resetBoardMap bmap = atomically $ SM.reset bmap + ------------------ unpackIndex :: FieldIndex -> Label @@ -211,6 +206,12 @@ deleteLabelSet :: Label -> LabelSet -> LabelSet deleteLabelSet (Label col row) set = IS.delete (mkIndex col row) set + +intersectLabelSet :: LabelSet -> LabelSet -> LabelSet +intersectLabelSet = IS.intersection + +labelSetSize :: LabelSet -> Int +labelSetSize = IS.size labelSetMember :: Label -> LabelSet -> Bool labelSetMember (Label col row) set = IS.member (mkIndex col row) set diff --git a/src/Core/Evaluator.hs b/src/Core/Evaluator.hs --- a/src/Core/Evaluator.hs +++ b/src/Core/Evaluator.hs @@ -1,85 +1,225 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Core.Evaluator ( SimpleEvaluator (..), + SimpleEvaluatorInterface (..), + SimpleEvaluatorSupport (..), + SimpleEvaluatorData (..), + weightForSide, defaultEvaluator ) where import Data.Aeson -import Data.Aeson.Types ( parseMaybe ) +import Data.Aeson.Types as AT import Data.Default +import qualified Data.Vector as V +import qualified Data.Map as M import Core.Types import Core.Board +data SimpleEvaluatorWeights = SimpleEvaluatorWeights { + sewFirst :: {-# UNPACK #-} ! ScoreBase + , sewSecond :: {-# UNPACK #-} ! ScoreBase + } + deriving (Show) + +weightForSide :: Side -> SimpleEvaluatorWeights -> ScoreBase +weightForSide First w = sewFirst w +weightForSide Second w = sewSecond w + +data SimpleEvaluatorData = SimpleEvaluatorData { + sedCenter :: SimpleEvaluatorWeights + } + deriving (Show) + data SimpleEvaluator = SimpleEvaluator { - seRules :: SomeRules, + seRules :: SimpleEvaluatorInterface, seUsePositionalScore :: Bool, seMobilityWeight :: ScoreBase, + seBackyardWeight :: ScoreBase, seCenterWeight :: ScoreBase, seOppositeSideWeight :: ScoreBase, + seBorderManWeight :: ScoreBase, seBackedWeight :: ScoreBase, seAsymetryWeight :: ScoreBase, sePreKingWeight :: ScoreBase, seKingCoef :: ScoreBase, - seHelpedKingCoef :: ScoreBase + seHelpedKingCoef :: ScoreBase, + seThreatWeight :: ScoreBase, + seAttackedManCoef :: ScoreBase, + seAttackedKingCoef :: ScoreBase, + seCache :: M.Map Address SimpleEvaluatorData } deriving (Show) -defaultEvaluator :: GameRules rules => rules -> SimpleEvaluator +class GameRules rules => SimpleEvaluatorSupport rules where + getBackDirections :: rules -> [PlayerDirection] + getBackDirections _ = [BackwardLeft, BackwardRight] + + getForwardDirections :: rules -> [PlayerDirection] + getForwardDirections _ = [ForwardLeft, ForwardRight] + + getAllAddresses :: rules -> [Address] + +data SimpleEvaluatorInterface = forall g. SimpleEvaluatorSupport g => SimpleEvaluatorInterface g + +instance Show SimpleEvaluatorInterface where + show (SimpleEvaluatorInterface rules) = rulesName rules + +defaultEvaluator :: SimpleEvaluatorSupport rules => rules -> SimpleEvaluator defaultEvaluator rules = SimpleEvaluator - { seRules = SomeRules rules - , seUsePositionalScore = True - , seMobilityWeight = 3 - , seCenterWeight = 4 - , seOppositeSideWeight = 4 - , seBackedWeight = 2 - , seAsymetryWeight = 1 - , sePreKingWeight = 3 - , seKingCoef = 3 - , seHelpedKingCoef = 5 - } + { seRules = iface + , seUsePositionalScore = True + , seMobilityWeight = 30 + , seBackyardWeight = 14 + , seCenterWeight = 16 + , seOppositeSideWeight = 32 + , seBorderManWeight = -16 + , seBackedWeight = 24 + , seAsymetryWeight = -12 + , sePreKingWeight = 28 + , seKingCoef = 3 + , seHelpedKingCoef = 5 + , seThreatWeight = 10 + , seAttackedManCoef = -40 + , seAttackedKingCoef = -80 + , seCache = buildCache iface + } + where + iface = SimpleEvaluatorInterface rules +parseEvaluator :: SimpleEvaluator -> Value -> AT.Parser SimpleEvaluator +parseEvaluator def = withObject "Evaluator" $ \v -> SimpleEvaluator + <$> pure (seRules def) + <*> v .:? "use_positional_score" .!= seUsePositionalScore def + <*> v .:? "mobility_weight" .!= seMobilityWeight def + <*> v .:? "backyard_weight" .!= seBackyardWeight def + <*> v .:? "center_weight" .!= seCenterWeight def + <*> v .:? "opposite_side_weight" .!= seOppositeSideWeight def + <*> v .:? "border_man_weight" .!= seBorderManWeight def + <*> v .:? "backed_weight" .!= seBackedWeight def + <*> v .:? "asymetry_weight" .!= seAsymetryWeight def + <*> v .:? "pre_king_weight" .!= sePreKingWeight def + <*> v .:? "king_coef" .!= seKingCoef def + <*> v .:? "helped_king_coef" .!= seHelpedKingCoef def + <*> v .:? "threat_weight" .!= seThreatWeight def + <*> v .:? "attacked_man_coef" .!= seAttackedManCoef def + <*> v .:? "attacked_king_coef" .!= seAttackedKingCoef def + <*> pure (seCache def) + +instance ToJSON SimpleEvaluator where + toJSON p = object [ + "use_positional_score" .= seUsePositionalScore p, + "mobility_weight" .= seMobilityWeight p, + "backyard_weight" .= seBackyardWeight p, + "center_weight" .= seCenterWeight p, + "opposite_side_weight" .= seOppositeSideWeight p, + "border_man_weight" .= seBorderManWeight p, + "backed_weight" .= seBackedWeight p, + "asymetry_weight" .= seAsymetryWeight p, + "pre_king_weight" .= sePreKingWeight p, + "king_coef" .= seKingCoef p, + "helped_king_coef" .= seHelpedKingCoef p, + "threat_weight" .= seThreatWeight p, + "attacked_man_coef" .= seAttackedManCoef p, + "attacked_king_coef" .= seAttackedKingCoef p + ] + data PreScore = PreScore { - psNumeric :: ScoreBase + psNumeric :: ! ScoreBase , psMobility :: ScoreBase + , psBackyard :: ScoreBase , psCenter :: ScoreBase , psTemp :: ScoreBase + , psBorder :: ScoreBase , psBacked :: ScoreBase , psAsymetry :: ScoreBase , psPreKing :: ScoreBase + , psAttackedMen :: ScoreBase + , psAttackedKings :: ScoreBase + , psThreats :: ScoreBase } sub :: PreScore -> PreScore -> PreScore sub ps1 ps2 = PreScore { psNumeric = psNumeric ps1 - psNumeric ps2 , psMobility = psMobility ps1 - psMobility ps2 + , psBackyard = psBackyard ps1 - psBackyard ps2 , psCenter = psCenter ps1 - psCenter ps2 , psTemp = psTemp ps1 - psTemp ps2 + , psBorder = psBorder ps1 - psBorder ps2 , psBacked = psBacked ps1 - psBacked ps2 , psAsymetry = psAsymetry ps1 - psAsymetry ps2 , psPreKing = psPreKing ps1 - psPreKing ps2 + , psAttackedMen = psAttackedMen ps1 - psAttackedMen ps2 + , psAttackedKings = psAttackedKings ps1 - psAttackedKings ps2 + , psThreats = psThreats ps1 - psThreats ps2 } instance Default PreScore where def = PreScore { psNumeric = 0 , psMobility = 0 + , psBackyard = 0 , psCenter = 0 , psTemp = 0 + , psBorder = 0 , psBacked = 0 , psAsymetry = 0 , psPreKing = 0 + , psAttackedMen = 0 + , psAttackedKings = 0 + , psThreats = 0 } +waveRho :: SimpleEvaluatorInterface -> Side -> (Address -> Bool) -> Address -> ScoreBase -> ScoreBase +waveRho (SimpleEvaluatorInterface rules) side isGood addr best = go addr + where + go :: Address -> ScoreBase + go addr + | isGood addr = best + | otherwise = + let check :: PlayerDirection -> ScoreBase + check dir = + case myNeighbour rules side dir addr of + Nothing -> 0 + Just dst -> max 0 $ go dst - 1 + in maximum $ map check $ getForwardDirections rules + +buildCache :: SimpleEvaluatorInterface -> M.Map Address SimpleEvaluatorData +buildCache iface@(SimpleEvaluatorInterface rules) = M.fromList [(addr, labelData addr) | addr <- getAllAddresses rules] + where + labelData addr = SimpleEvaluatorData $ SimpleEvaluatorWeights { + sewFirst = waveRho iface First (isCenter . aLabel) addr best, + sewSecond = waveRho iface Second (isCenter . aLabel) addr best + } + + (nrows, ncols) = boardSize rules + + best = fromIntegral $ nrows `div` 2 - 1 + + crow = nrows `div` 2 + ccol = ncols `div` 2 + halfCol = ccol `div` 2 + halfRow = crow `div` 2 + + isCenter (Label col row) = + (col >= ccol - halfCol && col < ccol + halfCol) + && (row >= crow - 1 && row < crow + 1) + -- && (row >= crow - halfRow && row < crow + halfRow) + preEval :: SimpleEvaluator -> Side -> Board -> PreScore -preEval (SimpleEvaluator { seRules = SomeRules rules, ..}) side board = +preEval (SimpleEvaluator { seRules = iface@(SimpleEvaluatorInterface rules), ..}) side board = let - kingCoef = + kingCoef = seKingCoef -- King is much more useful when there are enough men to help it - let (men, _) = myCounts side board - in if men > 3 then seHelpedKingCoef else seKingCoef +-- let (men, _) = myCounts side board +-- in if men > 3 then seHelpedKingCoef else seKingCoef numericScore = let (myMen, myKings) = myCounts side board @@ -91,10 +231,6 @@ halfCol = ccol `div` 2 halfRow = crow `div` 2 - isCenter (Label col row) = - (col >= ccol - halfCol && col < ccol + halfCol) - && (row >= crow - halfRow && row < crow + halfRow) - isLeftHalf (Label col _) = col >= ccol asymetry = @@ -108,47 +244,85 @@ Just back -> isPieceAt back board side backedScoreOf addr = - length $ filter (isBackedAt addr) [BackwardLeft, BackwardRight] + length $ filter (isBackedAt addr) $ getBackDirections rules backedScore = fromIntegral $ sum $ map backedScoreOf $ allMyAddresses side board - tempNumber (Label col row) - | col == 0 || col == ncols - 1 = 0 - | otherwise = case boardSide (boardOrientation rules) side of + isBackyard (Label _ row) = + case boardSide (boardOrientation rules) side of + Top -> row == nrows-1 + Bottom -> row == 0 + + backyard = + let (backMen, _) = myLabelsCount side board isBackyard + in backMen + + tempNumber (Label col row) = + case boardSide (boardOrientation rules) side of Top -> nrows - row Bottom -> row + 1 - -- opponentSideCount :: Side -> Int + isBorder (Label col row) = + col == 0 || col == ncols - 1 + + borderNumber = + let (men, _) = myLabelsCount side board isBorder + in men + + centerNumber addr = weightForSide side $ sedCenter $ seCache M.! addr + opponentSideCount = - let (men, kings) = myLabelsCount' side board tempNumber in men + sum $ map tempNumber $ myMen side board - preKing board src = sum $ map check [ForwardLeft, ForwardRight] + threatsBy addr = sum $ map check $ getForwardDirections rules where check dir = - case myNeighbour rules side dir src of + case myNeighbour rules side dir addr of Nothing -> 0 - Just dst -> if isLastHorizontal side dst && isFree dst board - then 1 - else 0 + Just f1 -> + if isFree f1 board + then case myNeighbour rules side dir f1 of + Nothing -> 0 + Just f2 -> if isFree f2 board + then 1 + else 0 + else 0 + threatsCount = sum $ map threatsBy $ myMenA side board + + isPreKing board src = any check $ getForwardDirections rules + where + check dir = + case myNeighbour rules side dir src of + Nothing -> False + Just dst -> isLastHorizontal side dst && isFree dst board + preKings = - let (men, kings) = myAddressesCount' side board (preKing board) in men + length $ filter (isPreKing board) $ myMenA side board mobility = mobilityScore rules side board + attackedFields = boardAttacked side board + attackedMen = getPiecesCount (Piece Man side) attackedFields board + attackedKings = getPiecesCount (Piece King side) attackedFields board + centerScore = - let (men, kings) = myLabelsCount side board isCenter - in kingCoef * fromIntegral kings + fromIntegral men + let (men, kings) = myAddressesCount' side board centerNumber in men + kings in PreScore { psNumeric = numericScore , psMobility = fromIntegral mobility - , psCenter = centerScore + , psCenter = fromIntegral centerScore + , psBackyard = fromIntegral backyard , psTemp = fromIntegral opponentSideCount + , psBorder = fromIntegral borderNumber , psBacked = fromIntegral backedScore , psAsymetry = fromIntegral asymetry , psPreKing = fromIntegral preKings + , psAttackedMen = fromIntegral attackedMen + , psAttackedKings = fromIntegral attackedKings + , psThreats = fromIntegral threatsCount } preEvalBoth :: SimpleEvaluator -> Board -> PreScore @@ -158,26 +332,46 @@ instance Evaluator SimpleEvaluator where evaluatorName _ = "simple" - updateEval e (Object v) = - case parseMaybe (.: "use_positional_score") v of + updateEval e v = + case AT.parseMaybe (parseEvaluator e) v of Nothing -> e - Just Nothing -> e - Just (Just True) -> e {seUsePositionalScore = True} - Just (Just False) -> e {seUsePositionalScore = False} + Just e' -> e' - evalBoard eval@(SimpleEvaluator {..}) whoAsks board = + evalBoard eval@(SimpleEvaluator {seRules = SimpleEvaluatorInterface rules, ..}) whoAsks board = let ps1 = preEval eval whoAsks board ps2 = preEval eval (opposite whoAsks) board + initCount = initPiecesCount rules + openingCount = 2 * initCount `div` 3 + endgameCount = initCount `div` 3 +-- midgameCount = initCount `div` 2 + count = totalCount board + + crescentAdjustment :: ScoreBase -> ScoreBase -> ScoreBase + crescentAdjustment from to + | count >= openingCount = to + | count <= endgameCount = from + | otherwise = (from - to) * fromIntegral (count - openingCount) `div` fromIntegral (endgameCount - openingCount) + to + + backyardWeight = crescentAdjustment seBackyardWeight 0 + centerWeight = crescentAdjustment seCenterWeight (seCenterWeight `div` 2) + tempWeight = crescentAdjustment (seOppositeSideWeight * 2) seOppositeSideWeight + asymetryWeight = crescentAdjustment 0 seAsymetryWeight + positionalScore ps = if seUsePositionalScore then - seCenterWeight * psCenter ps + - seOppositeSideWeight * psTemp ps + + centerWeight * psCenter ps + + backyardWeight * psBackyard ps + + tempWeight * psTemp ps + + seBorderManWeight * psBorder ps + seMobilityWeight * psMobility ps + seBackedWeight * psBacked ps + - seAsymetryWeight * psAsymetry ps + - sePreKingWeight * psPreKing ps + asymetryWeight * psAsymetry ps + + sePreKingWeight * psPreKing ps + + seAttackedManCoef * psAttackedMen ps + + seAttackedKingCoef * psAttackedKings ps + + seThreatWeight * psThreats ps else 0 myNumeric = psNumeric ps1 @@ -191,6 +385,40 @@ else if opponentNumeric == 0 then win else (myScore - opponentScore) + +instance VectorEvaluator SimpleEvaluator where + type VectorEvaluatorSupport SimpleEvaluator rules = SimpleEvaluatorSupport rules + + evalToVector (SimpleEvaluator {..}) = V.fromList $ map fromIntegral $ [ + seMobilityWeight, seBackyardWeight, + seCenterWeight, seOppositeSideWeight, + seBackedWeight, + seAsymetryWeight, sePreKingWeight, + seKingCoef, seAttackedManCoef, + seAttackedKingCoef, seBorderManWeight, + seThreatWeight] + + evalFromVector rules v = SimpleEvaluator { + seRules = iface + , seUsePositionalScore = True + , seMobilityWeight = round (v V.! 0) + , seBackyardWeight = round (v V.! 1) + , seCenterWeight = round (v V.! 2) + , seOppositeSideWeight = round (v V.! 3) + , seBackedWeight = round (v V.! 4) + , seAsymetryWeight = round (v V.! 5) + , sePreKingWeight = round (v V.! 6) + , seKingCoef = round (v V.! 7) + , seHelpedKingCoef = round (v V.! 7) + , seAttackedManCoef = round (v V.! 8) + , seAttackedKingCoef = round (v V.! 9) + , seBorderManWeight = round (v V.! 10) + , seThreatWeight = round (v V.! 11) + , seCache = buildCache iface + } + where + iface = SimpleEvaluatorInterface rules + -- data ComplexEvaluator rules = ComplexEvaluator { -- ceRules :: rules diff --git a/src/Core/Game.hs b/src/Core/Game.hs --- a/src/Core/Game.hs +++ b/src/Core/Game.hs @@ -15,6 +15,7 @@ import Control.Monad.State import Control.Monad.Except import Control.Concurrent.STM +import qualified Data.Map as M import Core.Types import Core.Board @@ -43,6 +44,15 @@ gMsgbox2 = msgbox2 } +-- | Get game by Id +getGame :: GameId -> Checkers Game +getGame gameId = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + case M.lookup gameId (ssGames st) of + Just game -> return game + Nothing -> throwError $ NoSuchGame gameId + -- | Check current game status. -- Throw an error if it is not as expected. -- Do nothing otherwise. @@ -85,6 +95,12 @@ let side = hrSide r in HistoryRecordRep side (moveRep rules side $ hrMove r) +-- | Number of half-moves done in this game +gameMoveNumber :: Game -> Int +gameMoveNumber g = + let history = gsHistory $ gState g + in length history + -- | Move result. Contains resulting board and a list of notification messages. data GMoveRs = GMoveRs Board [Notify] @@ -100,7 +116,7 @@ else do let (board', _, _) = applyMove rules side move board moveMsg = MoveNotify (opposite side) side (moveRep rules side move) (boardRep board') - mbResult = getGameResult rules board' + mbResult = getGameResult rules board' (opposite side) messages = case mbResult of Nothing -> [moveMsg] Just result -> diff --git a/src/Core/Json.hs b/src/Core/Json.hs --- a/src/Core/Json.hs +++ b/src/Core/Json.hs @@ -11,6 +11,7 @@ import Core.Types import Core.Logging import Core.Supervisor +import Formats.Types instance ToJSON PlayerDirection where @@ -26,6 +27,8 @@ instance ToJSON BoardOrientation +instance ToJSON BoardTopology + instance ToJSON Label where toJSON (Label col row) = toJSON (col, row) @@ -116,6 +119,19 @@ <$> v .: "ai" <*> v .:? "params" .!= Null +instance FromJSON PdnInfoRq where + parseJSON = withObject "PDN" $ \v -> PdnInfoRq + <$> v .: "rules" + <*> v .: "text" + +instance ToJSON PdnInfo where + toJSON pdn = object [ + "title" .= pdnTitle pdn + , "rules" .= pdnRules pdn + , "result" .= pdnResult pdn + , "next_move" .= pdnNextMove pdn + ] + instance ToJSON Notify where toJSON (MoveNotify to from move board) = object ["to_side" .= to, "from_side" .= from, "move" .= move, "board" .= board] @@ -138,6 +154,7 @@ toJSON (PollRs messages) = toJSON messages toJSON (StateRs board status side) = object ["board" .= board, "side" .= side, "status" .= status] toJSON (HistoryRs records) = toJSON records + toJSON (PdnInfoRs info) = toJSON info toJSON (PossibleMovesRs moves) = toJSON moves toJSON (MoveRs board) = toJSON board toJSON (UndoRs board) = toJSON board @@ -147,6 +164,8 @@ toJSON (LobbyRs games) = toJSON games toJSON (NotationRs size orientation list) = object ["size" .= size, "orientation" .= orientation, "notation" .= list] + toJSON (TopologyRs topology) = + object ["topology" .= topology] toJSON ShutdownRs = object ["shutdown" .= ("ok" :: T.Text)] instance ToJSON Response where diff --git a/src/Core/Rest.hs b/src/Core/Rest.hs --- a/src/Core/Rest.hs +++ b/src/Core/Rest.hs @@ -1,24 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Core.Rest where import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM +import Control.Exception as E +import Control.Monad.Catch +import Data.String import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import Data.Default import Data.Maybe import Data.Aeson hiding ( json ) import Web.Scotty.Trans +import qualified Network.HTTP.Types as H import Network.HTTP.Types.Status +import Network.Wai.Handler.Warp +import qualified Network.Wai as Wai import System.Log.Heavy import System.Log.Heavy.TH +import Network.Socket +import System.Exit import Core.Types import Core.Board import Core.Supervisor import Core.Json ( ) -- import instances only +import Formats.Types import Formats.Fen import Formats.Pdn @@ -30,9 +41,25 @@ status status400 transformError :: Error -> Rest () +transformError (Unhandled err) = do + error400 $ T.pack err +transformError (NoSuchMoveExt move side board possible) = do + json $ object [ + "error" .= ("no such move" :: T.Text), + "move" .= move, + "side" .= side, + "board" .= board, + "possible" .= possible + ] + status status400 transformError err = do error400 $ T.pack $ show err +raise500 :: Error -> Rest a +raise500 err = do + text $ TL.pack $ show err + raiseStatus status500 err + instance Parsable Side where parseParam "1" = Right First parseParam "2" = Right Second @@ -56,7 +83,7 @@ res <- lift $ wrap $ tryC actions case res of Right result -> return result - Left err -> raise err + Left err -> raise500 err where wrap r = case mbId of Nothing -> r @@ -72,7 +99,10 @@ boardRq rnd rules (NewGameRq { rqBoard = Nothing, rqFen = Nothing, rqPdn = Just pdn }) = case parsePdn (Just rules) pdn of Left err -> raise $ InvalidBoard err - Right gr -> return (Nothing, Just $ boardRep $ loadPdn rnd gr) + Right gr -> + case loadPdn rnd gr of + Left err -> raise err + Right board -> return (Nothing, Just $ boardRep board) boardRq _ _ (NewGameRq { rqPrevBoard = Just gameId }) = do board <- liftCheckers_ $ getInitialBoard gameId return (Nothing, Just $ boardRep board) @@ -81,6 +111,15 @@ boardRq _ _ _ = raise $ InvalidBoard "only one of fields must be filled: board, fen, pdn" +parsePdnInfo :: PdnInfoRq -> Rest PdnInfo +parsePdnInfo (PdnInfoRq rname text) = do + case selectRules' rname of + Nothing -> raise UnknownRules + Just rules -> + case parsePdn (Just rules) text of + Left err -> raise $ InvalidBoard err + Right gr -> return $ pdnInfo gr + restServer :: MVar () -> ScottyT Error Checkers () restServer shutdownVar = do @@ -220,6 +259,16 @@ (size, orientation, notation) <- liftCheckers_ $ getNotation rules json $ Response (NotationRs size orientation notation) [] + get "/topology/:rules" $ do + rules <- param "rules" + topology <- liftCheckers_ $ getTopology rules + json $ Response (TopologyRs topology) [] + + post "/file/info/pdn" $ do + rq <- jsonData + info <- parsePdnInfo rq + json $ Response (PdnInfoRs info) [] + post "/server/shutdown" $ do isLocal <- lift $ asks (gcLocal . csConfig) if isLocal @@ -228,6 +277,48 @@ liftIO $ putMVar shutdownVar () else error400 "Server is not running in local mode" + get "/status" $ do + json $ object [ + "status" .= ("ready" :: T.Text) + ] + +restOptions :: String -> Port -> Web.Scotty.Trans.Options +restOptions host port = + Options 0 $ setOnExceptionResponse errorHandler $ + setHost (fromString host) $ + setPort port (settings def) + +errorHandler :: SomeException -> Wai.Response +errorHandler e + | Just (err :: Error) <- fromException e = + Wai.responseLBS H.internalServerError500 + [(H.hContentType, "text/plain; charset=utf-8")] + (fromString $ show err) + | otherwise = + Wai.responseLBS H.internalServerError500 + [(H.hContentType, "text/plain; charset=utf-8")] + (fromString $ show e) + +-- openSocket :: AddrInfo -> IO Socket +-- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-- +-- checkPort :: HostName -> Port -> IO Bool +-- checkPort host port = do +-- addr <- head <$> getAddrInfo (Just defaultHints) (Just host) (Just $ show port) +-- E.bracketOnError (openSocket addr) close $ \sock -> do +-- withFdSocket sock setCloseOnExecIfNeeded +-- r <- E.try $ bind sock $ addrAddress addr +-- case r of +-- Right _ -> return True +-- Left (e :: SomeException) -> do +-- print e +-- return False + +ioErrorHandler :: IOError -> Checkers () +ioErrorHandler err = liftIO $ do + putStrLn $ "IO error: " ++ show err + exitWith (ExitFailure 2) + runRestServer :: Checkers () runRestServer = do cs <- ask @@ -236,9 +327,11 @@ case res of Right response -> return response Left err -> fail $ show err + host <- asks (T.unpack . gcHost . csConfig) port <- asks (gcPort . csConfig) + -- portOpen <- liftIO $ checkPort host port shutdownVar <- liftIO newEmptyMVar - forkCheckers $ scottyT (fromIntegral port) getResponse (restServer shutdownVar) + forkCheckers $ handleIOError ioErrorHandler $ scottyOptsT (restOptions host (fromIntegral port)) getResponse (restServer shutdownVar) liftIO $ takeMVar shutdownVar -- REST thread should be able to write the response to Shutdown request. liftIO $ threadDelay (1000 * 1000) diff --git a/src/Core/Supervisor.hs b/src/Core/Supervisor.hs --- a/src/Core/Supervisor.hs +++ b/src/Core/Supervisor.hs @@ -51,6 +51,9 @@ import Rules.Canadian import Rules.Spancirety import Rules.Diagonal +import Rules.Czech +import Rules.Turkish +import Rules.Armenian -- | Request for new game creation data NewGameRq = NewGameRq { @@ -69,6 +72,9 @@ data AttachAiRq = AttachAiRq String Value deriving (Eq, Show, Generic) +data PdnInfoRq = PdnInfoRq String T.Text + deriving (Eq, Show, Generic) + -- | Response to the client. -- Contains payload and list of notification messages. data Response = Response RsPayload [Notify] @@ -83,7 +89,9 @@ | PollRs [Notify] | LobbyRs [Game] | NotationRs BoardSize BoardOrientation [(Label, Notation)] + | TopologyRs BoardTopology | StateRs BoardRep GameStatus Side + | PdnInfoRs PdnInfo | HistoryRs [HistoryRecordRep] | PossibleMovesRs [MoveRep] | MoveRs BoardRep @@ -115,7 +123,11 @@ ("brazilian", SomeRules brazilian), ("canadian", SomeRules canadian), ("spancirety", SomeRules spancirety), - ("diagonal", SomeRules diagonal)] + ("diagonal", SomeRules diagonal), + ("czech", SomeRules czech), + ("turkish", SomeRules turkish), + ("armenian", SomeRules armenian) + ] -- | Select rules by client request. selectRules :: NewGameRq -> Maybe SomeRules @@ -137,6 +149,22 @@ Left _ -> Nothing Right gr -> rulesFromTags (grTags gr) +selectRules' :: String -> Maybe SomeRules +selectRules' name = selectRules $ NewGameRq { + rqRules = name, + rqRulesParams = Null, + rqPdn = Nothing, + rqBoard = Nothing, + rqFen = Nothing, + rqPrevBoard = Nothing + } + +withRules :: String -> (forall rules. GameRules rules => rules -> a) -> a +withRules name fn = + case selectRules' name of + Just (SomeRules rules) -> fn rules + _ -> error "unknown rules" + -- | List of supported AI implementations supportedAis :: [(String, SomeRules -> SomeAi)] supportedAis = [("default", \(SomeRules rules) -> SomeAi (AlphaBeta def rules (dfltEvaluator rules)))] @@ -252,15 +280,6 @@ Right result -> return result Left err -> throwError err --- | Get game by Id -getGame :: GameId -> Checkers Game -getGame gameId = do - var <- askSupervisor - st <- liftIO $ atomically $ readTVar var - case M.lookup gameId (ssGames st) of - Just game -> return game - Nothing -> throwError $ NoSuchGame gameId - -- | Get game rules by game Id getRules :: GameId -> Checkers SomeRules getRules gameId = do @@ -437,6 +456,16 @@ _ -> return board +resetAiStorageG :: GameId -> Side -> Checkers () +resetAiStorageG gameId side = do + game <- getGame gameId + case getPlayer game side of + AI ai -> do + rules <- getRules gameId + withAiStorage rules ai $ \storage -> do + resetAiStorage ai storage + _ -> fail "User is not an AI" + aiDrawRequest :: GameId -> Side -> Checkers (Maybe Bool) aiDrawRequest gameId side = do game <- getGame gameId @@ -513,6 +542,20 @@ orientation = boardOrientation rules in (size, orientation, notation) +getTopology :: String -> Checkers BoardTopology +getTopology rname = do + var <- askSupervisor + let Just someRules = select supportedRules + result = process someRules + return result + + where + select [] = Nothing + select ((name, rules) : rest) + | name == rname = Just rules + | otherwise = select rest + + process (SomeRules rules) = boardTopology rules getPlayer :: Game -> Side -> Player getPlayer game First = fromJust $ gPlayer1 game diff --git a/src/Core/Types.hs b/src/Core/Types.hs --- a/src/Core/Types.hs +++ b/src/Core/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} module Core.Types where import Control.Monad.Reader @@ -16,15 +17,18 @@ import Control.Monad.Metrics as Metrics import Control.Concurrent import Control.Concurrent.STM +import Control.Exception as E (try) import Data.List import Data.Array.Unboxed +import qualified Data.Vector as V import qualified Data.Map as M import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS +import Data.Array.IArray as A import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder.Int as Builder -import qualified STMContainers.Map as SM +import qualified StmContainers.Map as SM import Data.Text.Format.Heavy import Data.Dynamic import Data.Aeson (Value) @@ -39,6 +43,7 @@ import System.Log.Heavy import System.Log.Heavy.TH import System.Clock +import GHC.Exts (Constraint) import Debug.Trace (traceEventIO) @@ -139,7 +144,11 @@ aUpLeft :: Maybe Address, aUpRight :: Maybe Address, aDownLeft :: Maybe Address, - aDownRight :: Maybe Address + aDownRight :: Maybe Address, + aUp :: Maybe Address, + aRight :: Maybe Address, + aDown :: Maybe Address, + aLeft :: Maybe Address } deriving (Typeable) @@ -174,9 +183,10 @@ , bSecondMen :: LabelSet , bFirstKings :: LabelSet , bSecondKings :: LabelSet + , bFirstAttacked :: LabelSet + , bSecondAttacked :: LabelSet -- , boardCounts :: BoardCounts , bSize :: {-# UNPACK #-} ! BoardSize - , boardKey :: BoardKey , boardHash :: {-# UNPACK #-} ! BoardHash , randomTable :: ! RandomTable } @@ -232,6 +242,11 @@ class RandomTableProvider p where getRandomTable :: p -> RandomTable +data DummyRandomTableProvider = DummyRandomTableProvider + +instance RandomTableProvider DummyRandomTableProvider where + getRandomTable _ = A.listArray ((1,0), (4, 16*16-1)) $ replicate (4*16*16) 0 + type TBoardMap a = SM.Map BoardHash a -- | Direction on the board. @@ -239,6 +254,7 @@ data BoardDirection = UpLeft | UpRight | DownLeft | DownRight + | Up | ToRight | Down | ToLeft deriving (Eq, Generic, Typeable) instance Show BoardDirection where @@ -246,6 +262,10 @@ show UpRight = "UR" show DownLeft = "DL" show DownRight = "DR" + show Up = "U" + show ToRight = "R" + show Down = "D" + show ToLeft = "L" -- | Direction from a point of view of a player. -- For example, for white, B2 is at ForwardRight of A1; @@ -253,6 +273,7 @@ data PlayerDirection = ForwardLeft | ForwardRight | BackwardLeft | BackwardRight + | Forward | PRight | Backward | PLeft deriving (Eq, Ord, Generic, Typeable) instance Show PlayerDirection where @@ -260,6 +281,10 @@ show ForwardRight = "FR" show BackwardLeft = "BL" show BackwardRight = "BR" + show Forward = "F" + show PRight = "R" + show Backward = "B" + show PLeft = "L" -- | One step of the move is a movement of piece -- from one field to it's neighbour. At that moment @@ -356,12 +381,16 @@ data BoardRep = BoardRep [(Label, Piece)] deriving (Eq, Ord, Show, Typeable) +boardRepLen :: BoardRep -> Int +boardRepLen (BoardRep lst) = length lst + -- | More convinient format for game rules to specify -- which moves are possible data PossibleMove = PossibleMove { pmBegin :: ! Address , pmEnd :: Address , pmVictims :: [Address] -- ^ list of captured fields + , pmVictimsCount :: Int , pmMove :: Move , pmPromote :: ! Bool -- ^ is there any promotion in the move , pmResult :: ! [MoveAction] @@ -387,7 +416,8 @@ -- | The primitive action that can take place during the move data MoveAction = Take ! Address -- ^ Lift the piece from the board (at the beginning of the move) - | RemoveCaptured ! Address -- ^ Remove the piece that was captured (should be performed at the end of the move) + | MarkCaptured ! Address -- ^ Remove the piece that was captured (should be performed at the end of the move) + | RemoveCaptured ! Address -- ^ Remove the piece that was captured - immediately | Put ! Address ! Piece -- ^ Put the piece to the board (at the end of the move) deriving (Eq, Ord, Show, Typeable) @@ -395,15 +425,27 @@ boardOrientation :: a -> BoardOrientation boardOrientation _ = FirstAtBottom +data BoardTopology = + Diagonal + | Orthogonal + | DiagonalAndOrthogonal + deriving (Eq, Show, Typeable, Generic) + +class HasTopology a where + boardTopology :: a -> BoardTopology + -- | Interface of game rules -class (Typeable g, Show g, HasBoardOrientation g) => GameRules g where +class (Typeable g, Show g, HasBoardOrientation g, HasTopology g, VectorEvaluator (EvaluatorForRules g)) => GameRules g where + type EvaluatorForRules g -- | Initial board with initial pieces position initBoard :: SupervisorState -> g -> Board -- | Size of board used boardSize :: g -> BoardSize - dfltEvaluator :: g -> SomeEval + initPiecesCount :: g -> Int + dfltEvaluator :: g -> EvaluatorForRules g + boardNotation :: g -> Label -> Notation parseNotation :: g -> Notation -> Either String Label @@ -413,7 +455,7 @@ mobilityScore g side board = length $ possibleMoves g side board updateRules :: g -> Value -> g - getGameResult :: g -> Board -> Maybe GameResult + getGameResult :: g -> Board -> Side -> Maybe GameResult rulesName :: g -> String pdnId :: g -> String @@ -432,6 +474,8 @@ type ScoreBase = Int16 +-- note: if I try to make fields of this structure strict and unpacked, +-- processing time increases! data Score = Score { sNumeric :: ScoreBase , sPositional :: ScoreBase @@ -443,10 +487,10 @@ instance Binary Score scoreBound :: ScoreBase -scoreBound = 256 +scoreBound = 8*512 maxPieces :: ScoreBase -maxPieces = 30 +maxPieces = 16*5 win :: Score win = Score maxPieces scoreBound @@ -498,6 +542,9 @@ prevScore :: Score -> Score prevScore (Score n p) = Score n (safeMinus scoreBound p 1) +scoreValue :: Score -> ScoreBase +scoreValue (Score n p) = scoreBound * n + p + instance Show Score where show (Score n p) = show n ++ "/" ++ show p @@ -517,7 +564,12 @@ updateEval :: e -> Value -> e updateEval e _ = e -data SomeEval = forall e. Evaluator e => SomeEval e +class Evaluator e => VectorEvaluator e where + type VectorEvaluatorSupport e rules :: Constraint + evalToVector :: e -> V.Vector Double + evalFromVector :: VectorEvaluatorSupport e rules => rules -> V.Vector Double -> e + +data SomeEval = forall e. VectorEvaluator e => SomeEval e deriving (Typeable) instance Show SomeEval where @@ -534,6 +586,8 @@ createAiStorage :: ai -> Checkers (AiStorage ai) saveAiStorage :: ai -> AiStorage ai -> Checkers () + resetAiStorage :: ai -> AiStorage ai -> Checkers () + aiName :: ai -> String updateAi :: ai -> Value -> ai @@ -545,8 +599,15 @@ decideDrawRequest :: ai -> AiStorage ai -> Side -> Board -> Checkers Bool decideDrawRequest _ _ _ _ = return True +class GameAi ai => VectorAi ai where + type VectorAiSupport ai rules :: Constraint + aiToVector :: ai -> V.Vector Double + aiFromVector :: VectorAiSupport ai rules => rules -> V.Vector Double -> ai + data SomeAi = forall ai. GameAi ai => SomeAi ai +data SomeVectorAi rules = forall ai. (VectorAi ai, VectorAiSupport ai rules) => SomeVectorAi ai + instance Show SomeAi where show (SomeAi ai) = show ai @@ -658,15 +719,17 @@ -- to supervisor's state, we have to put it into TVar type SupervisorHandle = TVar SupervisorState +type Depth = Int8 + data AiConfig = AiConfig { aiThreads :: Int , aiLoadCache :: Bool , aiStoreCache :: Bool - , aiUseCacheMaxDepth :: Int - , aiUseCacheMaxPieces :: Int - , aiUseCacheMaxDepthPlus :: Int - , aiUseCacheMaxDepthMinus :: Int - , aiUpdateCacheMaxDepth :: Int + , aiUseCacheMaxDepth :: Depth + , aiUseCacheMaxPieces :: Depth + , aiUseCacheMaxDepthPlus :: Depth + , aiUseCacheMaxDepthMinus :: Depth + , aiUpdateCacheMaxDepth :: Depth , aiUpdateCacheMaxPieces :: Int } deriving (Show, Typeable, Generic) @@ -721,13 +784,17 @@ NotYourTurn | NotAllowedMove | NoSuchMoveError + | NoSuchMoveExt String Side BoardRep [MoveRep] | AmbigousMoveError [MoveRep] + | AmbigousPdnInstruction String + | AmbigousPdnMove String String BoardRep | NothingToUndo | NoSuchGame GameId | NoSuchUserInGame | UserNameAlreadyUsed | InvalidGameStatus GameStatus GameStatus -- ^ Expected, actual | TimeExhaused + | UnknownRules | InvalidBoard String | Unhandled String deriving (Eq, Show, Typeable, Generic) @@ -740,6 +807,9 @@ } deriving (Applicative, Functor, Monad, MonadIO, MonadReader CheckersState, MonadError Error, MonadThrow, MonadCatch, MonadMask) +instance MonadFail Checkers where + fail msg = throwError (Unhandled msg) + runCheckersT :: Checkers a -> CheckersState -> IO (Either Error a) runCheckersT actions st = runReaderT (runExceptT $ runCheckers actions) st @@ -759,6 +829,16 @@ r <- actions return $ Right r) `catchError` (\e -> return $ Left e) +-- tryIO :: Checkers a -> Checkers (Either Error a) +-- tryIO actions = do +-- st <- ask +-- rr <- liftIO $ E.try $ runCheckersT actions st +-- case rr of +-- Right (Right a) -> return $ Right a +-- Right (Left err) -> return $ Left err +-- Left (Right a) -> return $ Left $ Unhandled "IO error?" +-- Left (Left err) -> return $ Left err + askSupervisor :: Checkers SupervisorHandle askSupervisor = asks csSupervisor @@ -819,7 +899,7 @@ repeatTimed' :: forall m a b. (MonadIO m, HasLogging m) => String -> Int -> (a -> m (b, Maybe a)) -> a -> m b repeatTimed' label seconds action x = do - start <- liftIO $ getTime Monotonic + start <- liftIO $ getTime RealtimeCoarse run 0 x start where run :: Int -> a -> TimeSpec -> m b @@ -827,7 +907,7 @@ (result, mbX') <- action x case mbX' of Just x' -> do - time2 <- liftIO $ getTime Monotonic + time2 <- liftIO $ getTime RealtimeCoarse let delta = time2 - start if sec delta >= fromIntegral seconds then do diff --git a/src/Formats/Compact.hs b/src/Formats/Compact.hs --- a/src/Formats/Compact.hs +++ b/src/Formats/Compact.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import Text.Megaparsec hiding (Label, State) import Text.Megaparsec.Char -import Text.Megaparsec.Error (parseErrorPretty) +import Text.Megaparsec.Error (errorBundlePretty) import qualified Data.Text.IO as TIO import Text.Printf @@ -75,7 +75,7 @@ text <- TIO.readFile path forM (T.lines text) $ \line -> do case evalState (runParserT pGame path line) Nothing of - Left err -> fail $ parseErrorPretty err + Left err -> fail $ errorBundlePretty err Right game -> return game findMove :: Side -> SemiMove -> Board -> Either String PossibleMove diff --git a/src/Formats/Fen.hs b/src/Formats/Fen.hs --- a/src/Formats/Fen.hs +++ b/src/Formats/Fen.hs @@ -9,7 +9,7 @@ import Data.Monoid ((<>)) import Text.Megaparsec hiding (Label) import Text.Megaparsec.Char -import Text.Megaparsec.Error (parseErrorPretty) +import Text.Megaparsec.Error (errorBundlePretty) import Core.Types import Core.Board @@ -56,7 +56,7 @@ parseFen :: SomeRules -> T.Text -> Either String (Side, BoardRep) parseFen rules text = case evalState (runParserT (pFen rules) "FEN" text) Nothing of - Left err -> Left $ parseErrorPretty err + Left err -> Left $ errorBundlePretty err Right fen -> Right (fenNextMove fen, fenToBoardRep fen) boardToFen :: Side -> Board -> Fen diff --git a/src/Formats/Pdn.hs b/src/Formats/Pdn.hs --- a/src/Formats/Pdn.hs +++ b/src/Formats/Pdn.hs @@ -14,7 +14,7 @@ import qualified Data.Text as T import Text.Megaparsec hiding (Label, State) import Text.Megaparsec.Char -import Text.Megaparsec.Error (parseErrorPretty) +import Text.Megaparsec.Error (errorBundlePretty) import qualified Data.Text.IO as TIO import Text.Printf @@ -173,6 +173,11 @@ "43" -> return $ SomeRules simple _ -> fail $ "Unsupported rules: " ++ n +titleFromTags :: [Tag] -> Maybe T.Text +titleFromTags [] = Nothing +titleFromTags (Event title:_) = Just title +titleFromTags (_: rest) = titleFromTags rest + rulesFromTags :: [Tag] -> Maybe SomeRules rulesFromTags [] = Nothing rulesFromTags (GameType r:_) = Just r @@ -193,17 +198,17 @@ parsePdn :: Maybe SomeRules -> T.Text -> Either String GameRecord parsePdn dfltRules text = case evalState (runParserT (pGame dfltRules) "" text) dfltRules of - Left err -> Left $ parseErrorPretty err + Left err -> Left $ errorBundlePretty err Right pdn -> Right pdn parsePdnFile :: Maybe SomeRules -> FilePath -> IO [GameRecord] parsePdnFile dfltRules path = do text <- TIO.readFile path case evalState (runParserT ((pGame dfltRules) `sepEndBy` space1) path text) dfltRules of - Left err -> fail $ parseErrorPretty err + Left err -> fail $ errorBundlePretty err Right pdn -> return pdn -parseMoveRec :: GameRules rules => rules -> Side -> Board -> SemiMoveRec -> Move +parseMoveRec :: GameRules rules => rules -> Side -> Board -> SemiMoveRec -> Either Error Move parseMoveRec rules side board rec = let moves = possibleMoves rules side board passedFields m = nonCaptureLabels rules side board (pmMove m) @@ -217,11 +222,9 @@ (not $ null $ pmVictims m) && smrLabels `isSubsequenceOf` passedFields m in case filter suits moves of - [m] -> pmMove m - [] -> error $ printf "no such move: %s; side: %s; board: %s; possible: %s" - (show rec) (show side) (show board) (show $ map passedFields moves) - ms -> error $ printf "ambigous move: %s; candidates are: %s; board: %s" - (show rec) (show ms) (show board) + [m] -> return $ pmMove m + [] -> Left $ NoSuchMoveExt (show rec) side (boardRep board) (map (moveRep rules side . pmMove) moves) + ms -> Left $ AmbigousPdnMove (show rec) (show ms) (boardRep board) fenFromTags :: [Tag] -> Maybe Fen fenFromTags [] = Nothing @@ -298,37 +301,39 @@ state = execState (forM_ instructions interpret) initState in map M.elems $ M.elems $ isVariants state -loadPdn :: SupervisorState -> GameRecord -> Board -loadPdn rnd r = +loadPdn :: SupervisorState -> GameRecord -> Either Error Board +loadPdn rnd r = do let findRules [] = Nothing findRules (GameType rules:_) = Just rules findRules (_:rest) = findRules rest - withRules :: SomeRules -> Board - withRules some@(SomeRules rules) = + withRules :: SomeRules -> Either Error Board + withRules some@(SomeRules rules) = do let board0 = initBoardFromTags rnd some (grTags r) - go board [] = board - go board0 (moveRec : rest) = - let board1 = case mrFirst moveRec of - Just rec -> let move1 = parseMoveRec rules First board0 rec - (board1,_,_) = applyMove rules First move1 board0 - in board1 - Nothing -> board0 - in case mrSecond moveRec of - Nothing -> board1 - Just rec -> - let move2 = parseMoveRec rules Second board1 rec - (board2,_,_) = applyMove rules Second move2 board1 - in go board2 rest + go :: Board -> [MoveRec] -> Either Error Board + go board [] = return board + go board0 (moveRec : rest) = do + board1 <- case mrFirst moveRec of + Just rec -> do + move1 <- parseMoveRec rules First board0 rec + let (board1,_,_) = applyMove rules First move1 board0 + return board1 + Nothing -> return board0 + case mrSecond moveRec of + Nothing -> return board1 + Just rec -> do + move2 <- parseMoveRec rules Second board1 rec + let (board2,_,_) = applyMove rules Second move2 board1 + go board2 rest - in case instructionsToMoves (grMoves r) of - [moves] -> go board0 moves - vars -> error $ "multiple variants: " ++ show vars + case instructionsToMoves (grMoves r) of + [moves] -> go board0 moves + vars -> Left $ AmbigousPdnInstruction $ show vars - in case findRules (grTags r) of - Nothing -> error "rules are not specified" - Just rules -> withRules rules + case findRules (grTags r) of + Nothing -> Left $ Unhandled "rules are not specified" + Just rules -> withRules rules moveToInstructions :: Int -> MoveRec -> [Instruction] moveToInstructions n move = @@ -411,4 +416,20 @@ showTag (FEN fen) = T.pack (printf "[FEN \"%s\"]" (showFen (boardSize rules) fen)) showTag (GameType _) = T.pack (printf "[GameType \"%s\"]" (pdnId rules)) showTag (Unknown tag text) = T.pack (printf "[%s \"%s\"]" tag text) + +pdnInfo :: GameRecord -> PdnInfo +pdnInfo gr = PdnInfo { + pdnTitle = titleFromTags (grTags gr) + , pdnRules = someRulesName (rulesFromTags $ grTags gr) + , pdnResult = grResult gr + , pdnNextMove = getNextMove (last $ head $ instructionsToMoves $ grMoves gr) + } + where + someRulesName Nothing = Nothing + someRulesName (Just (SomeRules rules)) = Just (rulesName rules) + + getNextMove r = + case mrSecond r of + Nothing -> Second + _ -> First diff --git a/src/Formats/Types.hs b/src/Formats/Types.hs --- a/src/Formats/Types.hs +++ b/src/Formats/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} module Formats.Types where @@ -10,6 +11,8 @@ import Data.Typeable import Text.Megaparsec hiding (Label, State) import Data.Void +import Data.Aeson +import GHC.Generics import Core.Types @@ -75,6 +78,14 @@ , grResult :: Maybe GameResult } deriving (Show, Typeable) + +data PdnInfo = PdnInfo { + pdnTitle :: Maybe T.Text + , pdnRules :: Maybe String + , pdnResult :: Maybe GameResult + , pdnNextMove :: Side + } + deriving (Eq, Show, Typeable, Generic) data Fen = Fen { fenNextMove :: Side diff --git a/src/Learn.hs b/src/Learn.hs --- a/src/Learn.hs +++ b/src/Learn.hs @@ -47,13 +47,13 @@ let board1 = case mrFirst moveRec of Nothing -> board0 Just rec -> - let move1 = parseMoveRec rules First board0 rec + let Right move1 = parseMoveRec rules First board0 rec (board1, _, _) = applyMove rules First move1 board0 in board1 board2 = case mrSecond moveRec of Nothing -> board1 Just rec -> - let move2 = parseMoveRec rules Second board1 rec + let Right move2 = parseMoveRec rules Second board1 rec (board2, _, _) = applyMove rules Second move2 board1 in board2 in go (board1 : boards) board2 mbResult rest @@ -89,7 +89,7 @@ case mrFirst moveRec of Nothing -> return (board0, [], score0) Just rec -> do - let move1 = parseMoveRec rules First board0 rec + let Right move1 = parseMoveRec rules First board0 rec if move1 `elem` map pmMove predicted then Metrics.increment "learn.hit" else Metrics.increment "learn.miss" @@ -99,7 +99,7 @@ case mrSecond moveRec of Nothing -> return (score2, board0 : board1 : boards) Just rec -> do - let move2 = parseMoveRec rules Second board1 rec + let Right move2 = parseMoveRec rules Second board1 rec if move2 `elem` map pmMove predict2 then Metrics.increment "learn.hit" else Metrics.increment "learn.miss" @@ -125,7 +125,7 @@ learnPdn :: (GameRules rules, Evaluator eval) => AlphaBeta rules eval -> FilePath -> Checkers () learnPdn ai@(AlphaBeta params rules eval) path = do - cache <- loadAiCache scoreMove ai + cache <- loadAiCache scoreMoveGroup ai pdn <- liftIO $ parsePdnFile (Just $ SomeRules rules) path let n = length pdn forM_ (zip [1.. ] pdn) $ \(i, gameRec) -> do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,22 +2,32 @@ {-# LANGUAGE ViewPatterns #-} module Main where +import Control.Monad import Control.Monad.Reader import Control.Concurrent.STM import Data.Default +import qualified Data.Map as M +import qualified Data.ByteString.Lazy.Char8 as C8 +import qualified Data.Aeson as Aeson import System.Log.Heavy import Options.Applicative +import Text.Printf import Core.Types import Core.Board +import AI import AI.AlphaBeta.Types import AI.AlphaBeta.Persistent import Core.Rest import Core.Checkers import Core.CmdLine +import Core.Supervisor (withRules) +import Core.Evaluator import Learn +import Battle import Rules.Russian +import Rules.Spancirety -- let stdout = LoggingSettings $ filtering defaultLogFilter defStdoutSettings -- debug = LoggingSettings $ Filtering (\m -> lmLevel m == trace_level) ((defFileSettings "trace.log") {lsFormat = "{time} {source} [{thread}]: {message}\n"}) @@ -50,23 +60,68 @@ withLogContext (LogContextFrame [] (include defaultLogFilter)) $ learnPdn ai path - ["dump", path] -> checkDataFile' path + ["battle", rulesName, path1, path2] -> do + withRules rulesName $ \rules -> do + ai1 <- loadAi "default" rules path1 + ai2 <- loadAi "default" rules path2 + withCheckers cmd $ + withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do + runBattle (SomeRules rules) (SomeAi ai1) (SomeAi ai2) "battle.pdn" + return () + + ["match", rulesName, ns, path1, path2] -> do + withRules rulesName $ \rules -> do + let n = read ns + ai1 <- loadAi "default" rules path1 + ai2 <- loadAi "default" rules path2 + putStrLn $ "AI1: " ++ show ai1 + putStrLn $ "AI2: " ++ show ai2 + withCheckers cmd $ + withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do + runMatch (SomeRules rules) (SomeAi ai1) (SomeAi ai2) n + return () + + ("tournament": matches : games : paths) -> do + let rules = russian + nMatches = read matches + nGames = read games + ais <- forM paths $ \path -> loadAi "default" rules path + withCheckers cmd $ + withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do + runTournament rules ais nMatches nGames + return () + + ("genetics": generations : size : best : paths) -> do + let rules = spancirety + nGenerations = read generations + generationSize = read size + nBest = read best + ais <- forM paths $ \path -> loadAi "default" rules path + withCheckers cmd $ + withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do + result <- runGenetics rules nGenerations generationSize nBest ais + forM_ result $ \ai -> liftIO $ C8.putStrLn $ Aeson.encode ai + return () + + ["generate", ns, deltas, path] -> do + let n = read ns + delta = read deltas + generateAiVariations n delta path + + -- ["dump", path] -> checkDataFile' path ["load", path] -> do idx <- loadIndexIO path print path ["test"] -> do withCheckers cmd $ do - sh <- asks csSupervisor - st <- liftIO $ atomically $ readTVar sh - let b = movePiece' "c3" "e5" $ board8 st - b' = flipBoard b - b'' = flipBoard b' - liftIO $ do - print b - print b' - print b'' - print (b == b'') + let rules = russian + cache = seCache $ defaultEvaluator rules + forM_ (M.assocs cache) $ \(addr, sed) -> do + liftIO $ printf "%s => %s, %s\n" + (show $ aLabel addr) + (show $ weightForSide First $ sedCenter sed) + (show $ weightForSide Second $ sedCenter sed) -- main :: IO () -- main = do diff --git a/src/Rules/Armenian.hs b/src/Rules/Armenian.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Armenian.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Rules.Armenian ( + Armenian, armenian, armenianBase + ) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic + +newtype Armenian = Armenian GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Armenian where + show = rulesName + +instance HasTopology Armenian where + boardTopology _ = DiagonalAndOrthogonal + +instance SimpleEvaluatorSupport Armenian where + getBackDirections _ = [Backward] + getForwardDirections _ = [ForwardLeft, Forward, ForwardRight] + getAllAddresses r = addresses8 r + +instance GameRules Armenian where + type EvaluatorForRules Armenian = SimpleEvaluator + + initBoard rnd r = + let board = buildBoard rnd r (boardOrientation r) (8, 8) + labels1 = ["a2", "b2", "c2", "d2", "e2", "f2", "g2", "h2", + "a3", "b3", "c3", "d3", "e3", "f3", "g3", "h3"] + labels2 = ["a7", "b7", "c7", "d7", "e7", "f7", "g7", "h7", + "a6", "b6", "c6", "d6", "e6", "f6", "g6", "h6"] + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + initPiecesCount _ = 32 + + boardSize _ = (8, 8) + + dfltEvaluator r = (defaultEvaluator r) { + seKingCoef = 4, + seHelpedKingCoef = 5, + seOppositeSideWeight = 5, + seMobilityWeight = 4, + seBackedWeight = 1, + seBorderManWeight = 0 + } + + boardNotation _ = chessNotation + + parseNotation _ = parseChessNotation + + rulesName _ = "armenian" + + possibleMoves (Armenian rules) side board = gPossibleMoves rules side board + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "44" + +armenianBase :: GenericRules -> GenericRules +armenianBase = + let rules this = (abstractRules this) { + gManSimpleMoveDirections = [PLeft, ForwardLeft, Forward, ForwardRight, PRight] + , gManCaptureDirections = [PLeft, Forward, PRight] + , gKingCaptureDirections = [Backward, PLeft, Forward, PRight] + , gKingSimpleMoveDirections = [Backward, BackwardLeft, PLeft, ForwardLeft, + Forward, ForwardRight, PRight, BackwardRight] + , gManCaptures = manCaptures this + , gCaptureMax = True + , gRemoveCapturedImmediately = False + } + in rules + +armenian :: Armenian +armenian = Armenian $ + let rules = armenianBase rules + in rules + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let captures = gPieceCaptures1 rules ct + -- when last horizontal reached, pass promoted piece to + -- next moves check; so it will continue capture as a king + -- if it can + nextMoves pm = genericNextMoves rules ct True pm + in concat $ flip map captures $ \capture -> + let [move1] = translateCapture ctPiece capture + moves2 = nextMoves move1 + in if null moves2 + then [move1] + else [catPMoves move1 move2 | move2 <- moves2] + diff --git a/src/Rules/Brazilian.hs b/src/Rules/Brazilian.hs --- a/src/Rules/Brazilian.hs +++ b/src/Rules/Brazilian.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Rules.Brazilian (Brazilian, brazilian) where import Data.Typeable @@ -15,15 +16,25 @@ newtype Brazilian = Brazilian GenericRules deriving (Typeable, HasBoardOrientation) +instance HasTopology Brazilian where + boardTopology _ = Diagonal + +instance SimpleEvaluatorSupport Brazilian where + getAllAddresses r = addresses8 r + instance Show Brazilian where show = rulesName instance GameRules Brazilian where + type EvaluatorForRules Brazilian = SimpleEvaluator + boardSize _ = (8, 8) initBoard rnd _ = initBoard rnd russian - dfltEvaluator r = SomeEval $ defaultEvaluator r + initPiecesCount _ = 24 + + dfltEvaluator r = defaultEvaluator r boardNotation _ = boardNotation international parseNotation _ = parseNotation international diff --git a/src/Rules/Canadian.hs b/src/Rules/Canadian.hs --- a/src/Rules/Canadian.hs +++ b/src/Rules/Canadian.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Rules.Canadian (Canadian, canadian) where import Data.Typeable @@ -17,11 +18,19 @@ instance Show Canadian where show = rulesName +instance HasTopology Canadian where + boardTopology _ = Diagonal + +instance SimpleEvaluatorSupport Canadian where + getAllAddresses r = addresses12 r + instance GameRules Canadian where + type EvaluatorForRules Canadian = SimpleEvaluator + boardSize _ = (12, 12) initBoard rnd r = - let board = buildBoard rnd (boardOrientation r) (12, 12) + let board = buildBoard rnd r (boardOrientation r) (12, 12) labels1 = ["a1", "c1", "e1", "g1", "i1", "k1", "b2", "d2", "f2", "h2", "j2", "l2", "a3", "c3", "e3", "g3", "i3", "k3", @@ -36,7 +45,9 @@ in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board - dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} + initPiecesCount _ = 60 + + dfltEvaluator r = (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} boardNotation r = numericNotation (boardSize r) diff --git a/src/Rules/Czech.hs b/src/Rules/Czech.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Czech.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Rules.Czech (Czech, czech) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic +import Rules.Russian as Russian + +newtype Czech = Czech GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Czech where + show = rulesName + +instance HasTopology Czech where + boardTopology _ = Core.Types.Diagonal + +instance SimpleEvaluatorSupport Czech where + getAllAddresses r = addresses8 r + +instance GameRules Czech where + type EvaluatorForRules Czech = SimpleEvaluator + pdnId _ = "29" + rulesName _ = "czech" + + boardSize _ = (8, 8) + + initBoard rnd _ = initBoard rnd Russian.russian + + initPiecesCount _ = 24 + + dfltEvaluator r = defaultEvaluator r + + boardNotation _ = boardNotation russian + + parseNotation _ = parseNotation russian + + possibleMoves (Czech rules) side board = gPossibleMoves rules side board + mobilityScore (Czech rules) side board = gMobilityScore rules side board + + updateRules r _ = r + + getGameResult = genericGameResult + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let side = pieceSide ctPiece + captures = gPieceCaptures1 rules ct + -- when last horizontal reached, pass non-promoted piece + -- to next moves check; man cant capture backwards, so + -- the piece will stop there. + nextMoves pm = genericNextMoves rules ct False pm + in concat $ flip map captures $ \capture -> + let [move1] = translateCapture ctPiece capture + moves2 = nextMoves move1 + in if null moves2 + then [move1] + else [catPMoves move1 move2 | move2 <- moves2] + +selectMoves :: GenericRules -> Side -> Board -> MoveDecisionInput -> [PossibleMove] +selectMoves _ side board (MoveDecisionInput {..}) = + if mdiHasKingCaptures + then mdiKingCaptures + else if mdiHasMenCaptures + then mdiMenCaptures + else mdiKingSimpleMoves ++ mdiMenSimpleMoves + +czechBase :: GenericRules -> GenericRules +czechBase = + let rules this = (abstractRules this) { + gManCaptureDirections = [ForwardLeft, ForwardRight], + gSelectMoves = selectMoves this, + gManCaptures = manCaptures this + } + in rules + +czech :: Czech +czech = Czech $ + let rules = czechBase rules + in rules + diff --git a/src/Rules/Diagonal.hs b/src/Rules/Diagonal.hs --- a/src/Rules/Diagonal.hs +++ b/src/Rules/Diagonal.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Rules.Diagonal (Diagonal, diagonal) where +{-# LANGUAGE TypeFamilies #-} +module Rules.Diagonal (DiagonalRussian, diagonal) where import Data.Typeable @@ -11,15 +12,22 @@ import Rules.Russian import Rules.Generic -newtype Diagonal = Diagonal GenericRules +newtype DiagonalRussian = DiagonalRussian GenericRules deriving (Typeable, HasBoardOrientation) -instance Show Diagonal where +instance Show DiagonalRussian where show = rulesName -instance GameRules Diagonal where +instance HasTopology DiagonalRussian where + boardTopology _ = Core.Types.Diagonal + +instance SimpleEvaluatorSupport DiagonalRussian where + getAllAddresses r = addresses8 r + +instance GameRules DiagonalRussian where + type EvaluatorForRules DiagonalRussian = SimpleEvaluator initBoard rnd r = - let board = buildBoard rnd (boardOrientation r) (8, 8) + let board = buildBoard rnd r (boardOrientation r) (8, 8) labels1 = ["c1", "e1", "g1", "d2", "f2", "h2", "e3", "g3", @@ -36,8 +44,10 @@ boardSize _ = (8, 8) - dfltEvaluator r = SomeEval $ defaultEvaluator r + initPiecesCount _ = 24 + dfltEvaluator r = defaultEvaluator r + boardNotation _ = boardNotation russian parseNotation _ = parseNotation russian @@ -53,8 +63,8 @@ pdnId _ = "42" -diagonal :: Diagonal -diagonal = Diagonal $ +diagonal :: DiagonalRussian +diagonal = DiagonalRussian $ let rules = russianBase rules in rules diff --git a/src/Rules/English.hs b/src/Rules/English.hs --- a/src/Rules/English.hs +++ b/src/Rules/English.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Rules.English (English (..), english) where import Data.Typeable @@ -19,19 +20,28 @@ instance Show English where show = rulesName +instance HasTopology English where + boardTopology _ = Diagonal + +instance SimpleEvaluatorSupport English where + getAllAddresses r = addresses8' r + instance GameRules English where + type EvaluatorForRules English = SimpleEvaluator boardSize _ = boardSize Russian.russian initBoard rnd r = - let board = buildBoard rnd (boardOrientation r) (boardSize r) + let board = buildBoard rnd r (boardOrientation r) (boardSize r) labels1 = line1labels ++ line2labels ++ line3labels labels2 = line8labels ++ line7labels ++ line6labels in setManyPieces' labels1 (Piece Man Second) $ setManyPieces' labels2 (Piece Man First) board + initPiecesCount _ = 24 + boardNotation r = numericNotation (boardSize r) parseNotation r = parseNumericNotation (boardSize r) - dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 2, seHelpedKingCoef = 3} + dfltEvaluator r = (defaultEvaluator r) {seKingCoef = 2, seHelpedKingCoef = 3} rulesName _ = "english" updateRules r _ = r @@ -68,6 +78,7 @@ pmBegin = src, pmEnd = dst, pmVictims = [], + pmVictimsCount = 0, pmMove = Move src [Step dir False False], pmPromote = False, pmResult = [Take src, Put dst piece] @@ -102,6 +113,7 @@ cInitSteps = 0, cFreeSteps = 1, cVictim = victimAddr, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, cDst = freeAddr, cPromote = isLastHorizontal side freeAddr }] diff --git a/src/Rules/Generic.hs b/src/Rules/Generic.hs --- a/src/Rules/Generic.hs +++ b/src/Rules/Generic.hs @@ -4,6 +4,7 @@ import Data.List import Data.Maybe +import qualified Data.IntMap as IM import Core.Types import Core.Board @@ -17,6 +18,7 @@ , 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 + , cRemoveVictimImmediately :: Bool , 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. @@ -33,6 +35,16 @@ , ctSource :: Address -- ^ Starting position of capture } +data MoveDecisionInput = MoveDecisionInput { + mdiHasMenCaptures :: Bool + , mdiHasKingCaptures :: Bool + , mdiMenCaptures :: [PossibleMove] + , mdiKingCaptures :: [PossibleMove] + , mdiMenSimpleMoves :: [PossibleMove] + , mdiKingSimpleMoves :: [PossibleMove] + } + deriving (Eq, Show) + -- | Initial capture state initState :: Piece -> Board -> Address -> CaptureState initState piece board src = CaptureState Nothing emptyLabelSet piece board src src @@ -45,6 +57,7 @@ , gPossibleCaptures1 :: Board -> Address -> [PossibleMove] , gManSimpleMoves :: Side -> Board -> Address -> [PossibleMove] , gKingSimpleMoves :: Side -> Board -> Address -> [PossibleMove] + , gSelectMoves :: Side -> Board -> MoveDecisionInput -> [PossibleMove] , gManCaptures :: CaptureState -> [PossibleMove] , gKingCaptures :: CaptureState -> [PossibleMove] , gPieceCaptures1 :: CaptureState -> [Capture] @@ -58,6 +71,7 @@ , gKingCaptureDirections :: [PlayerDirection] , gBoardOrientation :: BoardOrientation , gCaptureMax :: Bool + , gRemoveCapturedImmediately :: Bool } instance HasBoardOrientation GenericRules where @@ -69,9 +83,10 @@ pmBegin = src, pmEnd = dst, pmVictims = [victim], + pmVictimsCount = 1, pmMove = Move src (steps $ cFreeSteps capture), pmPromote = promote, - pmResult = [Take src, RemoveCaptured victim, Put dst piece'] + pmResult = [Take src, remove victim, Put dst piece'] }] where steps n = replicate (cInitSteps capture) (Step dir False False) ++ @@ -84,14 +99,24 @@ dst = cDst capture victim = cVictim capture piece' = if promote then promotePiece piece else piece - + remove = if cRemoveVictimImmediately capture + then RemoveCaptured + else MarkCaptured -freeFields :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Board -> (Int, [Address]) -freeFields rules side dir addr board = +freeFields :: HasBoardOrientation rules + => rules + -> Side + -> PlayerDirection + -> LabelSet + -> Bool + -> Address + -> Board + -> (Int, [Address]) +freeFields rules side dir captured allowStepCaptured 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 + Just a' -> if isFree a' board || (allowStepCaptured && aLabel a' `labelSetMember` captured) + then let (n, prev) = freeFields rules side dir captured allowStepCaptured a' board in (n+1, a' : prev) else (0, []) @@ -119,55 +144,54 @@ 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 + let manSimpleMoves = concatMap (gManSimpleMoves rules side board) (filter (manHasSimpleMoves rules side board) men) + kingSimpleMoves = concatMap (gKingSimpleMoves rules side board) kings + + men = myMenA side board + kings = myKingsA side board + anyManHasCaptures = any (manHasCaptures rules side board) men + menWithCaptures = filter (manHasCaptures rules side board) men + manCaptures = concatMap (manCaptures' rules side board) menWithCaptures + kingCaptures = concatMap (kingCaptures' rules side board) kings + haveKingCaptures = not (null kings) && not (null kingCaptures) + + input = MoveDecisionInput { + mdiHasMenCaptures = anyManHasCaptures + , mdiHasKingCaptures = haveKingCaptures + , mdiMenCaptures = manCaptures + , mdiKingCaptures = kingCaptures + , mdiMenSimpleMoves = manSimpleMoves + , mdiKingSimpleMoves = kingSimpleMoves + } + in gSelectMoves rules side board input + + selectMoves rules side board (MoveDecisionInput {..}) = + let haveCaptures = mdiHasMenCaptures || mdiHasKingCaptures + simpleMoves = mdiKingSimpleMoves ++ mdiMenSimpleMoves + captures = mdiKingCaptures ++ mdiMenCaptures + in if gCaptureMax rules then - if null captures + if not haveCaptures 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 + let maxVictims = maximum $ map pmVictimsCount captures + in filter (\c -> pmVictimsCount c == maxVictims) captures + else if haveCaptures + then captures + else simpleMoves --- 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 + kingPositionScore board (Label col row) = + let (nrows, ncols) = bSize board + crow = nrows `div` 2 + ccol = ncols `div` 2 + col' = min col (ncols - col - 1) + row' = min row (nrows - row - 1) + add = min ncols nrows + in fromIntegral $ (1 + add) + 2 * min row' col' 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) + sum (map (manSimpleMovesCount rules side board) (myMenA side board)) + + sum (map (kingPositionScore board) (myKings side board)) manCaptures' rules side board src = gManCaptures rules $ initState (Piece Man side) board src @@ -220,6 +244,7 @@ pmBegin = src, pmEnd = dst, pmVictims = [], + pmVictimsCount = 0, pmMove = move, pmPromote = promote, pmResult = [Take src, Put dst piece'] @@ -243,7 +268,14 @@ Nothing -> False Just dst -> isFree dst board else False + + allowStepOccupied rules addr captured + | gRemoveCapturedImmediately rules = aLabel addr `labelSetMember` captured + | otherwise = False + canCaptureA rules addr captured = + not (aLabel addr `labelSetMember` captured) + manCaptures1 rules (CaptureState {..}) = mapMaybe (check ctCurrent) $ filter allowedDir (gManCaptureDirections rules) where @@ -260,12 +292,13 @@ if isPieceAt victimAddr ctBoard (opposite side) then case myNeighbour rules side dir victimAddr of Nothing -> Nothing - Just freeAddr -> if isFree freeAddr ctBoard + Just freeAddr -> if isFree freeAddr ctBoard || allowStepOccupied rules freeAddr ctCaptured then Just $ Capture { cSrc = a, cDirection = dir, cInitSteps = 0, cVictim = victimAddr, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, cFreeSteps = 1, cDst = freeAddr, cPromote = isLastHorizontal side freeAddr @@ -290,7 +323,7 @@ case search dir ctCurrent of Nothing -> [] Just (victimAddr, initSteps) -> - case freeFields rules side dir victimAddr ctBoard of + case freeFields rules side dir ctCaptured (gRemoveCapturedImmediately rules) victimAddr ctBoard of (0,_) -> [] (nFree, fields) -> [mkCapture dir initSteps victimAddr freeSteps (fields !! (freeSteps-1)) | freeSteps <- [1 .. nFree]] @@ -301,22 +334,54 @@ cDirection = dir, cInitSteps = init, cVictim = victim, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, cFreeSteps = free, cDst = dst, cPromote = False } + -- Skip as many empty fields before piece to be captured, as we need search :: PlayerDirection -> Address -> Maybe (Address, Int) search dir a = + -- make one step in given direction case myNeighbour rules side dir a of + -- if there is no way in this direction (board border) - no capture possible Nothing -> Nothing + -- otherwise check piece Just a' -> case getPiece a' ctBoard of + -- empty field + -- check the field after this one Nothing -> case search dir a' of Nothing -> Nothing + -- found something Just (victimAddr, steps) -> Just (victimAddr, steps + 1) - Just p -> if isOpponentPiece side p && not (aLabel a' `labelSetMember` ctCaptured) - then Just (a', 0) - else Nothing + Just p -> + -- the field is not empty + if isOpponentPiece side p + then let capturedPiece = aLabel a' `labelSetMember` ctCaptured + skipCapturedPiece = gRemoveCapturedImmediately rules + in if skipCapturedPiece + -- In some (turkish) rules, pieces are removed from the field + -- during capture. So if we already have captured this piece + -- during this move, we must behave as there is no piece at all + -- at this field. + then if capturedPiece + -- there is opponent piece, but we have already captured it + -- (during this move). + -- Just make another step through this field as if it was empty. + then case search dir a' of + Nothing -> Nothing + Just (victimAddr, steps) -> Just (victimAddr, steps+1) + -- piece was not captured yet, we can capture it now. + else Just (a', 0) + -- More usual rules: pieces are removed only when capture is complete. + -- In this case, opponent piece that we already captured is an obstacle: + -- we cannot capture it another time and we cannot step at this field. + else if capturedPiece + then Nothing + else Just (a', 0) + -- it is our piece, no capture + else Nothing -- This is most popular implementation, which fits most rules -- except for english / checkers @@ -340,12 +405,13 @@ concatMap check (gKingSimpleMoveDirections rules) where check dir = - let (nFree,free) = freeFields rules side dir src board + let (nFree,free) = freeFields rules side dir emptyLabelSet False src board piece = Piece King side in [PossibleMove { pmBegin = src, pmEnd = free !! (n-1), pmVictims = [], + pmVictimsCount = 0, pmMove = Move src (replicate n (Step dir False False)), pmPromote = False, pmResult = [Take src, Put (free !! (n-1)) piece] @@ -373,6 +439,7 @@ , gPieceCaptures = pieceCaptures this , gManCaptures1 = manCaptures1 this , gManCaptures = error "gManCaptures has to be implemented in specific rules" + , gSelectMoves = selectMoves this , gCanCaptureFrom = canCaptureFrom this , gManSimpleMoveDirections = manSimpleMoveDirections this , gKingSimpleMoveDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight] @@ -380,6 +447,28 @@ , gKingCaptureDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight] , gBoardOrientation = orientation this , gCaptureMax = False + , gRemoveCapturedImmediately = False } in rules + +labels8 :: [Label] +labels8 = [Label col row | col <- [0..7], row <- [0..7], ((row+col) `mod` 2) == 0] + +addresses8 :: HasTopology rules => rules -> [Address] +addresses8 r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (8, 8) + +addresses8' :: HasTopology rules => rules -> [Address] +addresses8' r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r SecondAtBottom (8, 8) + +labels8full :: [Label] +labels8full = [Label col row | col <- [0..7], row <- [0..7]] + +labels10 :: [Label] +labels10 = [Label col row | col <- [0..9], row <- [0..9], ((row+col) `mod` 2) == 0] + +addresses10 :: HasTopology rules => rules -> [Address] +addresses10 r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (10, 10) + +addresses12 :: HasTopology rules => rules -> [Address] +addresses12 r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (12, 12) diff --git a/src/Rules/International.hs b/src/Rules/International.hs --- a/src/Rules/International.hs +++ b/src/Rules/International.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Rules.International (International, international, internationalBase) where import Data.Typeable @@ -20,11 +21,18 @@ instance Show International where show = rulesName +instance HasTopology International where + boardTopology _ = Diagonal + +instance SimpleEvaluatorSupport International where + getAllAddresses r = addresses10 r + instance GameRules International where + type EvaluatorForRules International = SimpleEvaluator boardSize _ = (10, 10) initBoard rnd r = - let board = buildBoard rnd (boardOrientation r) (10, 10) + let board = buildBoard rnd r (boardOrientation r) (10, 10) labels1 = ["a1", "c1", "e1", "g1", "i1", "b2", "d2", "f2", "h2", "j2", "a3", "c3", "e3", "g3", "i3", @@ -37,9 +45,11 @@ in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + initPiecesCount _ = 40 + boardNotation r = numericNotation (boardSize r) - dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} + dfltEvaluator r = (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} parseNotation r = parseNumericNotation (boardSize r) @@ -118,6 +128,7 @@ cInitSteps = 0, cFreeSteps = 1, cVictim = victimAddr, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, cDst = freeAddr, cPromote = isLastHorizontal side freeAddr && not (gCanCaptureFrom rules next) diff --git a/src/Rules/Russian.hs b/src/Rules/Russian.hs --- a/src/Rules/Russian.hs +++ b/src/Rules/Russian.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Rules.Russian ( Russian, russian, russianBase ) where @@ -20,14 +21,23 @@ instance Show Russian where show = rulesName +instance SimpleEvaluatorSupport Russian where + getAllAddresses r = addresses8 r + +instance HasTopology Russian where + boardTopology _ = Diagonal + instance GameRules Russian where - initBoard rnd _ = board8 rnd + type EvaluatorForRules Russian = SimpleEvaluator + initBoard rnd r = board8 rnd r boardSize _ = (8, 8) + initPiecesCount _ = 24 + boardNotation _ = chessNotation - dfltEvaluator r = SomeEval $ defaultEvaluator r + dfltEvaluator r = defaultEvaluator r parseNotation _ = parseChessNotation @@ -44,7 +54,7 @@ russianBase :: GenericRules -> GenericRules russianBase = - let rules this = abstractRules this { + let rules this = (abstractRules this) { gManCaptures = manCaptures this } in rules diff --git a/src/Rules/Simple.hs b/src/Rules/Simple.hs --- a/src/Rules/Simple.hs +++ b/src/Rules/Simple.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Rules.Simple (Simple, simple) where import Data.Typeable @@ -18,15 +19,23 @@ instance Show Simple where show = rulesName +instance SimpleEvaluatorSupport Simple where + getAllAddresses r = addresses8 r + +instance HasTopology Simple where + boardTopology _ = Diagonal + instance GameRules Simple where + type EvaluatorForRules Simple = SimpleEvaluator initBoard rnd _ = initBoard rnd Russian.russian boardSize _ = boardSize Russian.russian + initPiecesCount _ = 24 boardNotation _ = boardNotation Russian.russian parseNotation _ = parseNotation Russian.russian - dfltEvaluator r = SomeEval $ defaultEvaluator r + dfltEvaluator r = defaultEvaluator r rulesName _ = "simple" @@ -61,6 +70,7 @@ pmBegin = src, pmEnd = dst, pmVictims = [], + pmVictimsCount = 0, pmMove = Move src [Step dir False False], pmPromote = False, pmResult = [Take src, Put dst piece] @@ -106,6 +116,7 @@ cDirection = dir, cInitSteps = 0, cVictim = victimAddr, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, cFreeSteps = 1, cDst = freeAddr, cPromote = False diff --git a/src/Rules/Spancirety.hs b/src/Rules/Spancirety.hs --- a/src/Rules/Spancirety.hs +++ b/src/Rules/Spancirety.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Rules.Spancirety (Spancirety, spancirety) where import Data.Typeable +import qualified Data.IntMap as IM import Core.Types import Core.Board @@ -17,9 +19,16 @@ instance Show Spancirety where show = rulesName +instance HasTopology Spancirety where + boardTopology _ = Diagonal + +instance SimpleEvaluatorSupport Spancirety where + getAllAddresses r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (8, 10) + instance GameRules Spancirety where + type EvaluatorForRules Spancirety = SimpleEvaluator initBoard rnd r = - let board = buildBoard rnd (boardOrientation r) (8, 10) + let board = buildBoard rnd r (boardOrientation r) (8, 10) labels1 = ["a1", "c1", "e1", "g1", "i1", "b2", "d2", "f2", "h2", "j2", "a3", "c3", "e3", "g3", "i3"] @@ -28,11 +37,13 @@ "b6", "d6", "f6", "h6", "j6"] in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + initPiecesCount _ = 30 + boardSize _ = (8, 10) boardNotation _ = boardNotation russian - dfltEvaluator r = SomeEval $ defaultEvaluator r + dfltEvaluator r = defaultEvaluator r parseNotation _ = parseNotation russian diff --git a/src/Rules/Turkish.hs b/src/Rules/Turkish.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Turkish.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Rules.Turkish ( + Turkish, turkish, turkishBase + ) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Evaluator +import Rules.Generic + +newtype Turkish = Turkish GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Turkish where + show = rulesName + +instance HasTopology Turkish where + boardTopology _ = Orthogonal + +instance SimpleEvaluatorSupport Turkish where + getBackDirections _ = [Backward] + getAllAddresses r = addresses8 r + +instance GameRules Turkish where + type EvaluatorForRules Turkish = SimpleEvaluator + initBoard rnd r = + let board = buildBoard rnd r (boardOrientation r) (8, 8) + labels1 = ["a2", "b2", "c2", "d2", "e2", "f2", "g2", "h2", + "a3", "b3", "c3", "d3", "e3", "f3", "g3", "h3"] + labels2 = ["a7", "b7", "c7", "d7", "e7", "f7", "g7", "h7", + "a6", "b6", "c6", "d6", "e6", "f6", "g6", "h6"] + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + initPiecesCount _ = 32 + + boardSize _ = (8, 8) + + dfltEvaluator r = (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6, seBorderManWeight = 0} + + boardNotation _ = chessNotation + + parseNotation _ = parseChessNotation + + rulesName _ = "turkish" + + possibleMoves (Turkish rules) side board = gPossibleMoves rules side board + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "43" + +turkishBase :: GenericRules -> GenericRules +turkishBase = + let rules this = (abstractRules this) { + gManSimpleMoveDirections = [PLeft, Forward, PRight] + , gManCaptureDirections = [PLeft, Forward, PRight] + , gKingCaptureDirections = [Backward, PLeft, Forward, PRight] + , gKingSimpleMoveDirections = [Backward, PLeft, Forward, PRight] + , gManCaptures = manCaptures this + , gManCaptures1 = manCaptures1 this + , gCaptureMax = True + , gRemoveCapturedImmediately = True + } + in rules + +turkish :: Turkish +turkish = Turkish $ + let rules = turkishBase rules + in rules + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let side = pieceSide ctPiece + captures = manCaptures1 rules ct + -- when last horizontal reached, pass non-promoted piece to + -- next moves check; man can not capture backward. + nextMoves pm = genericNextMoves rules ct False pm + in concat $ flip map captures $ \capture -> + let [move1] = translateCapture ctPiece capture + moves2 = nextMoves move1 + in if null moves2 + then [move1] + else [catPMoves move1 move2 | move2 <- moves2] + +manCaptures1 :: GenericRules -> CaptureState -> [Capture] +manCaptures1 rules ct@(CaptureState {..}) = + concatMap (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) -> + case getPiece victimAddr ctBoard of + Nothing -> [] + Just victim -> + if isMyPiece side victim + then [] + else case myNeighbour rules side dir victimAddr of + Nothing -> [] + Just freeAddr -> + if isFree freeAddr ctBoard || aLabel freeAddr `labelSetMember` ctCaptured + then let captured' = insertLabelSet (aLabel victimAddr) ctCaptured + next = ct { + ctPrevDirection = Just dir, + ctCaptured = captured', + ctCurrent = freeAddr + } + in [Capture { + cSrc = a, + cDirection = dir, + cInitSteps = 0, + cFreeSteps = 1, + cVictim = victimAddr, + cRemoveVictimImmediately = gRemoveCapturedImmediately rules, + cDst = freeAddr, + cPromote = isLastHorizontal side freeAddr && + not (gCanCaptureFrom rules next) + }] + else [] + _ -> [] +