hcheckers 0.1.0.0 → 0.1.0.1
raw patch · 34 files changed
+2377/−552 lines, 34 filesdep +networkdep +random-shuffledep +vector
Dependencies added: network, random-shuffle, vector, wai, warp
Files
- README.md +17/−8
- hcheckers.cabal +13/−3
- src/AI.hs +31/−0
- src/AI/AlphaBeta.hs +576/−210
- src/AI/AlphaBeta/Cache.hs +26/−16
- src/AI/AlphaBeta/Persistent.hs +21/−22
- src/AI/AlphaBeta/Types.hs +47/−28
- src/Battle.hs +224/−0
- src/Core/Board.hs +138/−48
- src/Core/BoardMap.hs +10/−9
- src/Core/Evaluator.hs +277/−49
- src/Core/Game.hs +17/−1
- src/Core/Json.hs +19/−0
- src/Core/Rest.hs +96/−3
- src/Core/Supervisor.hs +53/−10
- src/Core/Types.hs +97/−17
- src/Formats/Compact.hs +2/−2
- src/Formats/Fen.hs +2/−2
- src/Formats/Pdn.hs +53/−32
- src/Formats/Types.hs +11/−0
- src/Learn.hs +5/−5
- src/Main.hs +66/−11
- src/Rules/Armenian.hs +101/−0
- src/Rules/Brazilian.hs +12/−1
- src/Rules/Canadian.hs +13/−2
- src/Rules/Czech.hs +87/−0
- src/Rules/Diagonal.hs +18/−8
- src/Rules/English.hs +14/−2
- src/Rules/Generic.hs +144/−55
- src/Rules/International.hs +13/−2
- src/Rules/Russian.hs +13/−3
- src/Rules/Simple.hs +12/−1
- src/Rules/Spancirety.hs +13/−2
- src/Rules/Turkish.hs +136/−0
README.md view
@@ -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
hcheckers.cabal view
@@ -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 <https://github.com/githubuser/hcheckers#readme> 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
+ src/AI.hs view
@@ -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+
src/AI/AlphaBeta.hs view
@@ -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
src/AI/AlphaBeta/Cache.hs view
@@ -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
src/AI/AlphaBeta/Persistent.hs view
@@ -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
src/AI/AlphaBeta/Types.hs view
@@ -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
+ src/Battle.hs view
@@ -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+
src/Core/Board.hs view
@@ -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+ }
src/Core/BoardMap.hs view
@@ -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
src/Core/Evaluator.hs view
@@ -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
src/Core/Game.hs view
@@ -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 ->
src/Core/Json.hs view
@@ -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
src/Core/Rest.hs view
@@ -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)
src/Core/Supervisor.hs view
@@ -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
src/Core/Types.hs view
@@ -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
src/Formats/Compact.hs view
@@ -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
src/Formats/Fen.hs view
@@ -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
src/Formats/Pdn.hs view
@@ -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) "<PDN>" 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
src/Formats/Types.hs view
@@ -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
src/Learn.hs view
@@ -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
src/Main.hs view
@@ -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
+ src/Rules/Armenian.hs view
@@ -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]+
src/Rules/Brazilian.hs view
@@ -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
src/Rules/Canadian.hs view
@@ -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)
+ src/Rules/Czech.hs view
@@ -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+
src/Rules/Diagonal.hs view
@@ -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
src/Rules/English.hs view
@@ -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 }]
src/Rules/Generic.hs view
@@ -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)
src/Rules/International.hs view
@@ -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)
src/Rules/Russian.hs view
@@ -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
src/Rules/Simple.hs view
@@ -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
src/Rules/Spancirety.hs view
@@ -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
+ src/Rules/Turkish.hs view
@@ -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 []+ _ -> []+