diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hcheckers + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ilya Portnov (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,153 @@ +# hcheckers README + +## What this is + +HCheckers is a relatively simple implementation of checkers board game (also known as "draughts"). +The core is written in Haskell, and the GUI is written in Python + Qt5. Some +day, probably, there will be a web-based JS client to play from browser. + +It is possible to play: + +* Human vs computer (either user or computer plays white); +* Human vs human. + +## What this is not + +HCheckers is not about to compete with well-known and highly optimized +commercial checkers software. It will hardly do any good in playing versus +human checkers grossmaster. +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. + +## Project goals + +* Fun of development. For not-so-seasoned Haskell programmers, or people who are + not-so-expirienced in writing games, this can show some examples. For that, + I'm not going to optimize every possible bit: code readability is in + priority. For that, HCheckers is not going to be faster than software written + in C++ with economy of every bit of memory. +* Fun of game. HCheckers can play well enough for not-so-seasoned draughtsmen. + + +## Features + +The code is general enough to implement a wide range of checkers variants. +The following are implemented at the moment: + +* Russian +* Simple russian (russian draughts without kings) +* Diagonal russian (russian draughts with different initial setup) +* Spancirety (russian draughts on 8x10 board) +* English (checkers) +* International draughts (10x10) +* Brazilian (rules of international draughts on 8x8 board) +* Canadian draughts (12x12) + +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 +parameters, which can be tuned to choose between better play and performance. + +HCheckers can use persistent cache; it can help in calculating more turns, but +it can grow very large and eat a lot of RAM. + +## Current state + +At the moment, HCheckers has most of core functionality implemented. +Most wanted planned things to do are: + +* User documentation (#22) +* Code documentation (#1) +* Spectators support (#9) +* Distributed computing support (#17) +* Packaging (#23, #24) + +## Installation + +### Server part + +For the server part, there are two options available. + +### Ubuntu package + +I will put ubuntu package under github's releases once I'm sure it is working. + +To build the package, + +``` +$ git clone https://github.com/portnov/hcheckers.git +$ cd hcheckers/docker/ +$ ./build-ubuntu-package.sh +``` + +The package will be available under `docker/target` subdirectory. +Use `sudo dpkg -i hcheckersd_0.1.0.0-1_amd64.deb` to install it. + +### Docker image + +For non-debian based systems, the only "easily distributed" form for now is the +docker container. + +``` +$ git clone https://github.com/portnov/hcheckers.git +$ cd hcheckers/docker/ +$ ./build-plain-builder.sh +$ ./build-plain.sh +$ ./run-plain.sh +``` + +### Client part + +Python client can be installed in two ways: + +1) Via `pip`: + +``` +$ cd hcheckers/python/ +$ sudo pip3 install . +``` + +2) Using debian package (on debian-based systems). To build a debian 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 + +``` +$ sudo apt install python3-pyqt5 python3-pyqt5.qtsvg python3-pyqt5.qtmultimedia +$ sudo dpkg -i deb_dist/python3-hcheckers_0.1.0.0-1_all.deb +``` + +After client is installed (either via `pip` or `deb` package), you can run it with + +``` +$ hcheckersc.py +``` + +## Running development version + +You can run HCheckers without actually installing it; it is mostly useful while developing it. + +``` +$ sudo apt-get install stack +$ cd hcheckers/ +$ stack build +``` + +Run server: + +``` +$ stack exec hcheckersd +``` + +Run client: +``` +$ cd python/ +$ python hcheckersc.py +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hcheckers.cabal b/hcheckers.cabal new file mode 100644 --- /dev/null +++ b/hcheckers.cabal @@ -0,0 +1,119 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d512e48c2cc22041414eaea25593830ebf236845a10392a60a9a09b8b784f68d + +name: hcheckers +version: 0.1.0.0 +synopsis: Implementation of checkers ("draughts") board game - server application +description: Please see the README on GitHub at +category: Games +homepage: https://github.com/portnov/hcheckers#readme +bug-reports: https://github.com/portnov/hcheckers/issues +author: Ilya V. Portnov +maintainer: portnov84@rambler.ru +copyright: 2018 Ilya V. Portnov +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/portnov/hcheckers + +flag verbose + description: enable verbose logging of move search + manual: False + default: False + +executable hcheckersd + main-is: Main.hs + other-modules: + AI.AlphaBeta + AI.AlphaBeta.Cache + AI.AlphaBeta.Persistent + AI.AlphaBeta.Types + Core.Board + Core.BoardMap + Core.Checkers + Core.CmdLine + Core.Config + Core.Evaluator + Core.Game + Core.Json + Core.Logging + Core.Monitoring + Core.Parallel + Core.Rest + Core.Supervisor + Core.Types + Formats.Compact + Formats.Fen + Formats.Pdn + Formats.Types + Learn + Rules.Brazilian + Rules.Canadian + Rules.Diagonal + Rules.English + Rules.Generic + Rules.International + Rules.Russian + Rules.Simple + Rules.Spancirety + Paths_hcheckers + hs-source-dirs: + src + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -fwarn-unused-imports + build-depends: + aeson + , array + , base >=4.7 && <5 + , binary + , bits + , bytes + , bytestring + , clock + , concurrent-extra + , containers + , data-default + , directory + , ekg + , ekg-core + , exceptions + , fast-logger + , filepath + , hashable + , hashtables + , heavy-logger + , hsyslog + , http-types + , megaparsec + , microlens + , monad-metrics + , mtl + , mwc-random + , optparse-applicative + , psqueues + , random + , random-access-file + , scotty + , stm + , stm-containers + , store + , template-haskell + , text + , text-format-heavy + , unix + , unix-bytestring + , unordered-containers + , yaml + if flag(verbose) + cpp-options: -DVERBOSE + default-language: Haskell2010 diff --git a/src/AI/AlphaBeta.hs b/src/AI/AlphaBeta.hs new file mode 100644 --- /dev/null +++ b/src/AI/AlphaBeta.hs @@ -0,0 +1,816 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +{- + - This module contains an implementation of alpha-beta-pruning algorithm + - with small improvements. + -} + +module AI.AlphaBeta + ( runAI, scoreMove + ) where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Except +import Control.Concurrent.STM +import qualified Data.Map as M +import Data.Maybe +import Data.Default +import Data.List (sortOn) +import Data.Text.Format.Heavy +import Data.Aeson +import System.Log.Heavy +import System.Log.Heavy.TH +import System.Clock + +import Core.Types +import Core.Board +import Core.Parallel +import Core.Logging +import qualified Core.Monitoring as Monitoring +import AI.AlphaBeta.Types +import AI.AlphaBeta.Cache + +instance FromJSON AlphaBetaParams where + parseJSON = withObject "AlphaBetaParams" $ \v -> AlphaBetaParams + <$> v .: "depth" + <*> v .:? "start_depth" + <*> v .:? "max_combination_depth" .!= 8 + <*> v .:? "dynamic_depth" .!= abDynamicDepth def + <*> v .:? "deeper_if_bad" .!= False + <*> v .:? "moves_bound_low" .!= 4 + <*> v .:? "moves_bound_high" .!= 8 + <*> v .:? "time" + +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 + return cache + + saveAiStorage (AlphaBeta params rules _) cache = do + -- saveAiCache rules params cache + return () + + chooseMove ai storage gameId side board = do + (moves, _) <- runAI ai storage gameId side board + -- liftIO $ atomically $ writeTVar (aichCurrentCounts storage) $ calcBoardCounts board + return moves + + updateAi ai@(AlphaBeta _ rules eval) json = + case fromJSON json of + Error _ -> ai + Success params -> AlphaBeta params rules (updateEval eval json) + + aiName _ = "default" + +-- | Calculate score of one possible move. +scoreMove :: (GameRules rules, Evaluator eval) => ScoreMoveInput rules eval -> Checkers (PossibleMove, Score) +scoreMove (ScoreMoveInput {..}) = do + let AlphaBeta params rules eval = smiAi + score <- Monitoring.timed "ai.score.move" $ do + let board' = applyMoveActions (pmResult smiMove) smiBoard + score <- doScore rules eval smiCache params smiGameId (opposite smiSide) smiDepth board' smiAlpha smiBeta + `catchError` (\(e :: Error) -> do + $info "doScore: move {}, depth {}: {}" (show smiMove, dpTarget smiDepth, show e) + throwError e + ) + $info "Check: {} (depth {}) => {}" (show smiMove, dpTarget smiDepth, show score) + return score + + return (smiMove, score) + +rememberScoreShift :: AICacheHandle rules eval -> GameId -> ScoreBase -> Checkers () +rememberScoreShift handle gameId shift = liftIO $ atomically $ do + shifts <- readTVar (aichLastMoveScoreShift handle) + let shifts' = M.insert gameId shift shifts + writeTVar (aichLastMoveScoreShift handle) shifts' + +getLastScoreShift :: AICacheHandle rules eval -> GameId -> Checkers (Maybe ScoreBase) +getLastScoreShift handle gameId = liftIO $ atomically $ do + shifts <- readTVar (aichLastMoveScoreShift handle) + return $ M.lookup gameId shifts + +getPossibleMoves :: GameRules rules => AICacheHandle rules eval -> Side -> Board -> Checkers [PossibleMove] +getPossibleMoves handle side board = Monitoring.timed "ai.possible_moves.duration" $ do + let rules = aichRules handle + Monitoring.increment "ai.possible_moves.calls" + return $ possibleMoves rules side board +-- (result, hit) <- liftIO $ do +-- let memo = aichPossibleMoves handle +-- let rules = aichRules handle +-- let moves = possibleMoves rules side board +-- mbItem <- lookupBoardMap memo board +-- case mbItem of +-- Nothing -> do +-- let value = case side of +-- First -> (Just moves, Nothing) +-- Second -> (Nothing, Just moves) +-- putBoardMap memo board value +-- return (moves, False) +-- Just (Just cachedMoves, _) | side == First -> return (cachedMoves, True) +-- Just (_, Just cachedMoves) | side == Second -> return (cachedMoves, True) +-- Just (mbMoves1, mbMoves2) -> do +-- let value +-- | side == First = (Just moves, mbMoves2) +-- | otherwise = (mbMoves1, Just moves) +-- putBoardMap memo board value +-- return (moves, False) +-- if hit +-- then Monitoring.increment "ai.possible_moves.hit" +-- else Monitoring.increment "ai.possible_moves.miss" +-- return result + +-- | 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. +-- +-- This is done, in general, in three stages: +-- +-- 1. Preselect. From all possible moves, select ones that look good at a first glance. +-- This logic can be used to make AI work faster, but it obviously can miss some moves +-- that are not so good from a first glance, but are very good from the second glance. +-- +-- 2. Depth-wise loop. Score all moves with specified depth. If there is still time, then +-- score them again with better depth. Repeat until there is still time. +-- Each iteration can be interrupted by TimeExhaused exception. +-- If last iteration was not interrupted, then use results of last iteration. +-- If last iteration was interrputed, then merge results of last iteration with results +-- of previous one: for moves that we was not able to calculate with better depth, +-- use results with previous depth. +-- If timeout is not specified, then only one iteration is executed, without timeout. +-- The depth to start with should not be very big, so that we should be always able to +-- calculate all moves with at least start depth. Neither should it be too small, +-- otherwise we would re-calculate the same for many times. +-- +-- 3. Width-wise loop. This is performed within each depth iteration. +-- Specifics of alpha-beta prunning algorithm is so that the lesser +-- (alpha, beta) range is provided at start, the faster algorithm works; however, +-- in case real score is outside of these bounds, it will return eiter alpha or beta +-- value instead of real score value. So, we do the following: +-- +-- * Select initial "width range", which is range of scores (alpha, beta). This range +-- is selected based on evaluation of current board with zero depth, plus-minus some +-- small delta. +-- Run scoreAB in that range. +-- * If values returned by scoreAB are within selected initial range, then everything is +-- okay: we just select the best of returned values. +-- * If exactly one move seems to bee "too good", i.e. corresponding result of scoreAB +-- equals to alpha/beta (depending on side), then we do not bother about it's exact +-- score: we should do that move anyway. +-- * If there are more than one "too good" moves, then we should select the next interval +-- (alpha, beta), and run the next iteration only on that moves that seem to be "too good". +-- * If all moves seem to be "too bad", then we should select the previous interval of +-- (alpha, beta), and run the next iteration on all moves in that interval. +-- * It is possible (not very likely, but possible) that real score of some moves equals +-- exactly to alpha or beta bound that we selected on some iteration. To prevent switching +-- between "better" and "worther" intervals forwards and backwards indefinitely, we +-- introduce a restriction: if we see that scoreAB returned the bound value, but we have +-- already considered the interval on that side, then we know that the real score equals +-- exactly to the bound. +-- +runAI :: (GameRules rules, Evaluator eval) + => AlphaBeta rules eval + -> AICacheHandle rules eval + -> GameId + -> Side + -> Board + -> Checkers AiOutput +runAI ai@(AlphaBeta params rules eval) handle gameId side board = do + preOptions <- preselect + options <- depthDriver preOptions + output <- select options + let bestScore = sNumeric $ snd output + let shift = bestScore - sNumeric score0 + rememberScoreShift handle gameId shift + return output + where + maximize = side == First + minimize = not maximize + + betterThan s1 s2 + | maximize = s1 > s2 + | otherwise = s1 < s2 + + worseThan s1 s2 = not (betterThan s1 s2) + + preselect = + getPossibleMoves handle side board + +-- 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 + + 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) + + goTimed :: DepthIterationInput + -> Checkers (DepthIterationOutput, Maybe DepthIterationInput) + goTimed (params, moves, prevResult) = do + ret <- tryC $ go (params, moves, prevResult) + case ret of + Right result -> return result + Left TimeExhaused -> + case prevResult of + Just result -> return (result, Nothing) + Nothing -> return ([(move, 0) | move <- moves], Nothing) + Left err -> throwError err + + go :: DepthIterationInput + -> Checkers (DepthIterationOutput, Maybe DepthIterationInput) + go (params, moves, prevResult) = do + let depth = abDepth params + if length moves <= 1 -- Just one move possible + then do + $info "There is only one move possible; just do it." () + return ([(move, score0) | move <- moves], 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 { + dpInitialTarget = depth + , dpTarget = depth + , dpCurrent = -1 + , dpMax = abCombinationDepth params + depth + , dpMin = fromMaybe depth (abStartDepth params) + , dpStaticMode = False + , dpForcedMode = False + } + let needDeeper = abDeeperIfBad params && score0 `worseThan` 0 + let dp' + | needDeeper = dp { + dpTarget = min (dpMax dp) (dpTarget dp + 1) + } + | otherwise = dp + result <- widthController True True prevResult moves dp' =<< initInterval + -- 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)) + else return (result, Nothing) + + 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 + mbPrevShift <- getLastScoreShift handle gameId + case mbPrevShift of + Nothing -> do + let alpha = score0 - delta + beta = score0 + delta + $debug "Score0 = {}, delta = {} => initial interval ({}, {})" (score0, delta, alpha, beta) + return (alpha, beta) + Just shift -> do + let (alpha, beta) + | shift >= 0 = (score0 - delta, score0 + (Score shift 0) + delta) + | otherwise = (score0 + (Score shift 0) - delta, score0 + delta) + $debug "Score0 = {}, delta = {}, shift in previous move = {} => initial interval ({}, {})" + (score0, delta, shift, alpha, beta) + return (alpha, beta) + + selectScale :: Score -> ScoreBase + selectScale s + | s > 10000 = 1000 + | s > 1000 = 10 + | s > 100 = 5 + | otherwise = 2 + + nextInterval :: (Score, Score) -> (Score, Score) + nextInterval (alpha, beta) = + let width = (beta - alpha) + width' = selectScale width `scaleScore` width + alpha' = prevScore alpha + beta' = nextScore beta + in if maximize + then (beta', max beta' (beta' + width')) + else (min alpha' (alpha' - width'), alpha') + + prevInterval :: (Score, Score) -> (Score, Score) + prevInterval (alpha, beta) = + let width = (beta - alpha) + width' = selectScale width `scaleScore` width + alpha' = prevScore alpha + beta' = nextScore beta + in if minimize + then (beta', max beta' (beta' + width')) + else (min alpha' (alpha' - width'), alpha') + + widthController :: Bool -- ^ Allow to shift (alpha,beta) segment to bigger values? + -> Bool -- ^ Allow to shift (alpha,beta) segment to lesser values? + -> Maybe DepthIterationOutput -- ^ Results of previous depth iteration + -> [PossibleMove] + -> DepthParams + -> (Score, Score) -- ^ (Alpha, Beta) + -> Checkers DepthIterationOutput + widthController allowNext allowPrev prevResult moves dp interval@(alpha,beta) = + 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] + else do + results <- widthIteration prevResult moves dp interval + let (good, badScore, badMoves) = selectBestEdge interval moves results + (bestMoves, bestResults) = unzip good + 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' + 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] + else + case bestResults of + [] -> return results + [_] -> do + $info "Exactly one move is `too good'; do that move." () + 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 + + scoreMoves :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers [Either Error (PossibleMove, Score)] + scoreMoves moves dp (alpha, beta) = do + let var = aichData handle + let processor = aichProcessor handle + let inputs = [ + ScoreMoveInput { + smiAi = ai, + smiCache = handle, + smiGameId = gameId, + smiSide = side, + 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) + 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) + joinResults prevResult results + + joinResults :: Maybe DepthIterationOutput -> [Either Error (PossibleMove, Score)] -> 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 + $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 (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] + 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) + +-- | Calculate score of the board +doScore :: (GameRules rules, Evaluator eval) + => rules + -> eval + -> AICacheHandle rules eval + -> AlphaBetaParams + -> GameId + -> Side + -> DepthParams + -> Board + -> Score -- ^ Alpha + -> Score -- ^ Beta + -> Checkers Score +doScore rules eval var params gameId side dp board alpha beta = do + initState <- mkInitState + out <- evalStateT (cachedScoreAB var params input) initState + return $ soScore out + where + input = ScoreInput side dp alpha beta board Nothing + mkInitState = do + now <- liftIO $ getTime Monotonic + let timeout = case abBaseTime params of + Nothing -> Nothing + Just sec -> Just $ TimeSpec (fromIntegral sec) 0 + return $ ScoreState rules eval gameId [loose] M.empty now timeout + +clamp :: Ord a => a -> a -> a -> a +clamp alpha beta score + | score < alpha = alpha + | score > beta = beta + | otherwise = score + +-- | Calculate score of the board. +-- This uses the cache. It is called in the recursive call also. +cachedScoreAB :: forall rules eval. (GameRules rules, Evaluator eval) + => AICacheHandle rules eval + -> AlphaBetaParams + -> ScoreInput + -> ScoreM rules eval ScoreOutput +cachedScoreAB var params input = do + let depth = dpCurrent dp + side = siSide input + board = siBoard input + dp = siDepth input + alpha = siAlpha input + beta = siBeta input + mbItem <- lift $ lookupAiCache params board dp var + mbCached <- case mbItem of + Just item -> do + let score = 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 + then return $ Just $ ScoreOutput alpha False + else return Nothing + Beta -> if score >= beta + then return $ Just $ ScoreOutput beta False + else return Nothing + Nothing -> return Nothing + case mbCached of + Just out -> return out + Nothing -> do + out <- Monitoring.timed "ai.score.board" $ scoreAB var params input + let score = soScore out + bound + | score <= alpha = Alpha + | score >= beta = Beta + | otherwise = Exact + -- 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 + lift $ putAiCache params board item var + lift $ putAiCache params (flipBoard board) item' var + return out + +-- | Check if target depth is reached +isTargetDepth :: DepthParams -> Bool +isTargetDepth dp = dpCurrent dp >= dpTarget dp + +-- | Increase current depth as necessary. +-- +-- If there is only 1 move currently possible, this can increase +-- the target depth, up to dpMax. Such situations mean that there is +-- probably a series of captures going on, which can change situation +-- dramatically. So we want to know the result better (up to the end of +-- the whole combination, if possible) to make our choice. +-- +-- If there are a lot of moves possible, this can decrease the +-- target depth, down to dpMin. This is done simply to decrease computation +-- time. This is obviously going to lead to less strong play. +-- +-- Otherwise, this just increases dpCurrent by 1. +-- +updateDepth :: (Monad m, HasLogging m, MonadIO m) => AlphaBetaParams -> [PossibleMove] -> DepthParams -> m DepthParams +updateDepth params moves dp + | deepen = do + let delta = nMoves - 1 + let target = min (dpTarget dp + 1) (dpMax dp - delta) + let indent = replicate (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) ' ' + $verbose "{}| there are too many moves, decrease target depth to {}" + (indent, target) + return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target} + | otherwise = return $ dp {dpCurrent = dpCurrent dp + 1} + where + nMoves = length moves + deepen = if dpCurrent dp <= dpInitialTarget dp + then nMoves <= abMovesLowBound params + else any isCapture moves || any isPromotion moves + +isQuiescene :: [PossibleMove] -> Bool +isQuiescene moves = not (any isCapture moves || any isPromotion moves) + +-- | Check if timeout is exhaused. +isTimeExhaused :: ScoreM rules eval Bool +isTimeExhaused = do + check <- gets ssTimeout + case check of + Nothing -> return False + Just delta -> do + start <- gets ssStartTime + now <- liftIO $ getTime Monotonic + return $ start + delta <= now + +-- | Calculate score for the board. +-- This implements the alpha-beta section algorithm itself. +scoreAB :: forall rules eval. (GameRules rules, Evaluator eval) + => AICacheHandle rules eval + -> AlphaBetaParams + -> ScoreInput + -> ScoreM rules eval ScoreOutput +scoreAB var params input + | isTargetDepth dp = do + -- target depth is achieved, calculate score of current board directly + evaluator <- gets ssEvaluator + let score0 = evalBoard' evaluator board + $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 + + -- this actually means that corresponding side lost. + when (null moves) $ + $verbose "{}`—No moves left." (Single indent) + + dp' <- updateDepth params moves dp + let prevMove = siPrevMove input + moves' <- sortMoves prevMove moves + out <- iterateMoves (zip [1..] moves') dp' + pop + return out + + where + + side = siSide input + dp = siDepth input + alpha = siAlpha input + beta = siBeta input + board = siBoard input + + 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) + | otherwise = score + + checkQuiescene :: ScoreM rules eval Bool + checkQuiescene = do + rules <- gets ssRules + moves <- lift $ getPossibleMoves var (opposite side) board + return $ isQuiescene moves + + push :: Score -> ScoreM rules eval () + push score = + modify $ \st -> st {ssBestScores = score : ssBestScores st} + + pop :: ScoreM rules eval () + 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) + Label col' row' = aLabel (pmBegin pm) + in abs (col' - col) `max` abs (row' - row) + + maximize = side == First + minimize = not maximize + + bestStr :: String + bestStr = if maximize + then "Maximum" + else "Minimum" + + indent = replicate (2*dpCurrent dp) ' ' + + getBest = + gets (head . ssBestScores) + + setBest :: Score -> ScoreM rules eval () + setBest best = do + oldBest <- getBest + $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 + lift $ getPossibleMoves var (opposite side) board + + isInteresting move = do + opMoves <- opponentMoves + 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)] + + checkMove :: AICacheHandle rules eval -> AlphaBetaParams -> ScoreInput -> PossibleMove -> ScoreM rules eval ScoreOutput + checkMove var params input move = do + let alpha = siAlpha input + beta = siBeta input + width = beta - alpha + intervals <- do + interesting <- isInteresting move + if interesting || width <= 2 + then return [(alpha, beta)] + else return $ mkIntervals (alpha, beta) + let inputs = [input {siAlpha = alpha, siBeta = beta} | (alpha, beta) <- intervals] + go inputs + where + go [input] = cachedScoreAB var params input + go (input : inputs) = do + out <- cachedScoreAB var params input + let score = soScore out + if maximize && score >= beta || minimize && score <= alpha + then go inputs + else return out + + + 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 + timeout <- isTimeExhaused + when timeout $ do + -- $info "Timeout exhaused for depth {}." (Single $ dpCurrent dp) + throwError TimeExhaused + $verbose "{}|+Check move of side {}: {}" (indent, show side, show move) + evaluator <- gets ssEvaluator + rules <- gets ssRules + best <- getBest + let input' = input { + siSide = opposite side + , siAlpha = if maximize + then max alpha best + else alpha + , siBeta = if maximize + then beta + else min beta best + , siPrevMove = Just move + , siBoard = applyMoveActions (pmResult move) board + , siDepth = dp + } + out <- cachedScoreAB var params input' + let score = soScore out + $verbose "{}| score for side {}: {}" (indent, show side, show score) + + if (maximize && score > best) || (minimize && score < best) + then do + setBest score + if (maximize && score >= beta) || (minimize && score <= alpha) + then do + rememberGoodMove (dpCurrent dp) 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 do + iterateMoves moves dp + +instance (Evaluator eval, GameRules rules) => Evaluator (AlphaBeta rules eval) where + evaluatorName (AlphaBeta _ _ eval) = evaluatorName eval + evalBoard (AlphaBeta params rules eval) whoAsks board = + evalBoard eval whoAsks board + diff --git a/src/AI/AlphaBeta/Cache.hs b/src/AI/AlphaBeta/Cache.hs new file mode 100644 --- /dev/null +++ b/src/AI/AlphaBeta/Cache.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module AI.AlphaBeta.Cache + ( loadAiCache, + lookupAiCache, + putAiCache, + ) where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Catch +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception (SomeException) +import qualified Control.Concurrent.ReadWriteLock as RWL +import qualified Data.Map as M +import qualified Data.HashPSQ as PQ +import Data.Maybe +import Data.Text.Format.Heavy (Single (..)) +import System.FilePath +import System.Environment +import System.Directory +import System.Posix.IO +import qualified System.IO.RandomAccessFile as File +import System.Clock +import System.Log.Heavy +import System.Log.Heavy.TH + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Parallel +import qualified Core.Monitoring as Monitoring +import AI.AlphaBeta.Types +import AI.AlphaBeta.Persistent + +-- | Prepare AI storage instance. +-- This also contains Processor instance with several threads. +loadAiCache :: (GameRules rules, Evaluator eval) + => (ScoreMoveInput rules eval -> Checkers (PossibleMove, Score)) + -> AlphaBeta rules eval + -> Checkers (AICacheHandle rules eval) +loadAiCache scoreMove (AlphaBeta params rules eval) = do + let getKey input = pmResult (smiMove input) + aiCfg <- asks (gcAiConfig . csConfig) + processor <- runProcessor (aiThreads aiCfg) getKey scoreMove + cache <- liftIO newTBoardMap + cachePath <- do + home <- liftIO $ getEnv "HOME" + let directory = home ".cache" "hcheckers" rulesName rules "ai.cache" + liftIO $ createDirectoryIfMissing True directory + return directory + let indexPath = cachePath "index" + dataPath = cachePath "data" + + writeQueue <- liftIO $ atomically newTChan + cleanupQueue <- liftIO $ atomically $ newTVar PQ.empty + load <- asks (aiLoadCache . gcAiConfig . csConfig) + store <- asks (aiStoreCache . gcAiConfig . csConfig) + let mbMode + | store = Just ReadWrite + | load = Just ReadOnly + | otherwise = Nothing + (indexFile, dataFile, exist) <- case mbMode of + Nothing -> return (Nothing, Nothing, False) + Just mode -> do + indexExists <- liftIO $ doesFileExist indexPath + dataExists <- liftIO $ doesFileExist dataPath + let exist = dataExists && indexExists + if load && not store && not exist + then return (Nothing, Nothing, exist) + else liftIO $ do + let page = 1024*1024 + params = File.MMapedParams page True + indexFd <- File.initFile params indexPath + dataFd <- File.initFile params dataPath + return (Just indexFd, Just dataFd, exist) + when (isJust mbMode) $ + $info "Opened cache: {}" (Single cachePath) + + st <- ask + indexLock <- liftIO RWL.new + dataLock <- liftIO RWL.new + indexBlockLocks <- liftIO $ atomically $ newTVar M.empty + dataBlockLocks <- liftIO $ atomically $ newTVar M.empty + + let indexHandle = case indexFile of + Nothing -> Nothing + Just fd -> Just $ FHandle { + fhOffset = 0, + fhHandle = fd + } + let dataHandle = case dataFile of + Nothing -> Nothing + Just fd -> Just $ FHandle { + fhOffset = 0, + fhHandle = fd + } + counts <- liftIO $ atomically $ newTVar $ BoardCounts 50 50 50 50 + moves <- liftIO newTBoardMap + scoreShift <- liftIO $ atomically $ newTVar M.empty + let handle = AICacheHandle { + aichRules = rules, + aichData = cache, + aichProcessor = processor, + aichPossibleMoves = moves, + aichLastMoveScoreShift = scoreShift, + aichWriteQueue = writeQueue, + aichCleanupQueue = cleanupQueue, + aichCurrentCounts = counts, + aichIndexFile = indexHandle, + aichDataFile = dataHandle + } + when (store && isJust indexFile && not exist) $ do + runStorage handle initFile + when store $ + forkCheckers $ cacheDumper rules params handle + -- forkCheckers $ cacheCleaner handle + + return handle + +cacheDumper :: (GameRules rules, Evaluator eval) => rules -> AlphaBetaParams -> AICacheHandle rules eval -> Checkers () +cacheDumper rules params handle = do + store <- asks (aiStoreCache . gcAiConfig . csConfig) + when store $ forever $ do + repeatTimed "write" 30 $ do + -- threadDelay $ 100*1000 + mbRecord <- liftIO $ atomically $ checkWriteQueue (aichWriteQueue handle) + case mbRecord of + Nothing -> return False + Just (board, value) -> do + Monitoring.increment "cache.records.writen" + runStorage handle $ + putRecordFile board value + return True + + liftIO $ threadDelay $ 30 * 1000 * 1000 + +cacheCleaner :: AICacheHandle rules eval -> Checkers () +cacheCleaner handle = forever $ do + liftIO $ threadDelay $ 30 * 1000 * 1000 + +normalize :: BoardSize -> (BoardCounts,BoardKey,Side) -> (BoardCounts,BoardKey,Side) +normalize bsize (bc,bk,side) = + let bk' = flipBoardKey bsize bk + bc' = flipBoardCounts bc + in if bc' < bc + then (bc', bk', opposite side) + else (bc, bk, side) + +-- | Look up for item in the cache. First lookup in the memory, +-- then in the file (if it is open). +lookupAiCache :: (GameRules rules, Evaluator eval) => AlphaBetaParams -> Board -> DepthParams -> AICacheHandle rules eval -> Checkers (Maybe PerBoardData) +lookupAiCache params board depth handle = do + mbItem <- lookupMemory board + case mbItem of + Just item -> do + Monitoring.increment "cache.hit.memory" + return $ Just item + Nothing -> do + mbFile <- lookupFile' board depth + case mbFile of + Nothing -> do + 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' + + where + + avg :: Stats -> Score + avg s = + let Score n p = statsSumScore s + cnt = statsCount s + in Score (n `div` cnt) (p `div` cnt) + + checkStats :: Stats -> Maybe Stats + checkStats s + | statsCount s < 10 = Nothing + | otherwise = Just s + + lookupMemory :: Board -> Checkers (Maybe PerBoardData) + lookupMemory board = Monitoring.timed "cache.lookup.memory" $ do + cfg <- asks (gcAiConfig . csConfig) + let cache = aichData handle + mbItem <- liftIO $ lookupBoardMap cache board + case mbItem of + Nothing -> return Nothing + Just item@(PerBoardData {..}) -> + if itemDepth >= dpLast depth + then return $ Just item + else return Nothing + + 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 + else return Nothing + +-- | Put an item to the cache. +-- It is always writen to the memory, +-- and it is writen to the file if it is open. +putAiCache :: GameRules rules => AlphaBetaParams -> Board -> StorageValue -> AICacheHandle rules eval -> Checkers () +putAiCache params board newItem handle = do + let bc = calcBoardCounts board + let bsize = boardSize (aichRules handle) + let total = bcFirstMen bc + bcSecondMen bc + bcFirstKings bc + bcSecondKings bc + let depth = itemDepth newItem + cfg <- asks (gcAiConfig . csConfig) + let needWriteFile = {-total <= aiUpdateCacheMaxPieces cfg &&-} depth > aiUpdateCacheMaxDepth cfg + Monitoring.timed "cache.put.memory" $ do + now <- liftIO $ getTime Monotonic + Monitoring.increment "cache.records.put" + fileCacheEnabled <- asks (aiStoreCache . gcAiConfig . csConfig) + let cache = aichData handle + liftIO $ putBoardMapWith cache (<>) board newItem + + liftIO $ atomically $ do + when (fileCacheEnabled && needWriteFile) $ + putWriteQueue (aichWriteQueue handle) (board, newItem) + -- putCleanupQueue (aichCleanupQueue handle) (bc, bk) now + diff --git a/src/AI/AlphaBeta/Persistent.hs b/src/AI/AlphaBeta/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/AI/AlphaBeta/Persistent.hs @@ -0,0 +1,567 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} + +module AI.AlphaBeta.Persistent + (lookupFile, + lookupStatsFile, + putRecordFile, + putStatsFile, + putWriteQueue, + checkWriteQueue, + initFile, + checkDataFile', + loadIndexIO + ) where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Catch (catch, SomeException) +import Control.Concurrent.STM +import qualified Data.HashPSQ as PQ +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Maybe +import Data.Word +import Data.Text.Format.Heavy +import Data.Store +import Data.Bits.Coded +import Data.Bits.Coding +import Data.Bytes.Put +import System.Clock +import Text.Printf +import GHC.Generics +import System.Posix.Types +import qualified System.IO.RandomAccessFile as File +import System.Log.Heavy +import System.Log.Heavy.TH + +import Core.Types +import Core.Board +import qualified Core.Monitoring as Monitoring +import AI.AlphaBeta.Types + +maxPieces :: Integer +maxPieces = 30 + +encodeBoard :: Board -> B.ByteString +encodeBoard board = runPutS $ runEncode $ encodeB board + where + + encodePiece Nothing = + putBit False + encodePiece (Just (Piece Man First)) = do + putBit True + putBit False + putBit False + encodePiece (Just (Piece Man Second)) = do + putBit True + putBit False + putBit True + encodePiece (Just (Piece King First)) = do + putBit True + putBit True + putBit False + encodePiece (Just (Piece King Second)) = do + putBit True + putBit True + putBit True + + encodeB b = do + forM_ (allPieces b) encodePiece + + +sizeOf :: Data.Store.Store a => a -> ByteCount +sizeOf a = + case Data.Store.size of + Data.Store.VarSize fn -> fromIntegral $ fn a + Data.Store.ConstSize n -> fromIntegral n + +unexistingBlock :: IndexBlockNumber +unexistingBlock = maxBound + +putCleanupQueue :: CleanupQueue -> QueueKey -> TimeSpec -> STM () +putCleanupQueue var key now = modifyTVar var $ \queue -> + let cleanupDelay = TimeSpec {sec=10, nsec=0} + in PQ.insert key (now + cleanupDelay) () queue + +checkCleanupQueue :: CleanupQueue -> TimeSpec -> STM (Maybe QueueKey) +checkCleanupQueue var now = do + queue <- readTVar var + case PQ.minView queue of + Nothing -> return Nothing + Just (key, time, _, queue') -> + if time < now + then do + writeTVar var queue' + return $ Just key + else return Nothing + +putWriteQueue :: WriteQueue -> (Board, StorageValue) -> STM () +putWriteQueue = writeTChan + +checkWriteQueue :: WriteQueue -> STM (Maybe (Board, StorageValue)) +checkWriteQueue = tryReadTChan + +getFd :: FileType -> Storage FileDescriptor +getFd file = do + fh <- getFh file + return $ fhHandle fh + +getFh :: FileType -> Storage FHandle +getFh file = do + let selector = case file of + IndexFile -> ssIndex + DataFile -> ssData + st <- get + case selector st of + Nothing -> fail "getFh: file is not open" + Just fh -> return fh + +updateFh :: FileType -> (FHandle -> FHandle) -> Storage () +updateFh IndexFile fn = do + st <- get + case ssIndex st of + Nothing -> fail "updateFh: index file is not open" + Just fh -> put $ st {ssIndex = Just $ fn fh} +updateFh DataFile fn = do + st <- get + case ssData st of + Nothing -> fail "updateFh: data file is not open" + Just fh -> put $ st {ssData = Just $ fn fh} + +tell :: FileType -> Storage FileOffset +tell file = do + fh <- getFh file + return $ fhOffset fh + +seek :: FileType -> FileOffset -> Storage () +seek file offset = do + updateFh file $ \fh -> fh {fhOffset = offset} + +readBytes :: FileType -> ByteCount -> Storage B.ByteString +readBytes file size = do + fd <- getFd file + currentOffset <- tell file + result <- liftIO $ File.readBytes fd (fromIntegral currentOffset) (fromIntegral size) + seek file $ fromIntegral size + currentOffset + return result + +writeBytes :: FileType -> B.ByteString -> Storage () +writeBytes file bstr = do + fd <- getFd file + currentOffset <- tell file + result <- liftIO $ File.writeBytes fd (fromIntegral currentOffset) bstr + let size = B.length bstr + seek file $ fromIntegral size + currentOffset + +flush :: Storage () +flush = return () +-- fd <- getFd +-- handle <- liftIO $ fdToHandle fd +-- liftIO $ hFlush handle + +isEof :: Storage Bool +isEof = return False +-- fd <- getFd +-- handle <- liftIO $ fdToHandle fd +-- liftIO $ hIsEOF handle + +-- | Read an item of appropriate type from file handle. +-- Warning: this cannot work with data types which size is variable. +readData :: forall a. Data.Store.Store a => FileType -> Storage a +readData file = do + bstr <- readBytes file (fromIntegral $ sizeOf (error "unknown data size to read!" :: a)) + when (B.null bstr) $ do + offset <- tell file + fail $ "readData: unexpected EOF, offset " ++ show offset + liftIO $ Data.Store.decodeIO bstr + +writeData :: forall a. Data.Store.Store a => FileType -> a -> Storage () +writeData file a = do + let bstr = Data.Store.encode a + writeBytes file bstr + +-- | Read an item of appropriate type from file handle. +-- Assumes there is data size in Word16 format before data itself. +readDataSized :: forall a. Data.Store.Store a => FileType -> Storage a +readDataSized file = do + size <- readData file :: Storage Word16 + bstr <- readBytes file (fromIntegral size) + when (B.null bstr) $ do + offset <- tell file + fail $ "readDataSized: zero data size, offset " ++ show offset + liftIO $ Data.Store.decodeIO bstr + +writeDataSized :: forall a. Data.Store.Store a => FileType -> a -> Storage () +writeDataSized file a = do + let bstr = Data.Store.encode a + let size = (fromIntegral $ B.length bstr) :: Word16 + writeData file size + writeBytes file bstr + +dataHeaderSize :: FileOffset +dataHeaderSize = fromIntegral $ sizeOf (0 :: DataBlockNumber) + +indexHeaderSize :: FileOffset +indexHeaderSize = fromIntegral $ sizeOf (0 :: IndexBlockNumber) + +indexRecordSize :: FileOffset +indexRecordSize = fromIntegral (sizeOf (0 :: DataBlockNumber) + sizeOf (0 :: IndexBlockNumber)) + +indexBlockSize :: BoardSize -> FileOffset +indexBlockSize (nrows, ncols) = 256 * indexRecordSize + +dataBlockSize :: FileOffset +dataBlockSize = 128 + +calcIndexBlockOffset :: BoardSize -> IndexBlockNumber -> FileOffset +calcIndexBlockOffset bsize n = indexHeaderSize + indexBlockSize bsize * fromIntegral n + +calcDataBlockOffset :: DataBlockNumber -> FileOffset +calcDataBlockOffset n = dataHeaderSize + dataBlockSize * fromIntegral n + +calcIndexOffset :: BoardSize -> IndexBlockNumber -> Word8 -> FileOffset +calcIndexOffset bsize block char = + calcIndexBlockOffset bsize block + fromIntegral char * indexRecordSize + +data IndexHeader = IndexHeader { + ihBlocksCount :: IndexBlockNumber + } + deriving (Show, Generic) + +instance Data.Store.Store IndexHeader where + size = ConstSize $ fromIntegral $ sizeOf (0 :: IndexBlockNumber) + + poke h = + poke $ ihBlocksCount h + + peek = do + n <- peek + return $ IndexHeader n + +data DataHeader = DataHeader { + dhBlocksCount :: DataBlockNumber + } + deriving (Show, Generic) + +instance Data.Store.Store DataHeader where + size = ConstSize $ fromIntegral $ sizeOf (0 :: DataBlockNumber) + + poke h = + poke $ dhBlocksCount h + + peek = do + n <- peek + return $ DataHeader n + +data IndexRecord = IndexRecord { + irIndexBlock :: IndexBlockNumber + , irDataBlock :: DataBlockNumber + } + deriving (Show) + +instance Store IndexRecord where + size = ConstSize $ fromIntegral $ sizeOf (0 :: IndexBlockNumber) + sizeOf (0 :: DataBlockNumber) + + poke r = do + poke $ irIndexBlock r + poke $ irDataBlock r + + peek = do + idxBlock <- peek + dataBlock <- peek + return $ IndexRecord idxBlock dataBlock + +lookupFileB :: B.ByteString -> Storage (Maybe PerBoardData) +lookupFileB bstr = do + st <- get + case ssData st of + Nothing -> return Nothing + Just _ -> loop 0 bstr + where + loop blockNumber bstr + | B.length bstr == 1 = do + bsize <- gets ssBoardSize + let idxOffset = calcIndexOffset bsize blockNumber (B.head bstr) + seek IndexFile idxOffset + record <- readData IndexFile + let dataBlockNumber = irDataBlock record + if dataBlockNumber == unexistingBlock + then return Nothing + else do + let dataOffset = calcDataBlockOffset dataBlockNumber + seek DataFile dataOffset + value <- readDataSized DataFile + return $ Just value + | otherwise = do + bsize <- gets ssBoardSize + let idxOffset = calcIndexOffset bsize blockNumber (B.head bstr) + seek IndexFile idxOffset + record <- readData IndexFile + let nextBlockNumber = irIndexBlock record + if nextBlockNumber == unexistingBlock + then return Nothing + else loop nextBlockNumber (B.tail bstr) + + +-- | Returns: (cached result, stats +lookupFile :: Board -> DepthParams -> Storage (Maybe PerBoardData) +lookupFile board depth = Monitoring.timed "cache.lookup.file" $ do + mbRecord <- lookupFileB (encodeBoard board) + case mbRecord of + Nothing -> return Nothing + Just record -> do + return $ + if itemDepth record >= dpLast depth + 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 + +putRecordFileB :: B.ByteString -> PerBoardData -> Storage () +putRecordFileB bstr newData = do + st <- get + case ssData st of + Nothing -> return () + Just _ -> tryBlock 0 bstr + where + tryBlock blockNumber bstr + | B.length bstr == 1 = do + bsize <- gets ssBoardSize + let idxOffset = calcIndexOffset bsize blockNumber (B.head bstr) + seek IndexFile idxOffset + record <- readData IndexFile + let dataBlockNumber = irDataBlock record + if dataBlockNumber == unexistingBlock + then do + Monitoring.increment "storage.data.block.created" + newDataBlock <- createDataBlock + let record' = record {irDataBlock = newDataBlock} + seek IndexFile idxOffset + writeData IndexFile record' + seek DataFile $ calcDataBlockOffset newDataBlock + writeDataSized DataFile newData + return () + else do + Monitoring.increment "storage.data.block.reused" + let dataOffset = calcDataBlockOffset dataBlockNumber + seek DataFile dataOffset + oldData <- readDataSized DataFile + `catch` + (\(e :: SomeException) -> do + $reportError "putRecordFileB: {}" (Single $ show e) + return mempty + ) + let newData' = oldData <> newData + seek DataFile dataOffset + writeDataSized DataFile newData' + return () + | otherwise = do + bsize <- gets ssBoardSize + let idxOffset = calcIndexOffset bsize blockNumber (B.head bstr) + seek IndexFile idxOffset + record <- readData IndexFile + let nextBlockNumber = irIndexBlock record + if nextBlockNumber == unexistingBlock + then do + Monitoring.increment "storage.index.block.created" + newIndexBlock <- createIndexBlock + let record' = record {irIndexBlock = newIndexBlock} + seek IndexFile idxOffset + writeData IndexFile record' + tryBlock newIndexBlock (B.tail bstr) + else do + Monitoring.increment "storage.index.block.reused" + tryBlock nextBlockNumber (B.tail bstr) + + createIndexBlock = do + seek IndexFile 0 + header <- readData IndexFile + let newBlockNumber = ihBlocksCount header + 1 + let header' = header {ihBlocksCount = newBlockNumber} + bsize <- gets ssBoardSize + seek IndexFile 0 + writeData IndexFile header' + seek IndexFile $ calcIndexBlockOffset bsize newBlockNumber + let empty = B.replicate (fromIntegral $ indexBlockSize bsize) 0xff + writeBytes IndexFile empty + return newBlockNumber + + createDataBlock = do + seek DataFile 0 + header <- readData DataFile + let newBlockNumber = dhBlocksCount header + 1 + let header' = header {dhBlocksCount = newBlockNumber} + seek DataFile 0 + writeData DataFile header' + seek DataFile $ calcDataBlockOffset newBlockNumber + let empty = B.replicate (fromIntegral dataBlockSize) 0 + writeBytes DataFile empty + return newBlockNumber + +putRecordFile :: Board -> StorageValue -> Storage () +putRecordFile board value = Monitoring.timed "cache.put.file" $ do + let bstr = encodeBoard board + putRecordFileB bstr value + +putStatsFile :: Board -> Stats -> Storage () +putStatsFile board stats = do + return () +-- let newData = PerBoardData mempty (Just stats) +-- bstr = encodeBoard board +-- putRecordFileB bstr newData + +initFile :: Storage () +initFile = do + seek IndexFile 0 + writeData IndexFile $ IndexHeader 0 + bsize <- gets ssBoardSize + let empty = B.replicate (fromIntegral $ indexBlockSize bsize) 0xff + writeBytes IndexFile empty + seek DataFile 0 + writeData DataFile $ DataHeader 0 + return () + +-- dumpFile :: FilePath -> IO () +-- dumpFile path = withFile path ReadMode $ \file -> do +-- nBlocks <- readDataIO file :: IO Word16 +-- printf "Number of blocks: %d\n" nBlocks +-- forM_ [0 .. hashIndiciesCount - 1] $ \hashIndexNr -> do +-- printf "Hash index #%d:\n" hashIndexNr +-- forM_ [0 .. hashesCount - 1] $ \hash -> do +-- lastBlockNr <- readDataIO file :: IO BlockNumber +-- when (lastBlockNr /= unexistingBlock) $ do +-- printf " Hash %d, First:\tlast block #%d\n" hash lastBlockNr +-- lastBlockNr <- readDataIO file :: IO BlockNumber +-- when (lastBlockNr /= unexistingBlock) $ do +-- printf " Hash %d, Second:\tlast block #%d\n" hash lastBlockNr +-- forM_ [0 .. nBlocks - 1] $ \blockNr -> do +-- let blockOffset = fromIntegral $ calcBlockOffset (fromIntegral blockNr) +-- hSeek file AbsoluteSeek blockOffset +-- printf "Block #%d, offset %d\n" blockNr blockOffset +-- header <- readDataIO file :: IO BlockHeader +-- let nRecords = bhRecordsCount header +-- printf " Header: %s\n" (show header) +-- when (nRecords > 0) $ do +-- forM_ [0 .. nRecords - 1] $ \recordNr -> do +-- printf " Record #%d:\n" recordNr +-- ((bk, depth),item) <- readDataSizedIO file :: IO (StorageKey, StorageValue) +-- printf " Board key: %s\n" (show bk) +-- printf " Depth: %d\n" depth +-- printf " Value: %s\n" (show item) + +readDataIO :: forall a h. (Data.Store.Store a, File.FileAccess h) => h -> File.Offset -> IO a +readDataIO file offset = do + bstr <- File.readBytes file offset (fromIntegral $ sizeOf (error "unknown data size to read!" :: a)) + when (B.null bstr) $ do + fail $ "readDataIO: unexpected EOF, offset " ++ show offset + Data.Store.decodeIO bstr + +readDataSizedIO :: forall a h. (Data.Store.Store a, File.FileAccess h) => h -> File.Offset -> IO a +readDataSizedIO file offset = do + size <- readDataIO file offset :: IO Word16 + bstr <- File.readBytes file (offset + 2) (fromIntegral size) + when (B.null bstr) $ do + fail $ printf "readDataSizedIO: zero data size, offset %s, size %s" (show offset) (show size) + Data.Store.decodeIO bstr + +dumpIndexBlock :: File.FileAccess h => h -> BoardSize -> IndexBlockNumber -> IO () +dumpIndexBlock h bsize n = do + forM_ [0 .. 255] $ \char -> do + let offset = fromIntegral $ calcIndexOffset bsize n char + record <- readDataIO h offset + when (irDataBlock record /= unexistingBlock || irIndexBlock record /= unexistingBlock) $ + printf "Char #%d: next index #%d, data block #%d\n" char (irIndexBlock record) (irDataBlock 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 (start + 2) (fromIntegral size) + 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) + +data ParserState = ParserState { + psIndex :: File.MMaped + , psUnfinished :: M.Map IndexBlockNumber BL.ByteString + , psFinished :: M.Map BL.ByteString DataBlockNumber + } + +loadIndex :: StateT ParserState IO () +loadIndex = do + index <- gets psIndex + header <- liftIO $ readDataIO index 0 + let n = ihBlocksCount header + forM_ [0 .. n-1] loadBlock + where + bsize = (8,8) + + loadBlock :: IndexBlockNumber -> StateT ParserState IO () + loadBlock i = do + index <- gets psIndex + finished <- gets psFinished + liftIO $ printf "Block #%d; finished: %d\n" i (M.size finished) + records <- forM [0 .. 255] $ \char -> do + let offset = calcIndexOffset bsize i char + liftIO $ readDataIO index (fromIntegral offset) + unfinished <- gets psUnfinished + modify $ \st -> st {psUnfinished = M.delete i (psUnfinished st)} + let prefix = fromMaybe "" $ M.lookup i unfinished + forM_ (zip [0..] records) $ \(j, record) -> do + let prefix' = prefix `BL.append` BL.singleton j + when (irDataBlock record /= unexistingBlock) $ + modify $ \st -> st {psFinished = M.insert prefix' (irDataBlock record) (psFinished st)} + when (irIndexBlock record /= unexistingBlock) $ + modify $ \st -> st {psUnfinished = M.insert (irIndexBlock record) prefix' (psUnfinished st)} + +loadIndexIO :: FilePath -> IO (M.Map BL.ByteString DataBlockNumber) +loadIndexIO indexPath = do + let params = File.MMapedParams (1024*1024) False + index <- File.initFile params indexPath + let st = ParserState index M.empty M.empty + st' <- execStateT loadIndex st + File.closeFile index + putStrLn "index loaded." + return $ psFinished st' + +-- loadDataIO :: FilePath -> FilePath -> IO [(Board, PerBoardData)] +-- loadDataIO indexPath dataPath = do +-- index <- loadIndexIO indexPath +-- let params = File.MMapedParams (1024*1024) False +-- file <- File.initFile params +-- forM (M.assocs index) $ \(bstr, block) -> do + + diff --git a/src/AI/AlphaBeta/Types.hs b/src/AI/AlphaBeta/Types.hs new file mode 100644 --- /dev/null +++ b/src/AI/AlphaBeta/Types.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleInstances #-} + +module AI.AlphaBeta.Types + ( AlphaBeta (..), + AlphaBetaParams (..), + DepthParams (..), + dpLast, + Stats (..), + Bound (..), + PerBoardData (..), + AIData, StorageKey, StorageValue, + ScoreMoveInput (..), + QueueKey, + IndexBlockNumber, DataBlockNumber, + CleanupQueue, WriteQueue, FileDescriptor, + FHandle (..), + FileType (..), + MovesMemo, + AICacheHandle (..), + StorageState (..), + ScoreState (..), ScoreM (..), + ScoreInput (..), ScoreOutput (..), + DepthIterationInput, DepthIterationOutput, + AiOutput, + Storage, + runStorage + ) where + +import Control.Monad.State as St +import Control.Monad.Reader +import qualified Control.Monad.Metrics as Metrics +import Control.Concurrent.STM +import qualified Data.HashPSQ as PQ +import qualified Data.Map as M +import Data.Word +import Data.Binary +import Data.Store +import Data.Typeable +import Data.Default +import GHC.Generics +import System.Clock +import System.Posix.Types +import System.IO.RandomAccessFile +import System.Log.Heavy + +import Core.Types +import Core.Parallel + +-- | Alpha-beta prunning AI engine. +-- It is parametrized by game rules, evaluator +-- and an instance of Evaluator. +data AlphaBeta rules eval = AlphaBeta AlphaBetaParams rules eval + deriving (Eq, Ord, Show, Typeable) + +data AlphaBetaParams = AlphaBetaParams { + abDepth :: Int + , abStartDepth :: Maybe Int + , abCombinationDepth :: Int + , abDynamicDepth :: Int + , abDeeperIfBad :: Bool + , abMovesLowBound :: Int + , abMovesHighBound :: Int + , abBaseTime :: Maybe Int + } + deriving (Eq, Ord, Show) + +instance Default AlphaBetaParams where + def = AlphaBetaParams { + abDepth = 2 + , abStartDepth = Nothing + , abCombinationDepth = 8 + , abDynamicDepth = 8 + , abDeeperIfBad = False + , abMovesLowBound = 4 + , abMovesHighBound = 8 + , abBaseTime = Nothing + } + +-- 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 + , dpStaticMode :: Bool + , dpForcedMode :: Bool + } + deriving (Eq, Ord, Show, Typeable, Generic) + +dpLast :: DepthParams -> Int +dpLast dp = dpMax dp - dpCurrent dp + +instance Store DepthParams +instance Binary DepthParams + +data Stats = Stats { + statsCount :: ScoreBase + , statsMaxScore :: Score + , statsMinScore :: Score + , statsSumScore :: Score + } + deriving (Eq, Show, Generic, Typeable) + +instance Binary Stats +instance Store Stats + +instance Semigroup Stats where + s1 <> s2 = + Stats (statsCount s1 + statsCount s2) + (max (statsMaxScore s1) (statsMaxScore s2)) + (min (statsMinScore s1) (statsMinScore s2)) + (statsSumScore s1 + statsSumScore s2) + +instance Monoid Stats where + mempty = Stats 0 0 0 0 + +data Bound = Alpha | Beta | Exact + deriving (Generic, Typeable, Eq, Show) + +instance Binary Bound +instance Store Bound + +data PerBoardData = PerBoardData { + itemDepth :: Int + , itemScore :: Score + , itemBound :: Bound + , boardStats :: Maybe Stats + } + 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)} + +instance Monoid PerBoardData where + mempty = PerBoardData 0 0 Exact Nothing + +instance Binary PerBoardData +instance Store PerBoardData + +type AIData = TBoardMap PerBoardData + +type StorageKey = (DepthParams, BoardKey) + +type StorageValue = PerBoardData + +-- | Input for the `scoreMove` method +data ScoreMoveInput rules eval = ScoreMoveInput { + smiAi :: AlphaBeta rules eval + , smiCache :: AICacheHandle rules eval + , smiGameId :: GameId + , smiSide :: Side + , smiDepth :: DepthParams + , smiBoard :: Board + , smiMove :: PossibleMove + , smiAlpha :: Score + , smiBeta :: Score + } + +type QueueKey = (BoardCounts, BoardKey) + +type IndexBlockNumber = Word32 +type DataBlockNumber = Word32 + +data FileType = IndexFile | DataFile + deriving (Eq, Show) + +type MovesMemo = TBoardMap (Maybe [PossibleMove], Maybe [PossibleMove]) + +-- | 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) + , aichPossibleMoves :: MovesMemo + , aichLastMoveScoreShift :: TVar (M.Map GameId ScoreBase) + , aichWriteQueue :: WriteQueue + , aichCleanupQueue :: CleanupQueue + , aichCurrentCounts :: TVar BoardCounts + , aichIndexFile :: Maybe FHandle + , aichDataFile :: Maybe FHandle + } + +type WriteQueue = TChan (Board, StorageValue) + +type CleanupQueue = TVar (PQ.HashPSQ QueueKey TimeSpec ()) + +type FileDescriptor = MMaped + +-- | File handle +data FHandle = FHandle { + fhOffset :: FileOffset + , fhHandle :: FileDescriptor + } + +-- | State for the Storage monad +data StorageState = StorageState { + ssLogging :: LoggingTState + , ssMetrics :: Metrics.Metrics + , ssMetricsEnabled :: Bool + , ssBoardSize :: BoardSize + , ssIndex :: Maybe FHandle + , ssData :: Maybe FHandle + } + +-- | Storage monad. +type Storage a = StateT StorageState IO a + +instance HasMetricsConfig (StateT StorageState IO) where + isMetricsEnabled = gets ssMetricsEnabled + +instance HasLogContext (StateT StorageState IO) where + getLogContext = gets (ltsContext . ssLogging) + + withLogContext frame actions = do + logging <- gets ssLogging + let logging' = logging {ltsContext = frame : ltsContext logging} + modify $ \ss -> ss {ssLogging = logging'} + result <- actions + modify $ \ss -> ss {ssLogging = logging} + return result + +instance HasLogger (StateT StorageState IO) where + getLogger = gets (ltsLogger . ssLogging) + + localLogger logger actions = do + logging <- gets ssLogging + let logging' = logging {ltsLogger = logger} + modify $ \ss -> ss {ssLogging = logging'} + result <- actions + modify $ \ss -> ss {ssLogging = logging} + return result + +instance Metrics.MonadMetrics (StateT StorageState IO) where + getMetrics = gets ssMetrics + +-- | State of ScoreM monad. +data ScoreState rules eval = ScoreState { + ssRules :: rules + , ssEvaluator :: eval + , ssGameId :: GameId + , ssBestScores :: [Score] -- ^ At each level of depth-first search, there is own "best score" + , ssBestMoves :: M.Map Int (PossibleMove, Score) + , ssStartTime :: TimeSpec -- ^ Start time of calculation + , ssTimeout :: Maybe TimeSpec -- ^ Nothing for "no timeout" + } + +-- | Input data for scoreAB method. +data ScoreInput = ScoreInput { + siSide :: Side + , siDepth :: DepthParams + , siAlpha :: Score + , siBeta :: Score + , siBoard :: Board + , siPrevMove :: Maybe PossibleMove + } + +data ScoreOutput = ScoreOutput { + soScore :: Score + , soQuiescene :: Bool + } + +-- | ScoreM monad. +type ScoreM rules eval a = StateT (ScoreState rules eval) Checkers a + +instance HasMetricsConfig (StateT (ScoreState rules eval) Checkers) where + isMetricsEnabled = lift isMetricsEnabled + +instance HasLogger (StateT (ScoreState rules eval) Checkers) where + getLogger = lift getLogger + + localLogger logger actions = do + st <- St.get + (result, st') <- lift $ localLogger logger $ runStateT actions st + St.put st' + return result + +instance HasLogContext (StateT (ScoreState rules eval) Checkers) where + getLogContext = lift getLogContext + + withLogContext frame actions = do + st <- St.get + (result, st') <- lift $ withLogContext frame $ runStateT actions st + St.put st' + return result + +type DepthIterationInput = (AlphaBetaParams, [PossibleMove], Maybe DepthIterationOutput) +type DepthIterationOutput = [(PossibleMove, Score)] +type AiOutput = ([PossibleMove], Score) + +runStorage :: (GameRules rules, Evaluator eval) => AICacheHandle rules eval -> Storage a -> Checkers a +runStorage handle actions = do + lts <- asks csLogging + let indexHandle = aichIndexFile handle + let dataHandle = aichDataFile handle + let bsize = boardSize (aichRules handle) + metrics <- Metrics.getMetrics + metricsEnabled <- isMetricsEnabled + let initState = StorageState lts metrics metricsEnabled bsize indexHandle dataHandle + liftIO $ evalStateT actions initState + diff --git a/src/Core/Board.hs b/src/Core/Board.hs new file mode 100644 --- /dev/null +++ b/src/Core/Board.hs @@ -0,0 +1,764 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +module Core.Board where + +import Control.Monad +import Data.Maybe +import Data.List +import Data.String +import Data.Char (isDigit, toLower, toUpper) +import qualified Data.Map as M +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import qualified Data.Text as T +import Data.Array.IArray as A +import Data.Bits (xor) +import Text.Printf + +-- import Debug.Trace + +import Core.Types +import Core.BoardMap + +showAddress :: Address -> String +showAddress a = + printf "%s {UL: %s, UR: %s, DL: %s, DR: %s}" + (show $ aLabel a) + (maybe "X" (show . aLabel) $ aUpLeft a) + (maybe "X" (show . aLabel) $ aUpRight a) + (maybe "X" (show . aLabel) $ aDownLeft a) + (maybe "X" (show . aLabel) $ aDownRight a) + +showAddress2 :: Address -> String +showAddress2 a = + printf "%s {UL: (%s), UR: (%s), DL: (%s), DR: (%s)}" + (show $ aLabel a) + (maybe "X" showAddress $ aUpLeft a) + (maybe "X" showAddress $ aUpRight a) + (maybe "X" showAddress $ aDownLeft a) + (maybe "X" showAddress $ aDownRight a) + +opposite :: Side -> Side +opposite First = Second +opposite Second = First + +isMan :: Piece -> Bool +isMan (Piece kind _) = kind == Man + +isKing :: Piece -> Bool +isKing (Piece kind _) = kind == King + +promotePiece :: Piece -> Piece +promotePiece (Piece Man side) = Piece King side +promotePiece p = p + +promoteK :: PieceKind -> PieceKind +promoteK Man = King +promoteK King = King + +opponentPiece :: Piece -> Piece +opponentPiece (Piece k s) = Piece k (opposite s) + +allFields :: Board -> [FieldIndex] +allFields b = IM.keys (bAddresses b) + +allPieces :: Board -> [Maybe Piece] +allPieces b = + [getPiece' (Label col row) b | col <- [0 .. ncols-1], row <- [0 .. nrows-1]] + where + (ncols, nrows) = bSize b + +boardDirection :: BoardSide -> PlayerDirection -> BoardDirection +boardDirection Bottom ForwardLeft = UpLeft +boardDirection Bottom ForwardRight = UpRight +boardDirection Bottom BackwardLeft = DownLeft +boardDirection Bottom BackwardRight = DownRight +boardDirection Top ForwardLeft = DownRight +boardDirection Top ForwardRight = DownLeft +boardDirection Top BackwardLeft = UpRight +boardDirection Top BackwardRight = UpLeft + +boardSide :: BoardOrientation -> Side -> BoardSide +boardSide FirstAtBottom First = Bottom +boardSide FirstAtBottom Second = Top +boardSide SecondAtBottom First = Top +boardSide SecondAtBottom Second = Bottom + +playerSide :: BoardOrientation -> BoardSide -> Side +playerSide FirstAtBottom Bottom = First +playerSide FirstAtBottom Top = Second +playerSide SecondAtBottom Bottom = Second +playerSide SecondAtBottom Top = First + +myDirection :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> BoardDirection +myDirection rules side dir = boardDirection (boardSide (boardOrientation rules) side) dir + +playerDirection :: Side -> BoardDirection -> PlayerDirection +playerDirection First UpLeft = ForwardLeft +playerDirection First UpRight = ForwardRight +playerDirection First DownLeft = BackwardLeft +playerDirection First DownRight = BackwardRight +playerDirection Second UpLeft = BackwardRight +playerDirection Second UpRight = BackwardLeft +playerDirection Second DownLeft = ForwardRight +playerDirection Second DownRight = ForwardLeft + +oppositeDirection :: PlayerDirection -> PlayerDirection +oppositeDirection ForwardLeft = BackwardRight +oppositeDirection ForwardRight = BackwardLeft +oppositeDirection BackwardLeft = ForwardRight +oppositeDirection BackwardRight = ForwardLeft + +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 + +myNeighbour :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Maybe Address +myNeighbour rules side dir a = neighbour (myDirection rules side dir) a + +getNeighbourDirection :: Address -> Address -> Maybe BoardDirection +getNeighbourDirection src dst + | aUpLeft src == Just dst = Just UpLeft + | aUpRight src == Just dst = Just UpRight + | aDownLeft src == Just dst = Just DownLeft + | aDownRight src == Just dst = Just DownRight + | otherwise = Nothing + +getNeighbourDirection' :: Board -> Address -> Label -> Maybe BoardDirection +getNeighbourDirection' board src dst = + getNeighbourDirection src (resolve dst board) + +isValidDirection :: BoardDirection -> Address -> Bool +isValidDirection dir a = isJust (neighbour dir a) + +getNeighbourPiece :: BoardDirection -> Address -> Board -> Maybe Piece +getNeighbourPiece dir addr board = do + addr' <- neighbour dir addr + getPiece addr' board + +inDirection :: BoardDirection -> Address -> Int -> Maybe Address +inDirection _ src 0 = Just src +inDirection dir src 1 = neighbour dir src +inDirection dir src n = neighbour dir =<< inDirection dir src (n-1) + +getPieceInDirection :: BoardDirection -> Address -> Board -> Int -> Maybe Piece +getPieceInDirection dir src board n = do + dst <- inDirection dir src n + getPiece dst board + +isLastHorizontal :: Side -> Address -> Bool +isLastHorizontal side a = + aPromotionSide a == Just side + +isWithinBoard :: GameRules rules => rules -> Side -> Board -> Move -> Bool +isWithinBoard rules side board move = go (moveBegin move) (moveSteps move) + where + go _ [] = True + go addr (step : steps) = + case neighbour (myDirection rules side (sDirection step)) addr of + Just addr' -> go addr' steps + Nothing -> False + +allPassedAddresses :: GameRules rules => rules -> Side -> Board -> Move -> [Address] +allPassedAddresses rules side board move = moveBegin move : (reverse $ go [] (moveBegin move) (moveSteps move)) + where + go acc _ [] = acc + go acc addr (step : steps) = + case neighbour (myDirection rules side (sDirection step)) addr of + Just addr' -> go (addr' : acc) addr' steps + Nothing -> error $ "allPassedAddresses: invalid step: " ++ show step + +allPassedLabels :: GameRules rules => rules -> Side -> Board -> Move -> [Label] +allPassedLabels rules side board move = map aLabel $ allPassedAddresses rules side board move + +nonCaptureLabels :: GameRules rules => rules -> Side -> Board -> Move -> [Label] +nonCaptureLabels rules side board move = map aLabel $ + moveBegin move : (reverse $ go [] (moveBegin move) (moveSteps move)) + where + go acc _ [] = acc + go acc addr (step : steps) = + case neighbour (myDirection rules side (sDirection step)) addr of + Just addr' -> + if sCapture step + then go acc addr' steps + else go (addr' : acc) addr' steps + Nothing -> error $ "nonCaptureLabels: invalid step: " ++ show step + +isMyPiece :: Side -> Piece -> Bool +isMyPiece side (Piece _ s) = side == s + +isOpponentPiece :: Side -> Piece -> Bool +isOpponentPiece side (Piece _ s) = side /= s + +isMyPieceAt :: Side -> Address -> Board -> Bool +isMyPieceAt side addr board = + case getPiece addr board of + Nothing -> False + Just piece -> isMyPiece side piece + +isOpponentAt :: Side -> Address -> Board -> Bool +isOpponentAt side addr board = + case getPiece addr board of + Nothing -> False + Just piece -> isOpponentPiece side piece + +isFree :: Address -> Board -> Bool +isFree addr b = + not $ aLabel addr `labelSetMember` bOccupied b + +isFree' :: Label -> Board -> Bool +isFree' l b = isFree (resolve l b) b + +isFreeInDirection :: BoardDirection -> Address -> Board -> Int -> Bool +isFreeInDirection dir src board n = + case inDirection dir src n of + Nothing -> False + Just dst -> isNothing (getPiece dst board) + +allMyLabels :: Side -> Board -> [Label] +allMyLabels side board = myMen side board ++ myKings side board +-- allMyLabels side board = +-- [unpackIndex i | (i, p) <- A.assocs (bPieces board), check (boxPiece p)] +-- where +-- check (Just (Piece _ s)) = s == side +-- check _ = False + +myMen :: Side -> Board -> [Label] +myMen First board = labelSetToList $ bFirstMen board +myMen Second board = labelSetToList $ bSecondMen board +-- myMen side board = +-- [unpackIndex i | (i, p) <- A.assocs (bPieces board), check (boxPiece p)] +-- where +-- check (Just (Piece Man s)) = s == side +-- check _ = False + +myMenA :: Side -> Board -> [Address] +myMenA side board = + map (\l -> resolve l board) $ myMen side board + +myKings :: Side -> Board -> [Label] +myKings First board = labelSetToList $ bFirstKings board +myKings Second board = labelSetToList $ bSecondKings board +-- myKings side board = +-- [unpackIndex i | (i, p) <- A.assocs (bPieces board), check (boxPiece p)] +-- where +-- check (Just (Piece King s)) = s == side +-- check _ = False + +myKingsA :: Side -> Board -> [Address] +myKingsA side board = + map (\l -> resolve l board) $ myKings side board + +allMyAddresses :: Side -> Board -> [Address] +allMyAddresses side board = + map (\l -> resolve l board) $ allMyLabels side board + +allMyPieces :: Side -> Board -> [(Address, PieceKind)] +allMyPieces side board = + [(resolve l board, King) | l <- myKings side board] ++ + [(resolve l board, Man) | l <- myMen side board] + +myLabelsCount :: Side -> Board -> (Label -> Bool) -> (Int, Int) +myLabelsCount side board p = + (length $ filter p $ myMen side board, + length $ filter p $ myKings side board) + +myLabelsCount' :: Integral i => Side -> Board -> (Label -> i) -> (i, i) +myLabelsCount' side board w = + (sum $ map w $ myMen side board, + sum $ map w $ myKings side board) + +myAddressesCount' :: Integral i => Side -> Board -> (Address -> i) -> (i, i) +myAddressesCount' side board w = + (sum $ map w $ myMenA side board, + sum $ map w $ myKingsA side board) + +myCounts :: Side -> Board -> (Int, Int) +myCounts side board = + case side of + First -> (IS.size (bFirstMen board), IS.size (bFirstKings board)) + Second -> (IS.size (bSecondMen board), IS.size (bSecondKings board)) + +catMoves :: Move -> Move -> Move +catMoves m1 m2 = + Move (moveBegin m1) (moveSteps m1 ++ moveSteps m2) + +catPMoves :: PossibleMove -> PossibleMove -> PossibleMove +catPMoves pm1 pm2 = + PossibleMove { + pmBegin = pmBegin pm1, + pmEnd = pmEnd pm2, + pmVictims = pmVictims pm1 ++ pmVictims pm2, + pmMove = catMoves (pmMove pm1) (pmMove pm2), + pmPromote = pmPromote pm1 || pmPromote pm2, + pmResult = cat (pmResult pm1) (pmResult pm2) + } + where + cat lst1 lst2 = + case (last lst1, head lst2) of + (Put a1 _, Take a2) | a1 == a2 -> init lst1 ++ tail lst2 + _ -> lst1 ++ lst2 + +isCaptureM :: Move -> Bool +isCaptureM move = any sCapture (moveSteps move) + +isCapture :: PossibleMove -> Bool +isCapture pm = not $ null $ pmVictims pm + +isPromotion :: PossibleMove -> Bool +isPromotion = pmPromote + +capturesCount :: Move -> Int +capturesCount move = length $ filter sCapture (moveSteps move) + +capturesCounts :: GameRules rules => rules -> Move -> Board -> (Int, Int) +capturesCounts rules move board = +-- trace (printf "CC: %s" (show move)) $ + let captures = getCaptured rules move board + (men, kings) = partition isMan $ map snd captures + in (length men, length kings) + +applyStep :: HasBoardOrientation rules => rules -> Piece -> Address -> Step -> Board -> (Board, Address, Piece) +applyStep rules piece@(Piece _ side) src step board = + case neighbour (myDirection rules side (sDirection step)) src of + Nothing -> error $ "no such neighbour: " ++ show step + Just dst -> + let piece' = if sPromote step + then Piece King side + else piece + board' = setPiece dst piece' $ removePiece src board + in (board', dst, piece') + +-- case checkWellFormedStep piece board src step of +-- ValidStep dst -> +-- let piece' = if sPromote step +-- then Piece King side +-- else piece +-- board' = setPiece dst piece' $ removePiece src board +-- in (board', dst, piece') +-- err -> error $ printf "applyStep: Step is not well-formed: [%s at %s]: %s: %s" (show piece) (show src) (show step) (show err) + +applyMove :: HasBoardOrientation rules => rules -> Side -> Move -> Board -> (Board, Address, Piece) +applyMove rules side move board = go board piece (moveBegin move) (moveSteps move) + where + go b p src [] = (b, src, p) + go b p src (step : steps) = + let (b', dst, p') = applyStep rules p src step b + in go b' p' dst steps + + piece = getPiece_ "applyMove" (moveBegin move) board + +-- applyMove :: GameRules rules => rules -> Side -> Move -> Board -> (Board, Address, Piece) +-- applyMove rules side move board = +-- (board', dst, piece') +-- where +-- src = moveBegin move +-- dst = moveEnd rules side board move +-- piece' = if any sPromote (moveSteps move) +-- then promotePiece piece +-- else piece +-- board' = removeAll (map fst $ getCaptured rules move board) $! +-- removePiece src $! +-- setPiece dst piece' board +-- +-- removeAll (!list) b = foldr removePiece b list +-- +-- piece = getPiece_ "applyMove" (moveBegin move) board + +applyMoveAction :: MoveAction -> Board -> Either String Board +applyMoveAction (Take a) b = + if isFree a b + then Left $ printf "Take: no piece at %s; board: %s" (show a) (show b) + else Right $ removePiece a b +applyMoveAction (Put a p) b = Right $ setPiece a p b +applyMoveAction (RemoveCaptured a) b = + if isFree a b + then Left $ printf "RemoveCaptured: 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) + else Right $ b {bCaptured = insertLabelSet (aLabel a) (bCaptured b)} + +applyMoveActions' :: [MoveAction] -> Board -> Either String Board +applyMoveActions' actions board = do + board' <- foldM (flip applyMoveAction) board actions + let board'' = foldr removePiece' board' (labelSetToList $ bCaptured board') + return $ board'' {bCaptured = emptyLabelSet} + +applyMoveActions :: [MoveAction] -> Board -> Board +applyMoveActions actions board = + case applyMoveActions' actions board of + Left err -> error $ printf "applyMoveActions: %s; actions: %s; board: %s" err (show actions) (show board) + Right result -> result + +isCaptured :: Address -> Board -> Bool +isCaptured a b = aLabel a `labelSetMember` bCaptured b + +getCaptured :: GameRules rules => rules -> Move -> Board -> [(Address, Piece)] +getCaptured rules move board = go board (moveBegin move) (moveSteps move) + where + me = getPiece_ "getCaptured: me" (moveBegin move) board + + go _ _ [] = [] + go board addr (step : steps) = + if sCapture step + then let victim = getPiece_ "getCaptured" addr' board + (board', addr', _) = applyStep rules me addr step board + in (addr, victim) : go board' addr' steps + else let (board', addr', _) = applyStep rules me addr step board + in go board' addr' steps + +moveEnd :: GameRules rules => rules -> Side -> Board -> Move -> Address +moveEnd rules side board move = last $ allPassedAddresses rules side board move + +simpleMove :: GameRules rules => rules -> Side -> Address -> PlayerDirection -> Move +simpleMove rules side src dir = Move src [Step dir False promote] + where + promote = case neighbour (myDirection rules side dir) src of + Nothing -> False + Just dst -> isLastHorizontal side dst + +simpleCapture :: GameRules rules => rules -> Side -> Address -> PlayerDirection -> Move +simpleCapture rules side src dir = Move src [Step dir True False, Step dir False promote] + where + promote = case neighbour (myDirection rules side dir) =<< neighbour (myDirection rules side dir) src of + Nothing -> False + Just dst -> isLastHorizontal side dst + +kingMove :: Side -> Address -> PlayerDirection -> Int -> Move +kingMove side src dir n = Move src $ replicate n (Step dir False False) + +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 + update (label, piece) hash = updateBoardHash' table hash label piece + table = randomTable board + +updateBoardHash' :: RandomTable -> BoardHash -> Label -> Piece -> BoardHash +updateBoardHash' table hash (Label col row) piece = + hash `xor` (table A.! (unboxPiece (Just piece), mkIndex col row)) + +updateBoardHash :: Board -> Label -> Piece -> BoardHash +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) + label (r,c) = Label (c-1) (r-1) + + promote (r,_) + | r == 1 = Just $ playerSide orient Top + | r == nrows = Just $ playerSide orient Bottom + | otherwise = Nothing + + upLeft (r,c) + | r+1 > nrows || c-1 < 1 = Nothing + | otherwise = M.lookup (r+1, c-1) addresses + + upRight (r,c) + | r+1 > nrows || c+1 > ncols = Nothing + | otherwise = M.lookup (r+1, c+1) addresses + + downLeft (r,c) + | r-1 < 1 || c-1 < 1 = Nothing + | otherwise = M.lookup (r-1, c-1) addresses + + downRight (r,c) + | r-1 < 1 || c+1 > ncols = Nothing + | otherwise = M.lookup (r-1, 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] + + addressByLabel = buildLabelMap nrows ncols [(label p, address) | (p, address) <- M.assocs addresses] + + n2 = 16*16 + + -- boardData = A.listArray (0, n2-1) (replicate n2 0) + table = getRandomTable rnd + board = Board { + bAddresses = addressByLabel, + bCaptured = emptyLabelSet, + bOccupied = emptyLabelSet, + bFirstMen = emptyLabelSet, + bSecondMen = emptyLabelSet, + bFirstKings = emptyLabelSet, + bSecondKings = emptyLabelSet, + boardKey = IM.empty, + -- boardCounts = BoardCounts 0 0 0 0, + bSize = bsize, + boardHash = 0, + randomTable = table + } + + in board + +resolve :: Label -> Board -> Address +resolve label board = fromMaybe (error $ "resolve: unknown field: " ++ show label) $ lookupLabel label (bAddresses board) + +getPiece :: Address -> Board -> Maybe Piece +getPiece a b + | aLabel a `labelSetMember` bFirstKings b = Just $ Piece King First + | aLabel a `labelSetMember` bSecondKings b = Just $ Piece King Second + | aLabel a `labelSetMember` bFirstMen b = Just $ Piece Man First + | aLabel a `labelSetMember` bSecondMen b = Just $ Piece Man Second + | otherwise = Nothing + +isPieceAt :: Address -> Board -> Side -> Bool +isPieceAt a b side = + let label = aLabel a + in case side of + First -> label `labelSetMember` bFirstMen b || label `labelSetMember` bFirstKings b + Second -> label `labelSetMember` bSecondMen b || label `labelSetMember` bSecondKings b + +getPiece_ :: String -> Address -> Board -> Piece +getPiece_ name addr board = + case getPiece addr board of + Nothing -> error $ name ++ ": no piece at " ++ show addr + 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) + +getCapturablePiece :: Address -> Board -> Maybe Piece +getCapturablePiece a b = + if isCaptured a b + then Nothing + else getPiece a b + +setPiece :: Address -> Piece -> Board -> Board +setPiece a p b = board + where + b1 = if isFree a b + then b + else removePiece a b + b2 = case getPiece a b of + Nothing -> insertBoard a p b1 + Just old -> insertBoard a p $ removeBoard a old b1 + board = b2 { + boardHash = updateBoardHash b1 (aLabel a) p + } + +removePiece :: Address -> Board -> Board +removePiece a b = board + where + board = case getPiece a b of + Nothing -> error $ printf "removePiece: there is no piece at %s; board: %s" (show a) (show b) + Just piece -> + let b1 = removeBoard a piece b + b2 = b1 { + boardHash = updateBoardHash b (aLabel a) piece + } + in b2 + +removePiece' :: Label -> Board -> Board +removePiece' l b = removePiece (resolve l b) b + +movePiece :: Address -> Address -> Board -> Board +movePiece src dst board = + case getPiece src board of + Nothing -> error $ "movePiece: no piece at " ++ show src + Just piece -> setPiece dst piece $ removePiece src board + +movePiece' :: Label -> Label -> Board -> Board +movePiece' src dst board = + movePiece (resolve src board) (resolve dst board) board + +setPiece' :: Label -> Piece -> Board -> Board +setPiece' l p b = setPiece a p b + where + a = fromMaybe (error $ "setPiece': unknown field: " ++ show l) $ lookupLabel l (bAddresses b) + +setManyPieces :: [Address] -> Piece -> Board -> Board +setManyPieces addresses piece board = foldr (\a b -> setPiece a piece b) board addresses + +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) + labels1 = line1labels ++ line2labels ++ line3labels + labels2 = line8labels ++ line7labels ++ line6labels + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + +moveRep :: GameRules rules => rules -> Side -> Move -> MoveRep +moveRep rules side move = FullMoveRep (aLabel $ moveBegin move) $ rep (moveBegin move) (moveSteps move) + where + + rep _ [] = [] + rep prev (step@(Step dir capture promote) : steps) = + case neighbour (myDirection rules side dir) prev of + Nothing -> error $ "moveRep: invalid step: " ++ show step + Just addr -> (StepRep (aLabel addr) capture promote) : rep addr steps + +parseMoveRep :: GameRules rules => rules -> Side -> Board -> MoveRep -> MoveParseResult +parseMoveRep rules side board (ShortMoveRep from to) = + let moves = possibleMoves rules side board + suits pm = aLabel (pmBegin pm) == from && + aLabel (pmEnd pm) == to + in case filter suits moves of + [pm] -> Parsed $ pmMove pm + [] -> NoSuchMove + ms -> AmbigousMove ms +parseMoveRep rules side board (FullMoveRep from steps) = + case lookupLabel from (bAddresses board) of + Nothing -> NoSuchMove + Just src -> Parsed $ Move src $ parse src steps + where + parse _ [] = [] + parse prev (step@(StepRep dst capture promote) : steps) = + case getNeighbourDirection' board prev dst of + Nothing -> error $ "parseMoveRep: invalid step: " ++ show step + Just dir -> Step (playerDirection side dir) capture promote : parse (resolve dst board) steps + +boardAssocs :: Board -> [(Label, Piece)] +boardAssocs board = + [(label, Piece Man First) | label <- labelSetToList (bFirstMen board)] ++ + [(label, Piece Man Second) | label <- labelSetToList (bSecondMen board)] ++ + [(label, Piece King First) | label <- labelSetToList (bFirstKings board)] ++ + [(label, Piece King Second) | label <- labelSetToList (bSecondKings board)] + +boardRep :: Board -> BoardRep +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 + where + set (label, piece) board = setPiece' label piece board + bsize = boardSize rules + orient = boardOrientation rules + +-- | 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 + +instance IsString Label where + fromString str = + case parseChessNotationS str of + Left err -> error err + Right label -> label + +-- | Chess-like fields notation, like "A1" or "H8" +chessNotation :: Label -> Notation +chessNotation = T.pack . map toUpper . show + +-- | Parse chess-like fields notation. +parseChessNotation :: Notation -> Either String Label +parseChessNotation = parseChessNotationS . T.unpack + +-- | Parse chess-like fields notation. +parseChessNotationS :: String -> Either String Label +parseChessNotationS = parse . map toLower + where + parse (l:ds) + | all isDigit ds = + case elemIndex l letters of + Nothing -> Left $ "parseChessNotation: unknown letter: " ++ [l] + Just col -> let row = read ds - 1 + in Right $ Label (fromIntegral col) row + parse e = Left $ "parseChessNotation: cant parse: " ++ e + +-- | Numeric (international) fields notation +numericNotation :: BoardSize -> Label -> Notation +numericNotation (nrows, ncols) (Label col row) = + let half = ncols `div` 2 + row' = nrows - row - 1 + n = row' * half + (col `div` 2) + 1 + in T.pack $ show n + +-- | Parse numeric (international) fields notation +parseNumericNotation :: BoardSize -> Notation -> Either String Label +parseNumericNotation (nrows, ncols) t = parse (T.unpack t) + where + parse str + | all isDigit str = + let n = read str - 1 + half = ncols `div` 2 + row' = n `div` half + col' = n `mod` half + row = ncols - row' - 1 + col = if odd row + then col'*2 + 1 + else col'*2 + in Right $ Label col row + + | otherwise = Left $ "parseNumericNotation: Cant parse: " ++ str + +flipBoardKey :: BoardSize -> BoardKey -> BoardKey +flipBoardKey (nrows,ncols) bk = + IM.fromList $ map go $ IM.assocs bk + where + go (k, p) = (labelIndex $ flipLabel $ unpackIndex k, opponentPiece p) + flipLabel (Label col row) = Label (ncols - col - 1) (nrows - row - 1) + +flipBoardCounts :: BoardCounts -> BoardCounts +flipBoardCounts bc = + bc { + bcFirstMen = bcSecondMen bc, + bcSecondMen = bcFirstMen bc, + bcFirstKings = bcSecondKings bc, + bcSecondKings = bcFirstKings bc + } + +flipBoard :: Board -> Board +flipBoard b = b' {boardHash = hash} + where + b' = b { + bFirstMen = labelSetFromList $ map flipLabel (labelSetToList $ bSecondMen b), + bSecondMen = labelSetFromList $ map flipLabel (labelSetToList $ bFirstMen b), + bFirstKings = labelSetFromList $ map flipLabel (labelSetToList $ bSecondKings b), + bSecondKings = labelSetFromList $ map flipLabel (labelSetToList $ bFirstKings b), + bOccupied = labelSetFromList $ map flipLabel (labelSetToList $ bOccupied b) + -- boardCounts = flipBoardCounts (boardCounts b) + } + + hash = calcBoardHash b' + + (nrows, ncols) = bSize b + + flipLabel (Label col row) = Label (ncols - col - 1) (nrows - row - 1) + diff --git a/src/Core/BoardMap.hs b/src/Core/BoardMap.hs new file mode 100644 --- /dev/null +++ b/src/Core/BoardMap.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE BangPatterns #-} +module Core.BoardMap where + +import Control.Concurrent.STM +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import Data.Hashable +import qualified STMContainers.Map as SM +import Text.Printf + +import Core.Types + +boxPiece :: UnboxedPiece -> Maybe Piece +boxPiece 0 = Nothing +boxPiece 1 = Just $ Piece Man First +boxPiece 2 = Just $ Piece Man Second +boxPiece 3 = Just $ Piece King First +boxPiece 4 = Just $ Piece King Second + +unboxPiece :: Maybe Piece -> UnboxedPiece +unboxPiece Nothing = 0 +unboxPiece (Just (Piece Man First)) = 1 +unboxPiece (Just (Piece Man Second)) = 2 +unboxPiece (Just (Piece King First)) = 3 +unboxPiece (Just (Piece King Second)) = 4 + +calcBoardCounts :: Board -> BoardCounts +calcBoardCounts board = BoardCounts { + bcFirstMen = IS.size $ bFirstMen board + , bcFirstKings = IS.size $ bFirstKings board + , bcSecondMen = IS.size $ bSecondMen board + , bcSecondKings = IS.size $ bSecondKings board + } + +insertBoardCounts :: Piece -> BoardCounts -> BoardCounts +insertBoardCounts p bc = + case p of + Piece Man First -> bc {bcFirstMen = bcFirstMen bc + 1} + Piece Man Second -> bc {bcSecondMen = bcSecondMen bc + 1} + Piece King First -> bc {bcFirstKings = bcFirstKings bc + 1} + Piece King Second -> bc {bcSecondKings = bcSecondKings bc + 1} + +removeBoardCounts :: Piece -> BoardCounts -> BoardCounts +removeBoardCounts p bc = + case p of + Piece Man First -> bc {bcFirstMen = bcFirstMen bc - 1} + Piece Man Second -> bc {bcSecondMen = bcSecondMen bc - 1} + Piece King First -> bc {bcFirstKings = bcFirstKings bc - 1} + Piece King Second -> bc {bcSecondKings = bcSecondKings bc - 1} + +insertBoardKey :: Address -> Piece -> BoardKey -> BoardKey +insertBoardKey a p bk = IM.insert (aIndex a) p bk + +removeBoardKey :: Address -> Piece -> BoardKey -> BoardKey +removeBoardKey a p bk = IM.delete (aIndex a) bk + +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) + } + +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) + } + +newTBoardMap :: IO (TBoardMap a) +newTBoardMap = atomically SM.new + +putBoardMap :: TBoardMap a -> Board -> a -> IO () +putBoardMap bmap board value = atomically $ do + SM.insert value (boardHash board) bmap +-- mbByHash <- SM.lookup (boardCounts board) bmap +-- case mbByHash of +-- Just byHash -> SM.insert value (boardHash board) byHash +-- Nothing -> do +-- byHash <- SM.new +-- SM.insert value (boardHash board) byHash +-- SM.insert byHash (boardCounts board) bmap + +putBoardMapWith :: TBoardMap a -> (a -> a -> a) -> Board -> a -> IO () +putBoardMapWith bmap plus board value = atomically $ do + mbOld <- SM.lookup (boardHash board) bmap + case mbOld of + Nothing -> SM.insert value (boardHash board) bmap + Just old -> SM.insert (plus old value) (boardHash board) bmap +-- mbByHash <- SM.lookup (boardCounts board) bmap +-- byHash <- case mbByHash of +-- Nothing -> SM.new +-- Just byHash -> return byHash +-- mbOld <- SM.lookup (boardHash board) byHash +-- case mbOld of +-- Nothing -> SM.insert value (boardHash board) byHash +-- Just old -> SM.insert (plus old value) (boardHash board) byHash + +lookupBoardMap :: TBoardMap a -> Board -> IO (Maybe a) +lookupBoardMap bmap board = atomically $ do + SM.lookup (boardHash board) bmap +-- mbByHash <- SM.lookup (boardCounts board) bmap +-- case mbByHash of +-- Nothing -> return Nothing +-- Just byHash -> SM.lookup (boardHash board) byHash + +------------------ + +unpackIndex :: FieldIndex -> Label +unpackIndex n = + let col = n `div` 16 + row = n `mod` 16 + in Label (fromIntegral col) (fromIntegral row) + +aIndex :: Address -> FieldIndex +aIndex a = fromIntegral (labelColumn l) * 16 + fromIntegral (labelRow l) + where l = aLabel a + +mkIndex :: Line -> Line -> FieldIndex +mkIndex col row = fromIntegral col * 16 + fromIntegral row + +labelIndex :: Label -> FieldIndex +labelIndex (Label col row) = mkIndex col row + +buildLabelMap :: Line -> Line -> [(Label, a)] -> LabelMap a +buildLabelMap nrows ncols pairs = + IM.fromList [(mkIndex col row, value) | (Label col row, value) <- pairs] + +lookupLabel :: Label -> LabelMap a -> Maybe a +lookupLabel (Label col row) lmap = IM.lookup (mkIndex col row) lmap + +emptyAddressMap :: BoardSize -> AddressMap a +emptyAddressMap (nrows,ncols) = IM.empty + +lookupAddress :: Address -> AddressMap a -> Maybe a +lookupAddress a amap = IM.lookup (aIndex a) amap + +setAddress :: Address -> a -> AddressMap a -> AddressMap a +setAddress a x amap = IM.insert (aIndex a) x amap + +removeAddress :: Address -> AddressMap a -> AddressMap a +removeAddress a amap = IM.delete (aIndex a) amap + +addressMapContains :: Label -> AddressMap a -> Bool +addressMapContains (Label col row) amap = IM.member (mkIndex col row) amap + +findLabels :: (a -> Bool) -> AddressMap a -> [Label] +findLabels fn amap = [unpackIndex idx | idx <- IM.keys $ IM.filter fn amap] + +countAddresses :: (a -> Bool) -> AddressMap a -> Int +countAddresses fn amap = length $ findLabels fn amap + +occupiedLabels :: AddressMap a -> [(Label, a)] +occupiedLabels amap = [(unpackIndex idx, value) | (idx, value) <- IM.assocs amap] + +labelMapKeys :: LabelMap a -> [Label] +labelMapKeys lmap = map unpackIndex $ IM.keys lmap + +-------------------- + +emptyLabelSet :: LabelSet +emptyLabelSet = IS.empty + +labelSetToList :: LabelSet -> [Label] +labelSetToList set = map unpackIndex $ IS.toList set + +labelSetFromList :: [Label] -> LabelSet +labelSetFromList list = IS.fromList [mkIndex col row | Label col row <- list] + +insertLabelSet :: Label -> LabelSet -> LabelSet +insertLabelSet (Label col row) set = IS.insert (mkIndex col row) set + +deleteLabelSet :: Label -> LabelSet -> LabelSet +deleteLabelSet (Label col row) set = IS.delete (mkIndex col row) set + +labelSetMember :: Label -> LabelSet -> Bool +labelSetMember (Label col row) set = IS.member (mkIndex col row) set + +instance Hashable IS.IntSet where + hashWithSalt salt set = hashWithSalt salt (IS.toList set) + +instance Show Board where + show b = printf "{First Men: %s; Second Men: %s; First Kings: %s; Second Kings: %s}" + (show $ labelSetToList $ bFirstMen b) + (show $ labelSetToList $ bSecondMen b) + (show $ labelSetToList $ bFirstKings b) + (show $ labelSetToList $ bSecondKings b) + diff --git a/src/Core/Checkers.hs b/src/Core/Checkers.hs new file mode 100644 --- /dev/null +++ b/src/Core/Checkers.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Core.Checkers where + +import Control.Monad (when) +import Control.Concurrent +import qualified Control.Monad.Metrics as Metrics +import Data.Maybe +import qualified Data.Text.Encoding as TE +import System.Log.Heavy +import qualified System.Metrics as EKG +import qualified System.Remote.Monitoring as EKG +import Lens.Micro ((^.)) + +import Core.Types +import Core.CmdLine +import Core.Config +import Core.Supervisor + +isGameMessage :: LogMessage -> Bool +isGameMessage msg = + isJust $ gameIdFromLogMsg msg + +withCheckers :: CmdLine -> Checkers a -> IO a +withCheckers cmd actions = do + supervisor <- mkSupervisor + cfg <- loadConfig cmd + print cfg + logChan <- newChan + metrics <- Metrics.initialize + when (gcEnableMetrics cfg) $ do + let store = metrics ^. Metrics.metricsStore + EKG.registerGcMetrics store + EKG.forkServerWith store (TE.encodeUtf8 $ gcHost cfg) (gcMetricsPort cfg) + return () + let file = (defFileSettings (gcLogFile cfg)) { + lsFormat = "{time} [{level}] {source} [{game}|{thread}]: {message}\n" + } + game = Filtering isGameMessage $ ChanLoggerSettings logChan + logSettings = ParallelLogSettings [LoggingSettings game, LoggingSettings file] + withLoggingB logSettings $ \backend -> do + let logger = makeLogger backend + logging = LoggingTState logger (AnyLogBackend backend) [] + cs = CheckersState logging supervisor metrics cfg + actions' = do + forkCheckers $ logRouter supervisor logChan + actions + res <- runCheckersT actions' cs + case res of + Right result -> return result + Left err -> fail $ show err + diff --git a/src/Core/CmdLine.hs b/src/Core/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Core/CmdLine.hs @@ -0,0 +1,45 @@ + +module Core.CmdLine where + +import Options.Applicative +import Data.Semigroup ((<>)) +import Data.Char (toLower) + +data CmdLine = CmdLine { + cmdConfigPath :: Maybe FilePath + , cmdLocal :: Maybe Bool + , cmdSpecial :: Maybe String + } + deriving (Eq, Show) + +bool :: ReadM Bool +bool = eitherReader $ \str -> + case map toLower str of + "on" -> Right True + "true" -> Right True + "off" -> Right False + "false" -> Right False + _ -> Left $ "Unknown boolean value: " ++ str + +cmdline :: Parser CmdLine +cmdline = CmdLine + <$> optional (strOption + ( long "config" + <> short 'c' + <> metavar "PATH" + <> help "Path to the config file" ) ) + <*> optional (option bool + ( long "local" + <> short 'L' + <> metavar "on|off" + <> help "Run server in local mode" ) ) + <*> optional (strOption + ( long "special" + <> metavar "COMMAND" ) ) + +parserInfo :: ParserInfo CmdLine +parserInfo = info (cmdline <**> helper) + ( fullDesc + <> progDesc "HCheckers server application" + <> header "Run HCheckers server" ) + diff --git a/src/Core/Config.hs b/src/Core/Config.hs new file mode 100644 --- /dev/null +++ b/src/Core/Config.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module Core.Config + (locateConfig, loadConfig + ) where + +import Data.Yaml +import Data.Default +import System.FilePath +import System.Directory +import System.Environment + +import Core.Types +import Core.CmdLine +import Core.Json () -- import instances only + +locateConfig :: IO (Maybe FilePath) +locateConfig = do + home <- getEnv "HOME" + let homePath = home ".config" "hcheckers" "server.yaml" + ex <- doesFileExist homePath + if ex + then return $ Just homePath + else do + let etcPath = "/etc" "hcheckers" "server.yaml" + ex <- doesFileExist etcPath + if ex + then return $ Just etcPath + else return Nothing + +loadConfig :: CmdLine -> IO GeneralConfig +loadConfig cmd = do + mbPath <- + case cmdConfigPath cmd of + Nothing -> locateConfig + Just path -> return (Just path) + config <- + case mbPath of + Nothing -> return def + Just path -> do + putStrLn $ "Using config: " ++ path + r <- decodeFileEither path + case r of + Left err -> fail $ show err + Right cfg -> return cfg + let config' = case cmdLocal cmd of + Nothing -> config + Just local -> config {gcLocal = local} + return config' + diff --git a/src/Core/Evaluator.hs b/src/Core/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Core/Evaluator.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Core.Evaluator + ( SimpleEvaluator (..), + defaultEvaluator + ) where + +import Data.Aeson +import Data.Aeson.Types ( parseMaybe ) +import Data.Default + +import Core.Types +import Core.Board + +data SimpleEvaluator = SimpleEvaluator { + seRules :: SomeRules, + seUsePositionalScore :: Bool, + seMobilityWeight :: ScoreBase, + seCenterWeight :: ScoreBase, + seOppositeSideWeight :: ScoreBase, + seBackedWeight :: ScoreBase, + seAsymetryWeight :: ScoreBase, + sePreKingWeight :: ScoreBase, + seKingCoef :: ScoreBase, + seHelpedKingCoef :: ScoreBase + } + deriving (Show) + +defaultEvaluator :: GameRules 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 + } + +data PreScore = PreScore { + psNumeric :: ScoreBase + , psMobility :: ScoreBase + , psCenter :: ScoreBase + , psTemp :: ScoreBase + , psBacked :: ScoreBase + , psAsymetry :: ScoreBase + , psPreKing :: ScoreBase + } + +sub :: PreScore -> PreScore -> PreScore +sub ps1 ps2 = PreScore + { psNumeric = psNumeric ps1 - psNumeric ps2 + , psMobility = psMobility ps1 - psMobility ps2 + , psCenter = psCenter ps1 - psCenter ps2 + , psTemp = psTemp ps1 - psTemp ps2 + , psBacked = psBacked ps1 - psBacked ps2 + , psAsymetry = psAsymetry ps1 - psAsymetry ps2 + , psPreKing = psPreKing ps1 - psPreKing ps2 + } + +instance Default PreScore where + def = PreScore { + psNumeric = 0 + , psMobility = 0 + , psCenter = 0 + , psTemp = 0 + , psBacked = 0 + , psAsymetry = 0 + , psPreKing = 0 + } + +preEval :: SimpleEvaluator -> Side -> Board -> PreScore +preEval (SimpleEvaluator { seRules = SomeRules rules, ..}) side board = + let + kingCoef = + -- 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 + + numericScore = + let (myMen, myKings) = myCounts side board + in kingCoef * fromIntegral myKings + fromIntegral myMen + + (nrows, ncols) = bSize board + 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 - halfRow && row < crow + halfRow) + + isLeftHalf (Label col _) = col >= ccol + + asymetry = + let (leftMen , leftKings ) = myLabelsCount side board isLeftHalf + (rightMen, rightKings) = myLabelsCount side board (not . isLeftHalf) + in abs $ (leftMen + leftKings) - (rightMen + rightKings) + + isBackedAt addr dir = + case myNeighbour rules side dir addr of + Nothing -> True + Just back -> isPieceAt back board side + + backedScoreOf addr = + length $ filter (isBackedAt addr) [BackwardLeft, BackwardRight] + + 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 + Top -> nrows - row + Bottom -> row + 1 + + -- opponentSideCount :: Side -> Int + opponentSideCount = + let (men, kings) = myLabelsCount' side board tempNumber in men + + preKing board src = sum $ map check [ForwardLeft, ForwardRight] + where + check dir = + case myNeighbour rules side dir src of + Nothing -> 0 + Just dst -> if isLastHorizontal side dst && isFree dst board + then 1 + else 0 + + preKings = + let (men, kings) = myAddressesCount' side board (preKing board) in men + + mobility = mobilityScore rules side board + + centerScore = + let (men, kings) = myLabelsCount side board isCenter + in kingCoef * fromIntegral kings + fromIntegral men + in + PreScore + { psNumeric = numericScore + , psMobility = fromIntegral mobility + , psCenter = centerScore + , psTemp = fromIntegral opponentSideCount + , psBacked = fromIntegral backedScore + , psAsymetry = fromIntegral asymetry + , psPreKing = fromIntegral preKings + } + +preEvalBoth :: SimpleEvaluator -> Board -> PreScore +preEvalBoth eval board = + preEval eval First board `sub` preEval eval Second board + +instance Evaluator SimpleEvaluator where + evaluatorName _ = "simple" + + updateEval e (Object v) = + case parseMaybe (.: "use_positional_score") v of + Nothing -> e + Just Nothing -> e + Just (Just True) -> e {seUsePositionalScore = True} + Just (Just False) -> e {seUsePositionalScore = False} + + evalBoard eval@(SimpleEvaluator {..}) whoAsks board = + let ps1 = preEval eval whoAsks board + ps2 = preEval eval (opposite whoAsks) board + + positionalScore ps = + if seUsePositionalScore + then + seCenterWeight * psCenter ps + + seOppositeSideWeight * psTemp ps + + seMobilityWeight * psMobility ps + + seBackedWeight * psBacked ps + + seAsymetryWeight * psAsymetry ps + + sePreKingWeight * psPreKing ps + else 0 + + myNumeric = psNumeric ps1 + opponentNumeric = psNumeric ps2 + + myScore = Score myNumeric (positionalScore ps1) + opponentScore = Score opponentNumeric (positionalScore ps2) + + in if myNumeric == 0 + then loose + else if opponentNumeric == 0 + then win + else (myScore - opponentScore) + +-- data ComplexEvaluator rules = ComplexEvaluator { +-- ceRules :: rules +-- , ceCaptureManCoef :: Score +-- , ceCaptureKingCoef :: Score +-- } +-- deriving (Eq, Show) +-- +-- instance GameRules rules => Evaluator (ComplexEvaluator rules) where +-- evaluatorName _ = "complex" +-- +-- evalBoard ce whoAsks whoMovesNext board = +-- let rules = ceRules ce +-- allMyMoves = possibleMoves rules whoAsks board +-- allOpponentMoves = possibleMoves rules (opposite whoAsks) board +-- +-- myMoves = if whoAsks == whoMovesNext +-- then allMyMoves +-- else filter (not . isCapture) allMyMoves +-- opponentMoves = if whoAsks == whoMovesNext +-- then filter (not . isCapture) allOpponentMoves +-- else allOpponentMoves +-- +-- (myMen, myKings) = myCounts whoAsks board +-- (opponentMen, opponentKings) = myCounts (opposite whoAsks) board +-- +-- in if (myMen == 0 && myKings == 0) || null allMyMoves +-- then {- trace (printf "Side %s loses" (show whoAsks)) -} (-win) +-- else if (opponentMen == 0 && opponentKings == 0) || null allOpponentMoves +-- then {- trace (printf "Side %s wins" (show whoAsks)) -} win +-- else let movesScore s ms = if all isCapture ms +-- then let (men, kings) = unzip [capturesCounts rules move board | move <- ms] +-- maxMen = if null men then 0 else maximum men +-- maxKings = if null kings then 0 else maximum kings +-- in fromIntegral $ +-- -- trace (printf "Side %s possible captures: %s men, %s kings" (show s) (show men) (show kings)) $ +-- (ceCaptureManCoef ce) * fromIntegral maxMen + (ceCaptureKingCoef ce) * fromIntegral maxKings +-- else fromIntegral $ length ms +-- myMovesScore = movesScore whoAsks myMoves +-- opponentMovesScore = movesScore (opposite whoAsks) opponentMoves +-- in -- trace (printf "Side %s moves score %d, opponent moves score %d, total score = %d" (show whoAsks) myMovesScore opponentMovesScore (myMovesScore - opponentMovesScore)) $ +-- (myMovesScore - opponentMovesScore) +-- diff --git a/src/Core/Game.hs b/src/Core/Game.hs new file mode 100644 --- /dev/null +++ b/src/Core/Game.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} + +{- + - Game is a record for interaction between two players. + - It is created in New status, and there are no players in the game at that moment. + - Then two players are attached to the game (in any order). Each player can be a + - human user or an AI (NB: having two AI players in one game is not supported + - currently by Supervisor). + - After both players are attached, the game can be switched to Running state. + -} + +module Core.Game where + +import Control.Monad.State +import Control.Monad.Except +import Control.Concurrent.STM + +import Core.Types +import Core.Board + +-- | A monad to track game's state +type GameM a = ExceptT Error (State Game) a + +-- | Initialize Game instance +mkGame :: GameRules rules => SupervisorState -> rules -> Int -> Side -> Maybe BoardRep -> STM Game +mkGame supervisor rules id firstSide mbBoardRep = do + let board = case mbBoardRep of + Nothing -> initBoard supervisor rules + Just rep -> parseBoardRep supervisor rules rep + st = GameState firstSide board [] + msgbox1 <- newTChan + msgbox2 <- newTChan + return $ Game { + getGameId = show id, + gInitialBoard = board, + gState = st, + gStatus = New, + gRules = SomeRules rules, + gPlayer1 = Nothing, + gPlayer2 = Nothing, + gMsgbox1 = msgbox1, + gMsgbox2 = msgbox2 + } + +-- | Check current game status. +-- Throw an error if it is not as expected. +-- Do nothing otherwise. +checkStatus :: GameStatus -> GameM () +checkStatus expected = do + status <- gets gStatus + when (status /= expected) $ + throwError $ InvalidGameStatus expected status + +checkCurrentSide :: Side -> GameM () +checkCurrentSide side = do + currentSide <- gets (gsSide . gState) + when (side /= currentSide) $ + throwError NotYourTurn + +-- | get currently possible moves in this game +gamePossibleMoves :: GameM [Move] +gamePossibleMoves = do + -- checkStatus Running + SomeRules rules <- gets gRules + board <- gets (gsCurrentBoard . gState) + currentSide <- gets (gsSide . gState) + return $ map pmMove $ possibleMoves rules currentSide board + +-- | get current state of the game +gameState :: GameM (Side, GameStatus, Board) +gameState = do + st <- gets gState + status <- gets gStatus + return (gsSide st, status, gsCurrentBoard st) + +-- | Get game's history +gameHistory :: GameM [HistoryRecordRep] +gameHistory = do + history <- gets (gsHistory . gState) + some <- gets gRules + return $ map (rep some) history + where + rep (SomeRules rules) r = + let side = hrSide r + in HistoryRecordRep side (moveRep rules side $ hrMove r) + +-- | Move result. Contains resulting board and a list of notification messages. +data GMoveRs = GMoveRs Board [Notify] + +-- | Perform specified move +doMoveRq :: Side -> Move -> GameM GMoveRs +doMoveRq side move = do + checkStatus Running + checkCurrentSide side + SomeRules rules <- gets gRules + board <- gets (gsCurrentBoard . gState) + if move `notElem` (map pmMove $ possibleMoves rules side board) + then throwError NotAllowedMove + else do + let (board', _, _) = applyMove rules side move board + moveMsg = MoveNotify (opposite side) side (moveRep rules side move) (boardRep board') + mbResult = getGameResult rules board' + messages = case mbResult of + Nothing -> [moveMsg] + Just result -> + let resultMsg to = ResultNotify to side result + in [moveMsg, resultMsg First, resultMsg Second] + modify $ \game -> game {gState = pushMove move board' (gState game)} + case mbResult of + Just result -> + modify $ \game -> game {gStatus = Ended result} + _ -> return () + return $ GMoveRs board' messages + +-- | Perform specified move, parsing it from MoveRep +doMoveRepRq :: Side -> MoveRep -> GameM GMoveRs +doMoveRepRq side mRep = do + SomeRules rules <- gets gRules + board <- gets (gsCurrentBoard . gState) + case parseMoveRep rules side board mRep of + NoSuchMove -> throwError NoSuchMoveError + AmbigousMove moves -> throwError $ AmbigousMoveError $ map (moveRep rules side . pmMove) moves + Parsed move -> doMoveRq side move + +-- | Undo result +data GUndoRs = GUndoRs Board [Notify] + +-- | Execute undo +doUndoRq :: Side -> GameM GUndoRs +doUndoRq side = do + checkStatus Running + checkCurrentSide side + st <- gets gState + case popMove st of + Nothing -> throwError NothingToUndo + Just (prevBoard, prevSt) -> do + let push = UndoNotify (opposite side) side (boardRep prevBoard) + modify $ \game -> game {gState = prevSt} + return $ GUndoRs prevBoard [push] + +pushMove :: Move -> Board -> GameState -> GameState +pushMove move board st = + st { + gsSide = opposite (gsSide st), + gsCurrentBoard = board, + gsHistory = HistoryRecord (gsSide st) move (gsCurrentBoard st) : gsHistory st + } + +popMove :: GameState -> Maybe (Board, GameState) +popMove st = + case gsHistory st of + (_ : prevRecord : prevHistory) -> + let board = hrPrevBoard prevRecord + st' = st {gsCurrentBoard = board, gsHistory = prevHistory} + in Just (board, st') + _ -> Nothing + +doCapitulateRq :: Side -> GameM GameResult +doCapitulateRq side = do + checkStatus Running + checkCurrentSide side + let result = case side of + First -> SecondWin + Second -> FirstWin + modify $ \game -> game {gStatus = Ended result} + return result + +doPostDrawRequest :: Side -> GameM () +doPostDrawRequest side = do + checkStatus Running + checkCurrentSide side + modify $ \game -> game {gStatus = DrawRequested side} + +doDrawAcceptRq :: Side -> Bool -> GameM () +doDrawAcceptRq side accepted = do + checkStatus (DrawRequested (opposite side)) + if accepted + then modify $ \game -> game {gStatus = Ended Draw} + else modify $ \game -> game {gStatus = Running} + diff --git a/src/Core/Json.hs b/src/Core/Json.hs new file mode 100644 --- /dev/null +++ b/src/Core/Json.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +module Core.Json where + +import Control.Concurrent +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T +import Data.Default +import System.Log.Heavy + +import Core.Types +import Core.Logging +import Core.Supervisor + +instance ToJSON PlayerDirection where + +instance ToJSON PieceKind + +instance FromJSON PieceKind + +instance ToJSON Side + +instance FromJSON Side + +instance ToJSON GameResult + +instance ToJSON BoardOrientation + +instance ToJSON Label where + toJSON (Label col row) = toJSON (col, row) + +instance FromJSON Label where + parseJSON v = do + (col,row) <- parseJSON v + return $ Label col row + +instance ToJSON Step where + toJSON (Step direction capture promote) = + object ["direction" .= direction, "capture" .= capture, "promote" .= promote] + +instance ToJSON StepRep where + toJSON (StepRep field capture promote) = + object ["field" .= field, "capture" .= capture, "promote" .= promote] + +instance ToJSON MoveRep where + toJSON (ShortMoveRep from to) = object ["from" .= from, "to" .= to] + toJSON (FullMoveRep from steps) = + object ["from" .= from, "steps" .= steps] + +instance FromJSON MoveRep where + parseJSON (Object v) = ShortMoveRep + <$> v .: "from" + <*> v .: "to" + parseJSON invalid = typeMismatch "MoveRep" invalid + +instance ToJSON HistoryRecordRep where + toJSON r = object ["side" .= hrrSide r, "move" .= hrrMove r] + +instance ToJSON Piece where + toJSON (Piece kind side) = object ["kind" .= kind, "side" .= side] + +instance FromJSON Piece where + parseJSON (Object v) = Piece + <$> v .: "kind" + <*> v .: "side" + parseJSON invalid = typeMismatch "Piece" invalid + +instance ToJSON BoardRep where + toJSON (BoardRep list) = toJSON list + +instance FromJSON BoardRep where + parseJSON v = BoardRep <$> parseJSON v + +instance ToJSON ThreadId where + toJSON id = toJSON (show id) + +-- instance FromJSON ThreadId where +-- parseJSON (String text) = return $ read $ T.unpack text +-- parseJSON invalid = typeMismatch "ThreadId" invalid + +instance ToJSON Player where + toJSON (User name) = toJSON name + toJSON (AI ai) = toJSON (aiName ai) + +instance ToJSON SomeRules where + toJSON (SomeRules rules) = toJSON (rulesName rules) + +instance ToJSON GameStatus where + toJSON New = toJSON ("New" :: T.Text) + toJSON Running = toJSON ("Running" :: T.Text) + toJSON (DrawRequested side) = object ["draw_requested" .= side] + toJSON (Ended result) = toJSON result + +instance ToJSON Game where + toJSON g = + object ["id" .= getGameId g, + "rules" .= gRules g, + "status" .= gStatus g, + "first" .= gPlayer1 g, + "second" .= gPlayer2 g + ] + +-- instance FromJSON Player + +instance FromJSON NewGameRq where + parseJSON = withObject "NewGame" $ \v -> NewGameRq + <$> v .: "rules" + <*> v .:? "params" .!= Null + <*> v .:? "board" + <*> v .:? "fen" + <*> v .:? "pdn" + <*> v .:? "previous_board" + +instance FromJSON AttachAiRq where + parseJSON = withObject "AttachAi" $ \v -> AttachAiRq + <$> v .: "ai" + <*> v .:? "params" .!= Null + +instance ToJSON Notify where + toJSON (MoveNotify to from move board) = + object ["to_side" .= to, "from_side" .= from, "move" .= move, "board" .= board] + toJSON (UndoNotify to from board) = + object ["to_side" .= to, "from_side" .= from, "undo" .= True, "board" .= board] + toJSON (ResultNotify to from result) = + object ["to_side" .= to, "from_side" .= from, "result" .= result] + toJSON (DrawRqNotify to from) = + object ["to_side" .= to, "from_side" .= from, "draw" .= ("requested" :: T.Text)] + toJSON (DrawRsNotify to from accepted) = + object ["to_side" .= to, "from_side" .= from, "draw_accepted" .= accepted] + toJSON (LogNotify to level src text) = + object ["to_side" .= to, "source" .= src, "level" .= level, "message" .= text] + +instance ToJSON RsPayload where + toJSON (NewGameRs id side) = object ["id" .= id, "turn" .= side] + toJSON RegisterUserRs = object ["register_user" .= ("ok" :: T.Text)] + toJSON AttachAiRs = object ["attach_ai" .= ("ok" :: T.Text)] + toJSON RunGameRs = object ["run_game" .= ("ok" :: T.Text)] + toJSON (PollRs messages) = toJSON messages + toJSON (StateRs board status side) = object ["board" .= board, "side" .= side, "status" .= status] + toJSON (HistoryRs records) = toJSON records + toJSON (PossibleMovesRs moves) = toJSON moves + toJSON (MoveRs board) = toJSON board + toJSON (UndoRs board) = toJSON board + toJSON CapitulateRs = object ["capitulate" .= ("ok" :: T.Text)] + toJSON DrawRqRs = object ["draw_request" .= ("pending" :: T.Text)] + toJSON (DrawAcceptRs accepted) = object ["draw_accepted" .= accepted] + toJSON (LobbyRs games) = toJSON games + toJSON (NotationRs size orientation list) = + object ["size" .= size, "orientation" .= orientation, "notation" .= list] + toJSON ShutdownRs = object ["shutdown" .= ("ok" :: T.Text)] + +instance ToJSON Response where + toJSON (Response payload messages) = object ["response" .= payload, "messages" .= messages] + +instance FromJSON AiConfig where + parseJSON = withObject "AiConfig" $ \v -> AiConfig + <$> v .:? "threads" .!= (aiThreads def) + <*> v .:? "load" .!= (aiLoadCache def) + <*> v .:? "store" .!= (aiStoreCache def) + <*> v .:? "use_cache_max_depth" .!= (aiUseCacheMaxDepth def) + <*> v .:? "use_cache_max_pieces" .!= (aiUseCacheMaxPieces def) + <*> v .:? "use_cache_max_depth_plus" .!= (aiUseCacheMaxDepthPlus def) + <*> v .:? "use_cache_max_depth_minus" .!= (aiUseCacheMaxDepthMinus def) + <*> v .:? "update_cache_max_depth" .!= (aiUpdateCacheMaxDepth def) + <*> v .:? "update_cache_max_pieces" .!= (aiUpdateCacheMaxPieces def) + +instance FromJSON GeneralConfig where + parseJSON = withObject "GeneralConfig" $ \v -> GeneralConfig + <$> v .:? "host" .!= (gcHost def) + <*> v .:? "port" .!= (gcPort def) + <*> v .:? "local" .!= (gcLocal def) + <*> v .:? "enable_metrics" .!= (gcEnableMetrics def) + <*> v .:? "metrics_port" .!= (gcMetricsPort def) + <*> v .:? "log_path" .!= (gcLogFile def) + <*> v .:? "log_level" .!= (gcLogLevel def) + <*> v .:? "ai" .!= (gcAiConfig def) + +instance FromJSON Level where + parseJSON (String "debug") = return debug_level + parseJSON (String "verbose") = return verbose_level + parseJSON (String "trace") = return trace_level + parseJSON (String "info") = return info_level + parseJSON (String "warning") = return warn_level + parseJSON (String "error") = return error_level + parseJSON (String "fatal") = return fatal_level + parseJSON (String "disable") = return disable_logging + parseJSON invalid = typeMismatch "logging level" invalid + diff --git a/src/Core/Logging.hs b/src/Core/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Core/Logging.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Core.Logging where + +import Language.Haskell.TH.Syntax +import qualified System.Posix.Syslog as Syslog +import System.Log.Heavy +import System.Log.Heavy.TH + +verbose_level :: Level +verbose_level = Level "VERBOSE" 700 Syslog.Debug + +config_level :: Level +config_level = Level "CONFIG" 650 Syslog.Debug + +verbose :: Q Exp +#ifdef VERBOSE +verbose = putMessage trace_level +#else +verbose = [| \fmt args -> return () |] +#endif + +traceConfig :: Q Exp +traceConfig = putMessage config_level + diff --git a/src/Core/Monitoring.hs b/src/Core/Monitoring.hs new file mode 100644 --- /dev/null +++ b/src/Core/Monitoring.hs @@ -0,0 +1,30 @@ + +module Core.Monitoring where + +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Catch +import qualified Control.Monad.Metrics as Metrics +import qualified Data.Text as T + +import Core.Types + +ifMetricsEnabled :: (Monad m, HasMetricsConfig m) => m () -> m () +ifMetricsEnabled action = do + enabled <- isMetricsEnabled + when enabled action + +increment :: (MonadIO m, Metrics.MonadMetrics m, HasMetricsConfig m) => T.Text -> m () +increment name = ifMetricsEnabled $ Metrics.increment name + +timed :: (MonadIO m, Metrics.MonadMetrics m, MonadMask m, HasMetricsConfig m) => T.Text -> m a -> m a +timed name action = do + enabled <- isMetricsEnabled + if enabled + then Metrics.timed name action + else action + +distribution :: (MonadIO m, Metrics.MonadMetrics m, HasMetricsConfig m) => T.Text -> Double -> m () +distribution name x = + ifMetricsEnabled $ Metrics.distribution name x + diff --git a/src/Core/Parallel.hs b/src/Core/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Core/Parallel.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Core.Parallel where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Concurrent +import Data.Maybe +import qualified Data.Map as M +import System.Log.Heavy + +import Core.Types + +data Processor key input output = Processor (input -> key) (Chan input) (Chan (key, Either Error output)) + +runProcessor :: Int -> (input -> key) -> (input -> Checkers output) -> Checkers (Processor key input output) +runProcessor nThreads getKey fn = do + st <- ask + inputChan <- liftIO newChan + outChan <- liftIO newChan + + forM_ [1 .. nThreads] $ \i -> do + liftIO $ forkIO $ worker st inputChan outChan i + return $ Processor getKey inputChan outChan + where + worker st inChan outChan i = forever $ do + input <- readChan inChan + output <- runCheckersT (withLogVariable "thread" (i :: Int) $ fn input) st + writeChan outChan (getKey input, output) + +process :: Ord key => Processor key input output -> [input] -> Checkers [output] +process processor inputs = do + results <- process' processor inputs + case sequence results of + Right outputs -> return outputs + Left err -> throwError err + +process' :: Ord key => Processor key input output -> [input] -> Checkers [Either Error output] +process' (Processor getKey inChan outChan) inputs = do + let n = length inputs + forM_ inputs $ \input -> + liftIO $ writeChan inChan input + results <- replicateM n $ liftIO $ readChan outChan + let m = M.fromList results + let results = [fromJust $ M.lookup (getKey input) m | input <- inputs] + return results + diff --git a/src/Core/Rest.hs b/src/Core/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Core/Rest.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Core.Rest where + +import Control.Monad.Reader +import Control.Concurrent +import Control.Concurrent.STM +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Maybe +import Data.Aeson hiding ( json ) +import Web.Scotty.Trans +import Network.HTTP.Types.Status +import System.Log.Heavy +import System.Log.Heavy.TH + +import Core.Types +import Core.Board +import Core.Supervisor +import Core.Json ( ) -- import instances only +import Formats.Fen +import Formats.Pdn + +type Rest a = ActionT Error Checkers a + +error400 :: T.Text -> Rest () +error400 message = do + json $ object ["error" .= message] + status status400 + +transformError :: Error -> Rest () +transformError err = do + error400 $ T.pack $ show err + +instance Parsable Side where + parseParam "1" = Right First + parseParam "2" = Right Second + parseParam text = Left $ "unknown side" + +instance ScottyError Error where + stringError str = Unhandled str + showError err = TL.pack $ show err + +withGameContext :: GameId -> Checkers a -> Checkers a +withGameContext gameId actions = withLogVariable "game" gameId actions + +liftCheckers :: GameId -> Checkers a -> Rest a +liftCheckers gameId actions = liftCheckers' (Just gameId) actions + +liftCheckers_ :: Checkers a -> Rest a +liftCheckers_ actions = liftCheckers' Nothing actions + +liftCheckers' :: Maybe GameId -> Checkers a -> Rest a +liftCheckers' mbId actions = do + res <- lift $ wrap $ tryC actions + case res of + Right result -> return result + Left err -> raise err + where + wrap r = case mbId of + Nothing -> r + Just gameId -> withGameContext gameId r + +boardRq :: SupervisorState -> SomeRules -> NewGameRq -> Rest (Maybe Side, Maybe BoardRep) +boardRq _ _ (NewGameRq { rqBoard = Just br, rqFen = Nothing, rqPdn = Nothing }) = + return $ (Nothing, Just br) +boardRq _ rules (NewGameRq { rqBoard = Nothing, rqFen = Just fen, rqPdn = Nothing }) + = case parseFen rules fen of + Left err -> raise $ InvalidBoard err + Right (side, br) -> return (Just side, Just br) +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) +boardRq _ _ (NewGameRq { rqPrevBoard = Just gameId }) = do + board <- liftCheckers_ $ getInitialBoard gameId + return (Nothing, Just $ boardRep board) +boardRq _ _ (NewGameRq { rqBoard = Nothing, rqFen = Nothing, rqPdn = Nothing }) = + return (Nothing, Nothing) +boardRq _ _ _ = + raise $ InvalidBoard "only one of fields must be filled: board, fen, pdn" + +restServer :: MVar () -> ScottyT Error Checkers () +restServer shutdownVar = do + + defaultHandler transformError + + post "/game/new" $ do + rq <- jsonData + case selectRules rq of + Nothing -> error400 "invalid game rules" + Just rules -> do + rnd <- liftCheckers_ $ do + sup <- askSupervisor + liftIO $ atomically $ readTVar sup + (mbFirstSide, board) <- boardRq rnd rules rq + let firstSide = fromMaybe First mbFirstSide + gameId <- liftCheckers_ $ newGame rules firstSide board + liftCheckers gameId $ $info + "Created new game #{}; First turn: {}; initial board: {}" + (gameId, show firstSide, show board) + json $ Response (NewGameRs gameId firstSide) [] + + post "/game/:id/attach/ai/:side" $ do + gameId <- param "id" + side <- param "side" + rules <- liftCheckers gameId $ getRules gameId + rq <- jsonData + case selectAi rq rules of + Nothing -> error400 "invalid ai settings" + Just ai -> do + liftCheckers gameId $ do + $info "Attached AI: {} to game #{} as {}" (show ai, gameId, show side) + initAiStorage rules ai + attachAi gameId side ai + json $ Response AttachAiRs [] + + post "/game/:id/attach/:name/:side" $ do + gameId <- param "id" + name <- param "name" + side <- param "side" + liftCheckers gameId $ do + registerUser gameId side name + $info "Attached player `{}' to game #{} as {}" (name, gameId, show side) + json $ Response RegisterUserRs [] + + post "/game/:id/run" $ do + gameId <- param "id" + liftCheckers gameId $ runGame gameId + json $ Response RunGameRs [] + + get "/game/:id/state" $ do + gameId <- param "id" + rs <- liftCheckers gameId $ getState gameId + json $ Response rs [] + + get "/game/:id/fen" $ do + gameId <- param "id" + rs <- liftCheckers gameId $ getFen gameId + Web.Scotty.Trans.text $ TL.fromStrict rs + + get "/game/:id/pdn" $ do + gameId <- param "id" + rs <- liftCheckers gameId $ getPdn gameId + Web.Scotty.Trans.text $ TL.fromStrict rs + + get "/game/:id/history" $ do + gameId <- param "id" + rs <- liftCheckers gameId $ getHistory gameId + json $ Response (HistoryRs rs) [] + + post "/game/:id/move/:name" $ do + gameId <- param "id" + name <- param "name" + moveRq <- jsonData + board <- liftCheckers gameId $ doMove gameId name moveRq + messages <- liftCheckers gameId $ getMessages name + json $ Response (MoveRs board) messages + + get "/game/:id/moves/:name" $ do + gameId <- param "id" + name <- param "name" + side <- liftCheckers gameId $ getSideByUser gameId name + moves <- liftCheckers gameId $ getPossibleMoves gameId side + messages <- liftCheckers gameId $ getMessages name + json $ Response (PossibleMovesRs moves) messages + + post "/game/:id/undo/:name" $ do + gameId <- param "id" + name <- param "name" + board <- liftCheckers gameId $ doUndo gameId name + messages <- liftCheckers gameId $ getMessages name + json $ Response (UndoRs board) messages + + post "/game/:id/capitulate/:name" $ do + gameId <- param "id" + name <- param "name" + liftCheckers gameId $ doCapitulate gameId name + messages <- liftCheckers gameId $ getMessages name + json $ Response CapitulateRs messages + + post "/game/:id/draw/request/:name" $ do + gameId <- param "id" + name <- param "name" + liftCheckers gameId $ doDrawRequest gameId name + messages <- liftCheckers gameId $ getMessages name + json $ Response DrawRqRs messages + + post "/game/:id/draw/accept/:name" $ do + gameId <- param "id" + name <- param "name" + liftCheckers gameId $ doDrawAccept gameId name True + messages <- liftCheckers gameId $ getMessages name + json $ Response (DrawAcceptRs True) messages + + post "/game/:id/draw/decline/:name" $ do + gameId <- param "id" + name <- param "name" + liftCheckers gameId $ doDrawAccept gameId name False + messages <- liftCheckers gameId $ getMessages name + json $ Response (DrawAcceptRs False) messages + + get "/poll/:name" $ do + name <- param "name" + messages <- liftCheckers_ $ getMessages name + json $ Response (PollRs messages) [] + + get "/lobby/:rules" $ do + rules <- param "rules" + games <- liftCheckers_ $ getGames (Just rules) + json $ Response (LobbyRs games) [] + + get "/lobby" $ do + games <- liftCheckers_ $ getGames Nothing + json $ Response (LobbyRs games) [] + + get "/notation/:rules" $ do + rules <- param "rules" + (size, orientation, notation) <- liftCheckers_ $ getNotation rules + json $ Response (NotationRs size orientation notation) [] + + post "/server/shutdown" $ do + isLocal <- lift $ asks (gcLocal . csConfig) + if isLocal + then do + json $ Response ShutdownRs [] + liftIO $ putMVar shutdownVar () + else error400 "Server is not running in local mode" + +runRestServer :: Checkers () +runRestServer = do + cs <- ask + let getResponse m = do + res <- runCheckersT m cs + case res of + Right response -> return response + Left err -> fail $ show err + port <- asks (gcPort . csConfig) + shutdownVar <- liftIO newEmptyMVar + forkCheckers $ scottyT (fromIntegral port) getResponse (restServer shutdownVar) + liftIO $ takeMVar shutdownVar + -- REST thread should be able to write the response to Shutdown request. + liftIO $ threadDelay (1000 * 1000) + diff --git a/src/Core/Supervisor.hs b/src/Core/Supervisor.hs new file mode 100644 --- /dev/null +++ b/src/Core/Supervisor.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} + +{- + - Supervisor is a singleton unit, which manages set of games (which may be + - just created, running, or already finished). It supports methods like "make this move in that game". + -} + +module Core.Supervisor where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Except +import Control.Concurrent +import Control.Concurrent.STM +import Data.Maybe +import Data.List +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Array.IArray as A +import Data.Text.Format.Heavy +import Data.Default +import Data.Aeson hiding (Error) +import Data.Dynamic +import GHC.Generics +import System.Random +import System.Log.Heavy +import System.Log.Heavy.TH +import System.Log.Heavy.Format +import System.Log.FastLogger.Date +import System.Random.MWC + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Game +import AI.AlphaBeta () -- import instances only +import AI.AlphaBeta.Types +import Formats.Types +import Formats.Fen +import Formats.Pdn + +import Rules.Russian +import Rules.Simple +import Rules.English +import Rules.International +import Rules.Brazilian +import Rules.Canadian +import Rules.Spancirety +import Rules.Diagonal + +-- | Request for new game creation +data NewGameRq = NewGameRq { + rqRules :: String -- ^ Rules identifier + , rqRulesParams :: Value -- ^ Rules parameters (no rules support parameters atm) + , rqBoard :: Maybe BoardRep -- ^ Initial board, Nothing for default one + , rqFen :: Maybe T.Text -- ^ Initial board in FEN notation + , rqPdn :: Maybe T.Text -- ^ Initial board in PDN notation + , rqPrevBoard :: Maybe GameId + } + deriving (Eq, Show, Generic) + +-- | Request for attaching AI to the game. +-- Parameter is identifier of AI implementation. +-- Currently there is only one, named 'default'. +data AttachAiRq = AttachAiRq String Value + deriving (Eq, Show, Generic) + +-- | Response to the client. +-- Contains payload and list of notification messages. +data Response = Response RsPayload [Notify] + deriving (Eq, Show, Generic) + +-- | Response payload +data RsPayload = + NewGameRs GameId Side + | RegisterUserRs + | AttachAiRs + | RunGameRs + | PollRs [Notify] + | LobbyRs [Game] + | NotationRs BoardSize BoardOrientation [(Label, Notation)] + | StateRs BoardRep GameStatus Side + | HistoryRs [HistoryRecordRep] + | PossibleMovesRs [MoveRep] + | MoveRs BoardRep + | UndoRs BoardRep + | CapitulateRs + | DrawRqRs + | DrawAcceptRs Bool + | ShutdownRs + deriving (Eq, Show, Generic) + +-- | Create supervisor handle +mkSupervisor :: IO SupervisorHandle +mkSupervisor = do + random <- withSystemRandom . asGenIO $ \gen -> + forM [1 .. 4] $ \unboxedPiece -> + forM [1 .. 16*16] $ \index -> + uniform gen + let randomArray = A.listArray ((1,0), (4, 16*16-1)) $ concat random + var <- atomically $ newTVar $ SupervisorState M.empty 0 M.empty $! randomArray + return var + +-- | List of supported rules with their identifiers +supportedRules :: [(String, SomeRules)] +supportedRules = + [("russian", SomeRules russian), + ("simple", SomeRules simple), + ("english", SomeRules english), + ("international", SomeRules international), + ("brazilian", SomeRules brazilian), + ("canadian", SomeRules canadian), + ("spancirety", SomeRules spancirety), + ("diagonal", SomeRules diagonal)] + +-- | Select rules by client request. +selectRules :: NewGameRq -> Maybe SomeRules +selectRules (NewGameRq {rqRules=name, rqRulesParams=params, rqPdn=mbPdn}) = + fromPdn mbPdn `mplus` go supportedRules + where + -- extract rules from client request field + go :: [(String, SomeRules)] -> Maybe SomeRules + go [] = Nothing + go ((key, (SomeRules rules)) : other) + | key == name = Just $ SomeRules $ updateRules rules params + | otherwise = go other + + -- extract rules (GameType tag) from PDN + fromPdn :: Maybe T.Text -> Maybe SomeRules + fromPdn Nothing = Nothing + fromPdn (Just text) = + case parsePdn Nothing text of + Left _ -> Nothing + Right gr -> rulesFromTags (grTags gr) + +-- | List of supported AI implementations +supportedAis :: [(String, SomeRules -> SomeAi)] +supportedAis = [("default", \(SomeRules rules) -> SomeAi (AlphaBeta def rules (dfltEvaluator rules)))] + +-- | Select AI implementation by client request +selectAi :: AttachAiRq -> SomeRules -> Maybe SomeAi +selectAi (AttachAiRq name params) rules = go supportedAis + where + go :: [(String, SomeRules -> SomeAi)] -> Maybe SomeAi + go [] = Nothing + go ((key, fn) : other) + | key == name = Just $ updateSomeAi (fn rules) params + | otherwise = go other + +-- | Initialize AI storage. +-- There should be exactly one AI storage instance running +-- per (AI implementation, game rules) tuple, shared by all games running. +initAiStorage :: SomeRules -> SomeAi -> Checkers () +initAiStorage (SomeRules rules) (SomeAi ai) = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + let key = (rulesName rules, aiName ai) + case M.lookup key (ssAiStorages st) of + Nothing -> do + storage <- createAiStorage ai + liftIO $ atomically $ modifyTVar var $ \st -> + st {ssAiStorages = M.insert key (toDyn storage) (ssAiStorages st)} + Just _ -> return () + +-- | Create a game in the New state +newGame :: SomeRules -> Side -> Maybe BoardRep -> Checkers GameId +newGame r@(SomeRules rules) firstSide mbBoardRep = do + var <- askSupervisor + liftIO $ atomically $ do + st <- readTVar var + let gameId = ssLastGameId st + 1 + let st' = st {ssLastGameId = gameId} + writeTVar var st' + game <- mkGame st' rules gameId firstSide mbBoardRep + modifyTVar var $ \st -> st {ssGames = M.insert (show gameId) game (ssGames st)} + return $ show gameId + +-- | Register a user in the game +registerUser :: GameId -> Side -> String -> Checkers () +registerUser gameId side name = do + var <- askSupervisor + res <- liftIO $ atomically $ do + st <- readTVar var + case M.lookup gameId (ssGames st) of + Nothing -> return $ Left $ NoSuchGame gameId + Just game -> do + if exists name game + then return $ Left UserNameAlreadyUsed + else do + modifyTVar var $ \st -> + st {ssGames = M.update (Just . update name) gameId (ssGames st)} + return $ Right () + case res of + Right _ -> return () + Left err -> throwError err + where + update name game + | side == First = game {gPlayer1 = Just (User name)} + | otherwise = game {gPlayer2 = Just (User name)} + + exists name game = + case (gPlayer1 game, gPlayer2 game) of + (Just p, Nothing) -> isUser name p + (Nothing, Just p) -> isUser name p + (Just p1, Just p2) -> isUser name p1 || isUser name p2 + _ -> False + +-- | Attach AI to the game +attachAi :: GameId -> Side -> SomeAi -> Checkers () +attachAi gameId side (SomeAi ai) = do + var <- askSupervisor + liftIO $ atomically $ modifyTVar var $ \st -> st {ssGames = M.update (Just . update) gameId (ssGames st)} + where + update game + | side == First = game {gPlayer1 = Just $ AI ai} + | otherwise = game {gPlayer2 = Just $ AI ai} + +-- | Switch game to the running state. +-- If the first player is AI, let it make a turn. +runGame :: GameId -> Checkers () +runGame gameId = do + var <- askSupervisor + liftIO $ atomically $ modifyTVar var $ \st -> st {ssGames = M.update (Just . update) gameId (ssGames st)} + game <- getGame gameId + let firstSide = gsSide $ gState game + letAiMove gameId firstSide Nothing + return () + where + update game = game {gStatus = Running} + +-- | Execute actions within GameM monad +withGame :: GameId -> (SomeRules -> GameM a) -> Checkers a +withGame gameId action = do + var <- askSupervisor + res <- liftIO $ atomically $ do + st <- readTVar var + case M.lookup gameId (ssGames st) of + Nothing -> return $ Left $ NoSuchGame gameId + Just game -> do + let rules = gRules game + let (r, game') = runState (runExceptT $ action rules) game + case r of + Left err -> return $ Left err + Right result -> do + writeTVar var $ st {ssGames = M.insert gameId game' (ssGames st)} + return $ Right result + case res of + 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 + game <- getGame gameId + return $ gRules game + +getInitialBoard :: GameId -> Checkers Board +getInitialBoard gameId = do + game <- getGame gameId + return $ gInitialBoard game + +-- | Find a game by participating user name. +-- Returns Just game if there is exactly one such game. +getGameByUser :: String -> Checkers (Maybe Game) +getGameByUser name = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + case filter (\g -> isJust (sideByUser' g name)) (M.elems $ ssGames st) of + [game] -> return (Just game) + _ -> return Nothing + +-- | Get all messages pending for specified user. +-- Remove that messages from mailboxes. +getMessages :: String -> Checkers [Notify] +getMessages name = do + var <- askSupervisor + liftIO $ atomically $ do + st <- readTVar var + let mailboxes = mapMaybe getM (M.elems $ ssGames st) + messages <- forM mailboxes readAll + return (concat messages) + where + readAll chan = do + mbMsg <- tryReadTChan chan + case mbMsg of + Nothing -> return [] + Just msg -> do + rest <- readAll chan + return $ msg : rest + + getM game = do + case sideByUser' game name of + Nothing -> Nothing + Just First -> Just $ gMsgbox1 game + Just Second -> Just $ gMsgbox2 game + +-- | Get moves that are possible currently +-- in the specified game for specified side. +getPossibleMoves :: GameId -> Side -> Checkers [MoveRep] +getPossibleMoves gameId side = + withGame gameId $ \(SomeRules rules) -> do + currentSide <- gets (gsSide . gState) + if side /= currentSide + then throwError NotYourTurn + else do + game <- get + moves <- gamePossibleMoves + return $ map (moveRep rules side) moves + +-- | Execute specified move in specified game and return a new board. +doMove :: GameId -> String -> MoveRep -> Checkers BoardRep +doMove gameId name moveRq = do + game <- getGame gameId + side <- sideByUser game name + GMoveRs board' messages <- withGame gameId $ \_ -> doMoveRepRq side moveRq + queueNotifications gameId messages + letAiMove gameId (opposite side) (Just board') + return $ boardRep board' + +-- | Undo last pair of moves in the specified game. +doUndo :: GameId -> String -> Checkers BoardRep +doUndo gameId name = do + game <- getGame gameId + side <- sideByUser game name + GUndoRs board' messages <- withGame gameId $ \_ -> doUndoRq side + queueNotifications gameId messages + letAiMove gameId side (Just board') + return $ boardRep board' + +doCapitulate :: GameId -> String -> Checkers () +doCapitulate gameId name = do + game <- getGame gameId + side <- sideByUser game name + result <- withGame gameId $ \_ -> doCapitulateRq side + let messages = [ + ResultNotify (opposite side) side result, + ResultNotify side side result + ] + queueNotifications gameId messages + +doDrawRequest :: GameId -> String -> Checkers () +doDrawRequest gameId name = do + game <- getGame gameId + side <- sideByUser game name + withGame gameId $ \_ -> doPostDrawRequest side + let messages = [ + DrawRqNotify (opposite side) side + ] + queueNotifications gameId messages + mbResult <- aiDrawRequest gameId (opposite side) + case mbResult of + Nothing -> return () + Just accepted -> doDrawAccept' gameId (opposite side) accepted + +doDrawAccept' :: GameId -> Side -> Bool -> Checkers () +doDrawAccept' gameId side accepted = do + withGame gameId $ \_ -> doDrawAcceptRq side accepted + let drawNotify = DrawRsNotify (opposite side) side accepted + resultNotify = [ + ResultNotify (opposite side) side Draw, + ResultNotify side side Draw + ] + let messages = + if accepted + then drawNotify : resultNotify + else [drawNotify] + queueNotifications gameId messages + +doDrawAccept :: GameId -> String -> Bool -> Checkers () +doDrawAccept gameId name accepted = do + game <- getGame gameId + side <- sideByUser game name + doDrawAccept' gameId side accepted + +-- | Execute actions with AI storage instance. +-- AI storage instance must be initialized beforeahead. +withAiStorage :: GameAi ai + => SomeRules + -> ai + -> (AiStorage ai -> Checkers a) + -> Checkers a +withAiStorage (SomeRules rules) ai fn = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + let key = (rulesName rules, aiName ai) + case M.lookup key (ssAiStorages st) of + Nothing -> fail $ "AI storage was not initialized yet for key: " ++ show key + Just value -> + case fromDynamic value of + Nothing -> fail $ "AI storage has unexpected type" + Just storage -> do + result <- fn storage + return result + +-- | Let AI make it's turn. +letAiMove :: GameId -> Side -> Maybe Board -> Checkers Board +letAiMove gameId side mbBoard = do + board <- case mbBoard of + Just b -> return b + Nothing -> do + (_, _, b) <- withGame gameId $ \_ -> gameState + return b + + game <- getGame gameId + case getPlayer game side of + AI ai -> do + + rules <- getRules gameId + withAiStorage rules ai $ \storage -> do + timed "Selecting AI move" $ do + aiMoves <- chooseMove ai storage gameId side board + if null aiMoves + then do + $info "AI failed to move." () + return board + else do + i <- liftIO $ randomRIO (0, length aiMoves - 1) + let aiMove = aiMoves !! i + $info "AI returned {} move(s), selected: {}" (length aiMoves, show aiMove) + GMoveRs board' messages <- withGame gameId $ \_ -> doMoveRq side (pmMove aiMove) + $debug "Messages: {}" (Single $ show messages) + queueNotifications (getGameId game) messages + return board' + + _ -> return board + +aiDrawRequest :: GameId -> Side -> Checkers (Maybe Bool) +aiDrawRequest gameId side = do + game <- getGame gameId + board <- do + (_, _, b) <- withGame gameId $ \_ -> gameState + return b + case getPlayer game side of + AI ai -> do + rules <- getRules gameId + withAiStorage rules ai $ \storage -> do + result <- decideDrawRequest ai storage side board + $info "AI response for draw request: {}" (Single result) + return $ Just result + _ -> return Nothing + +-- | Get current game state +getState :: GameId -> Checkers RsPayload +getState gameId = do + (side, status, board) <- withGame gameId $ \_ -> gameState + return $ StateRs (boardRep board) status side + +-- | Get game history +getHistory :: GameId -> Checkers [HistoryRecordRep] +getHistory gameId = do + withGame gameId $ \_ -> gameHistory + +-- | Get current position in specified game in FEN notation +getFen :: GameId -> Checkers T.Text +getFen gameId = do + (side, _, board) <- withGame gameId $ \_ -> gameState + return $ showFen (bSize board) $ boardToFen side board + +-- | Get specified game record in PDN format +getPdn :: GameId -> Checkers T.Text +getPdn gameId = do + game <- getGame gameId + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + return $ showPdn (gRules game) $ gameToPdn st game + +-- | Get list of running games with specified rules +-- (Nothing - any rules) +getGames :: Maybe String -> Checkers [Game] +getGames mbRulesId = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + let games = M.elems (ssGames st) + good (SomeRules rules) = + case mbRulesId of + Nothing -> True + Just rulesId -> rulesName rules == rulesId + return [game | game <- games, good (gRules game)] + +-- | Get list of fields notation by rules name. +getNotation :: String -> Checkers (BoardSize, BoardOrientation, [(Label, Notation)]) +getNotation rname = do + var <- askSupervisor + st <- liftIO $ atomically $ readTVar var + let Just someRules = select supportedRules + result = process st someRules + return result + + where + select [] = Nothing + select ((name, rules) : rest) + | name == rname = Just rules + | otherwise = select rest + + process st (SomeRules rules) = + let board = initBoard st rules + labels = labelMapKeys (bAddresses board) + notation = [(label, boardNotation rules label) | label <- labels] + size = boardSize rules + orientation = boardOrientation rules + in (size, orientation, notation) + + +getPlayer :: Game -> Side -> Player +getPlayer game First = fromJust $ gPlayer1 game +getPlayer game Second = fromJust $ gPlayer2 game + +isAI :: Game -> Side -> Bool +isAI game First = case gPlayer1 game of + Just (AI _) -> True + _ -> False +isAI game Second = case gPlayer2 game of + Just (AI _) -> True + _ -> False + +sideByUser' :: Game -> String -> Maybe Side +sideByUser' game name = + case (gPlayer1 game, gPlayer2 game) of + (Just (User name1), _) | name1 == name -> Just First + (_, Just (User name2)) | name2 == name -> Just Second + _ -> Nothing + +sideByUser :: Game -> String -> Checkers Side +sideByUser game name = + case sideByUser' game name of + Just side -> return side + Nothing -> throwError NoSuchUserInGame + +getSideByUser :: GameId -> String -> Checkers Side +getSideByUser gameId name = do + game <- getGame gameId + sideByUser game name + +-- | Put notification messages in corresponding mailboxes. +queueNotifications :: GameId -> [Notify] -> Checkers () +queueNotifications gameId messages = do + game <- getGame gameId + liftIO $ atomically $ + forM_ messages $ \message -> + case nDestination message of + First -> writeTChan (gMsgbox1 game) message + Second -> writeTChan (gMsgbox2 game) message + +gameIdFromLogMsg :: LogMessage -> Maybe Variable +gameIdFromLogMsg msg = msum $ map (lookup "game") $ map lcfVariables $ lmContext msg + +logRouter :: SupervisorHandle -> Chan LogMessage -> Checkers () +logRouter supervisor chan = do + let fmt = "[{thread}] {message}" + tcache <- liftIO $ newTimeCache simpleTimeFormat + forever $ do + msg <- liftIO $ readChan chan + case gameIdFromLogMsg msg of + Nothing -> return () + Just str -> do + + ftime <- liftIO tcache + let gameId = show str + level = show (lmLevel msg) + src = intercalate "." (lmSource msg) + notifies = [LogNotify side level src text | side <- [First, Second]] + text = format fmt $ LogMessageWithTime ftime msg + queueNotifications gameId notifies + diff --git a/src/Core/Types.hs b/src/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Core/Types.hs @@ -0,0 +1,840 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Core.Types where + +import Control.Monad.Reader +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Metrics as Metrics +import Control.Concurrent +import Control.Concurrent.STM +import Data.List +import Data.Array.Unboxed +import qualified Data.Map as M +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +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 Data.Text.Format.Heavy +import Data.Dynamic +import Data.Aeson (Value) +import Data.Int +import Data.Word +import Data.Binary +import Data.Store +import Data.Default +import Data.Hashable +import Text.Printf +import GHC.Generics +import System.Log.Heavy +import System.Log.Heavy.TH +import System.Clock + +import Debug.Trace (traceEventIO) + +-- | Label is a coordinate of field on the board. +data Label = Label { + labelColumn :: ! Line, + labelRow :: ! Line + } + deriving (Eq, Ord, Typeable, Generic) + +instance Binary Label where + +instance Store Label where + size = ConstSize 1 + + poke (Label col row) = do + poke $ col * 16 + row + + peek = do + n <- peek :: Peek Word8 + let row = n `mod` 16 + col = n `div` 16 + return $ Label col row + +instance Hashable Label where + hashWithSalt salt (Label col row) = + salt `hashWithSalt` col `hashWithSalt` row + +-- | Field notation. +type Notation = T.Text + +letters :: [Char] +letters = ['a' .. 'z'] + +instance Show Label where + show l = letter : show (labelRow l + 1) + where + letter = letters !! fromIntegral (labelColumn l) + +data PieceKind = Man | King + deriving (Eq, Ord, Generic, Typeable) + +instance Show PieceKind where + show Man = "M" + show King = "K" + +instance Hashable PieceKind where + hashWithSalt salt Man = hashWithSalt salt (1 :: Int) + hashWithSalt salt King = hashWithSalt salt (2 :: Int) + +-- | There are two places at the board for players: top and bottom. +data BoardSide = Top | Bottom + deriving (Eq, Ord, Show, Generic, Typeable) + +-- | Playing side. First is one who moves first. +-- Mapping of First\/Second to white\/black or to +-- top\/bottom depends on game rules. +-- Actually, we do not care at all about colors: +-- for example, in english draughts black are usually red; +-- but why should we care? it is only important that black +-- (well, red) move first. +data Side = First | Second + deriving (Eq, Ord, Generic, Typeable) + +instance Show Side where + show First = "1" + show Second = "2" + +instance Store Side + +instance Hashable Side where + hashWithSalt salt First = hashWithSalt salt (3 :: Int) + hashWithSalt salt Second = hashWithSalt salt (4 :: Int) + +-- | In most game rules, the side who moves first starts +-- from the bottom of board; but there are some (well, +-- english), in which first side starts from top. +data BoardOrientation = FirstAtBottom | SecondAtBottom + deriving (Eq, Ord, Show, Generic, Typeable) + +data Piece = Piece { + pieceKind :: PieceKind + , pieceSide :: Side + } + deriving (Eq, Ord, Typeable) + +instance Show Piece where + show (Piece k s) = show k ++ show s + +instance Hashable Piece where + hashWithSalt salt (Piece k s) = salt `hashWithSalt` k `hashWithSalt` s + +type UnboxedPiece = Word8 + +data Address = Address { + aLabel :: ! Label, + aPromotionSide :: Maybe Side, + aUpLeft :: Maybe Address, + aUpRight :: Maybe Address, + aDownLeft :: Maybe Address, + aDownRight :: Maybe Address + } + deriving (Typeable) + +instance Eq Address where + f1 == f2 = aLabel f1 == aLabel f2 + +instance Show Address where + show f = show (aLabel f) + +instance Ord Address where + compare a1 a2 = compare (aLabel a1) (aLabel a2) + +-- | Number of row / column of the board +type Line = Word8 + +type BoardSize = (Line, Line) + +type FieldIndex = Int + +type AddressMap a = IM.IntMap a + +type LabelMap a = IM.IntMap a + +type LabelSet = IS.IntSet + +-- | Board describes current position on the board. +data Board = Board { + bAddresses :: LabelMap Address + , bCaptured :: LabelSet + , bOccupied :: LabelSet + , bFirstMen :: LabelSet + , bSecondMen :: LabelSet + , bFirstKings :: LabelSet + , bSecondKings :: LabelSet +-- , boardCounts :: BoardCounts + , bSize :: {-# UNPACK #-} ! BoardSize + , boardKey :: BoardKey + , boardHash :: {-# UNPACK #-} ! BoardHash + , randomTable :: ! RandomTable + } + deriving (Typeable) + +instance Eq Board where + b1 == b2 = + boardHash b1 == boardHash b2 && + bFirstMen b1 == bFirstMen b2 && + bSecondMen b1 == bSecondMen b2 && + bFirstKings b1 == bFirstKings b2 && + bSecondKings b1 == bSecondKings b2 + +boardEq :: Board -> Board -> Bool +boardEq b1 b2 = + boardHash b1 == boardHash b2 && + bFirstMen b1 == bFirstMen b2 && + bSecondMen b1 == bSecondMen b2 && + bFirstKings b1 == bFirstKings b2 && + bSecondKings b1 == bSecondKings b2 && + bOccupied b1 == bOccupied b2 + +-- | Statistic information about the board. +-- Can be used as a part of key in some caches. +data BoardCounts = BoardCounts { + bcFirstMen :: ! Int + , bcSecondMen :: ! Int + , bcFirstKings :: ! Int + , bcSecondKings :: ! Int + } + deriving (Eq, Ord, Show, Typeable, Generic) + +instance Binary BoardCounts + +instance Store BoardCounts + +instance Hashable BoardCounts where + hashWithSalt salt bc = + salt `hashWithSalt` bcFirstMen bc `hashWithSalt` bcSecondMen bc `hashWithSalt` bcFirstKings bc `hashWithSalt` bcSecondKings bc + +instance Hashable Board where + hashWithSalt salt board = boardHash board + +type BoardKey = LabelMap Piece + +instance Hashable BoardKey where + hashWithSalt salt bk = hashWithSalt salt (IM.assocs bk) + +type BoardHash = Int +type RandomTable = UArray (UnboxedPiece, FieldIndex) BoardHash +type BoardData = UArray FieldIndex UnboxedPiece + +class RandomTableProvider p where + getRandomTable :: p -> RandomTable + +type TBoardMap a = SM.Map BoardHash a + +-- | Direction on the board. +-- For example, B2 is at UpRight of A1. +data BoardDirection = + UpLeft | UpRight + | DownLeft | DownRight + deriving (Eq, Generic, Typeable) + +instance Show BoardDirection where + show UpLeft = "UL" + show UpRight = "UR" + show DownLeft = "DL" + show DownRight = "DR" + +-- | Direction from a point of view of a player. +-- For example, for white, B2 is at ForwardRight of A1; +-- for black, B2 is at BackwardLeft of A1. +data PlayerDirection = + ForwardLeft | ForwardRight + | BackwardLeft | BackwardRight + deriving (Eq, Ord, Generic, Typeable) + +instance Show PlayerDirection where + show ForwardLeft = "FL" + show ForwardRight = "FR" + show BackwardLeft = "BL" + show BackwardRight = "BR" + +-- | One step of the move is a movement of piece +-- from one field to it's neighbour. At that moment +-- there can take place a capturing of another piece +-- or current piece promotion to king. +data Step = Step { + sDirection :: ! PlayerDirection, + sCapture :: ! Bool, + sPromote :: ! Bool + } + deriving (Eq, Ord, Typeable) + +instance Show Step where + show step = show (sDirection step) ++ capture ++ promote + where + capture + | sCapture step = "[X]" + | otherwise = "" + + promote + | sPromote step = "[K]" + | otherwise = "" + +-- | Move (or should we say half-move? because it's about one player's move) is +-- a series of steps from one field to neighbour, and to neighbour... +data Move = Move { + moveBegin :: ! Address, + moveSteps :: ! [Step] + } + deriving (Eq, Ord, Typeable) + +instance Show Move where + show move = "[" ++ show (moveBegin move) ++ "] " ++ (intercalate "." $ map show (moveSteps move)) + +-- | Representation of Step for JSON +data StepRep = StepRep { + srField :: Label, + srCapture :: Bool, + srPromote :: Bool + } + deriving (Eq, Typeable, Generic) + +instance Binary StepRep + +instance Store StepRep + +instance Show StepRep where + show step = show (srField step) ++ capture ++ promote + where + capture + | srCapture step = "[X]" + | otherwise = "" + + promote + | srPromote step = "[K]" + | otherwise = "" + +-- | Representation of Move for JSON. +data MoveRep = + ShortMoveRep Label Label -- ^ Just start and end field specified + | FullMoveRep Label [StepRep] -- ^ Full list of steps specified + deriving (Eq, Typeable, Generic) + +instance Binary MoveRep + +instance Store MoveRep + +instance Show MoveRep where + show (ShortMoveRep from to) = show from ++ " > " ++ show to + show (FullMoveRep from steps) = "[" ++ show from ++ "] " ++ (intercalate "." $ map show steps) + +-- | Result of parsing MoveRep into Move +data MoveParseResult = + Parsed Move + | NoSuchMove + | AmbigousMove [PossibleMove] + deriving (Eq, Show) + +data StepCheckResult = + ValidStep Address + | NoSuchNeighbour + | NoPieceToCapture + | CapturingOwnPiece + | OccupatedField + | InvalidPromotion Bool Bool + deriving (Eq, Show) + +data MoveCheckResult = + ValidMove + | InvalidStep Step StepCheckResult + deriving (Eq, Show) + +-- | Representation of Board for JSON +data BoardRep = BoardRep [(Label, Piece)] + deriving (Eq, Ord, Show, Typeable) + +-- | 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 + , pmMove :: Move + , pmPromote :: ! Bool -- ^ is there any promotion in the move + , pmResult :: ! [MoveAction] + } + deriving (Typeable) + +instance Eq PossibleMove where + pm1 == pm2 = + pmBegin pm1 == pmBegin pm2 && + pmMove pm1 == pmMove pm2 + +instance Show PossibleMove where + show pm = move ++ promotion + where + move + | null (pmVictims pm) = show (pmBegin pm) ++ "-" ++ show (pmEnd pm) + | otherwise = show (pmBegin pm) ++ "x" ++ show (pmEnd pm) + + promotion + | pmPromote pm = "(K)" + | otherwise = "" + +-- | 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) + | Put ! Address ! Piece -- ^ Put the piece to the board (at the end of the move) + deriving (Eq, Ord, Show, Typeable) + +class HasBoardOrientation a where + boardOrientation :: a -> BoardOrientation + boardOrientation _ = FirstAtBottom + +-- | Interface of game rules +class (Typeable g, Show g, HasBoardOrientation g) => GameRules g where + -- | Initial board with initial pieces position + initBoard :: SupervisorState -> g -> Board + -- | Size of board used + boardSize :: g -> BoardSize + + dfltEvaluator :: g -> SomeEval + + boardNotation :: g -> Label -> Notation + parseNotation :: g -> Notation -> Either String Label + + possibleMoves :: g -> Side -> Board -> [PossibleMove] + + mobilityScore :: g -> Side -> Board -> Int + mobilityScore g side board = length $ possibleMoves g side board + + updateRules :: g -> Value -> g + getGameResult :: g -> Board -> Maybe GameResult + rulesName :: g -> String + pdnId :: g -> String + +fieldsCount :: GameRules rules => rules -> Line +fieldsCount rules = + let (nrows, ncols) = boardSize rules + in nrows * ncols `div` 2 + +dfltBoardNotation :: Label -> Notation +dfltBoardNotation l = T.pack $ show l + +data SomeRules = forall g. GameRules g => SomeRules g + +instance Show SomeRules where + show (SomeRules rules) = rulesName rules + +type ScoreBase = Int16 + +data Score = Score { + sNumeric :: ScoreBase + , sPositional :: ScoreBase + } + deriving (Eq, Ord, Generic, Typeable, Bounded) + +instance Store Score + +instance Binary Score + +scoreBound :: ScoreBase +scoreBound = 256 + +maxPieces :: ScoreBase +maxPieces = 30 + +win :: Score +win = Score maxPieces scoreBound + +loose :: Score +loose = Score (-maxPieces) (-scoreBound) + +clampS :: Int32 -> ScoreBase +clampS x = clampS' scoreBound x + +clampS' :: ScoreBase -> Int32 -> ScoreBase +clampS' bound x = min bound $ max (-bound) (fromIntegral x) + +safePlus :: forall a. (Integral a) => ScoreBase -> ScoreBase -> a -> ScoreBase +safePlus bound x y = + let result = (fromIntegral x + fromIntegral y) :: Int32 + in clampS' bound result + +safeMinus :: forall a. (Integral a) => ScoreBase -> ScoreBase -> a -> ScoreBase +safeMinus bound x y = + let result = (fromIntegral x - fromIntegral y) :: Int32 + in clampS' bound result + +safeScale :: forall a. (Integral a) => ScoreBase -> ScoreBase -> a -> ScoreBase +safeScale bound x y = + let result = (fromIntegral x * fromIntegral y) :: Int32 + in clampS' bound result + +instance Num Score where + fromInteger x = Score (fromIntegral x) 0 + (Score n1 p1) + (Score n2 p2) = Score (safePlus maxPieces n1 n2) (safePlus scoreBound p1 p2) + (Score n1 p1) - (Score n2 p2) = Score (safeMinus maxPieces n1 n2) (safeMinus scoreBound p1 p2) + _ * _ = error "* is not defined for Score" + abs (Score n p) = Score (abs n) (abs p) + negate (Score n p) = Score (negate n) (negate p) + signum _ = error "signum is not defined for Score" + +scaleScore :: Integral n => n -> Score -> Score +scaleScore x (Score n p) = Score (safeScale maxPieces (fromIntegral x) n) + (safeScale scoreBound (fromIntegral x) p) + +divideScore :: Integral n => Score -> n -> Score +divideScore (Score n p) d = + Score (n `div` fromIntegral d) (p `div` fromIntegral d) + +nextScore :: Score -> Score +nextScore (Score n p) = Score n (safePlus scoreBound p 1) + +prevScore :: Score -> Score +prevScore (Score n p) = Score n (safeMinus scoreBound p 1) + +instance Show Score where + show (Score n p) = show n ++ "/" ++ show p + +instance Formatable Score where + formatVar _ (Score n p) = Right $ Builder.decimal n <> "/" <> Builder.decimal p + +data GameResult = + FirstWin + | SecondWin + | Draw + deriving (Eq, Show, Ord, Typeable, Generic) + +class (Show e, Typeable e) => Evaluator e where + evalBoard :: e -> Side -> Board -> Score + evaluatorName :: e -> String + + updateEval :: e -> Value -> e + updateEval e _ = e + +data SomeEval = forall e. Evaluator e => SomeEval e + deriving (Typeable) + +instance Show SomeEval where + show (SomeEval e) = show e + +instance Evaluator SomeEval where + evalBoard (SomeEval e) s1 b = evalBoard e s1 b + evaluatorName (SomeEval e) = evaluatorName e + updateEval (SomeEval e) v = SomeEval (updateEval e v) + +class (Show ai, Typeable (AiStorage ai)) => GameAi ai where + type AiStorage ai + + createAiStorage :: ai -> Checkers (AiStorage ai) + saveAiStorage :: ai -> AiStorage ai -> Checkers () + + aiName :: ai -> String + + updateAi :: ai -> Value -> ai + + chooseMove :: ai -> AiStorage ai -> GameId -> Side -> Board -> Checkers [PossibleMove] + + -- | Answer for a draw request. + -- Default implementation always accepts the draw. + decideDrawRequest :: ai -> AiStorage ai -> Side -> Board -> Checkers Bool + decideDrawRequest _ _ _ _ = return True + +data SomeAi = forall ai. GameAi ai => SomeAi ai + +instance Show SomeAi where + show (SomeAi ai) = show ai + +updateSomeAi :: SomeAi -> Value -> SomeAi +updateSomeAi (SomeAi ai) params = SomeAi (updateAi ai params) + +type GameId = String + +data Player = + User String + | forall ai. GameAi ai => AI ai + +instance Show Player where + show (User name) = name + show (AI ai) = aiName ai + +isUser :: String -> Player -> Bool +isUser name (User n) = n == name +isUser _ _ = False + +data GameStatus = New | Running | DrawRequested Side | Ended GameResult + deriving (Eq, Show, Generic) + +data Game = Game { + getGameId :: GameId + , gInitialBoard :: Board + , gState :: GameState + , gStatus :: GameStatus + , gRules :: SomeRules + , gPlayer1 :: Maybe Player + , gPlayer2 :: Maybe Player + , gMsgbox1 :: TChan Notify + , gMsgbox2 :: TChan Notify + } + +instance Show Game where + show g = printf "" + (show $ gRules g) + (show $ gPlayer1 g) + (show $ gPlayer2 g) + +instance Eq Game where + g1 == g2 = getGameId g1 == getGameId g2 + +data GameState = GameState { + gsSide :: Side + , gsCurrentBoard :: Board + , gsHistory :: [HistoryRecord] + } + +data HistoryRecord = HistoryRecord { + hrSide :: Side + , hrMove :: Move + , hrPrevBoard :: Board + } + +data HistoryRecordRep = HistoryRecordRep { + hrrSide :: Side + , hrrMove :: MoveRep + } + deriving (Eq, Show, Typeable) + +data Notify = + MoveNotify { + nDestination :: Side + , nSource :: Side + , nMove :: MoveRep + , nBoard :: BoardRep + } + | UndoNotify { + nDestination :: Side + , nSource :: Side + , nBoard :: BoardRep + } + | ResultNotify { + nDestination :: Side + , nSource :: Side + , nResult :: GameResult + } + | DrawRqNotify { + nDestination :: Side + , nSource :: Side + } + | DrawRsNotify { + nDestination :: Side + , nSource :: Side + , nAccepted :: Bool + } + | LogNotify { + nDestination :: Side + , nLevel :: String + , nComponent :: String + , nLogMessage :: TL.Text + } + deriving (Eq, Show, Generic) + +-- | State of supervisor singleton +data SupervisorState = SupervisorState { + ssGames :: M.Map GameId Game -- ^ Set of games running + , ssLastGameId :: Int -- ^ ID of last created game + , ssAiStorages :: M.Map (String,String) Dynamic -- ^ AI storage instance per (AI engine; game rules) tuple + , ssRandomTable :: RandomTable + } + +instance RandomTableProvider SupervisorState where + getRandomTable = ssRandomTable + +-- | Since many threads of REST server will refer +-- to supervisor's state, we have to put it into TVar +type SupervisorHandle = TVar SupervisorState + +data AiConfig = AiConfig { + aiThreads :: Int + , aiLoadCache :: Bool + , aiStoreCache :: Bool + , aiUseCacheMaxDepth :: Int + , aiUseCacheMaxPieces :: Int + , aiUseCacheMaxDepthPlus :: Int + , aiUseCacheMaxDepthMinus :: Int + , aiUpdateCacheMaxDepth :: Int + , aiUpdateCacheMaxPieces :: Int + } + deriving (Show, Typeable, Generic) + +instance Default AiConfig where + def = AiConfig { + aiThreads = 4 + , aiLoadCache = True + , aiStoreCache = False + , aiUseCacheMaxDepth = 8 + , aiUseCacheMaxPieces = 24 + , aiUseCacheMaxDepthPlus = 0 + , aiUseCacheMaxDepthMinus = 0 + , aiUpdateCacheMaxDepth = 6 + , aiUpdateCacheMaxPieces = 8 + } + +data GeneralConfig = GeneralConfig { + gcHost :: T.Text + , gcPort :: Int + , gcLocal :: Bool + , gcEnableMetrics :: Bool + , gcMetricsPort :: Int + , gcLogFile :: FilePath + , gcLogLevel :: Level + , gcAiConfig :: AiConfig + } + deriving (Show, Typeable, Generic) + +instance Default GeneralConfig where + def = GeneralConfig { + gcHost = "localhost", + gcLocal = False, + gcPort = 8864, + gcEnableMetrics = True, + gcMetricsPort = 8000, + gcLogFile = "hcheckers.log", + gcLogLevel = info_level, + gcAiConfig = def + } + +-- | Commonly used data +data CheckersState = CheckersState { + csLogging :: LoggingTState + , csSupervisor :: SupervisorHandle + , csMetrics :: Metrics.Metrics + , csConfig :: GeneralConfig + } + +-- | Recognized exception types +data Error = + NotYourTurn + | NotAllowedMove + | NoSuchMoveError + | AmbigousMoveError [MoveRep] + | NothingToUndo + | NoSuchGame GameId + | NoSuchUserInGame + | UserNameAlreadyUsed + | InvalidGameStatus GameStatus GameStatus -- ^ Expected, actual + | TimeExhaused + | InvalidBoard String + | Unhandled String + deriving (Eq, Show, Typeable, Generic) + +instance Exception Error + +-- | Checkers monad +newtype Checkers a = Checkers { + runCheckers :: ExceptT Error (ReaderT CheckersState IO) a + } + deriving (Applicative, Functor, Monad, MonadIO, MonadReader CheckersState, MonadError Error, MonadThrow, MonadCatch, MonadMask) + +runCheckersT :: Checkers a -> CheckersState -> IO (Either Error a) +runCheckersT actions st = runReaderT (runExceptT $ runCheckers actions) st + +forkCheckers :: Checkers () -> Checkers () +forkCheckers actions = do + st <- ask + liftIO $ forkIO $ do + res <- runCheckersT actions st + case res of + Right _ -> return () + Left err -> fail $ show err + return () + +tryC :: Checkers a -> Checkers (Either Error a) +tryC actions = + (do + r <- actions + return $ Right r) `catchError` (\e -> return $ Left e) + +askSupervisor :: Checkers SupervisorHandle +askSupervisor = asks csSupervisor + +askLogging :: Checkers LoggingTState +askLogging = asks csLogging + +instance HasLogContext Checkers where + getLogContext = asks (ltsContext . csLogging) + + withLogContext frame actions = + Checkers $ ExceptT $ ReaderT $ \cs -> + let logging = csLogging cs + logging' = logging {ltsContext = frame : ltsContext logging} + in runReaderT (runExceptT $ runCheckers actions) $ cs {csLogging = logging'} + +instance HasLogger Checkers where + getLogger = asks (ltsLogger . csLogging) + + localLogger logger actions = + Checkers $ ExceptT $ ReaderT $ \cs -> + let logging = csLogging cs + logging' = logging {ltsLogger = logger} + in runReaderT (runExceptT $ runCheckers actions) $ cs {csLogging = logging'} + +instance MonadMetrics Checkers where + getMetrics = asks csMetrics + +class HasMetricsConfig m where + isMetricsEnabled :: m Bool + +instance HasMetricsConfig Checkers where + isMetricsEnabled = asks (gcEnableMetrics . csConfig) + +timed :: String -> Checkers a -> Checkers a +timed message actions = do + time1 <- liftIO $ getTime Realtime + result <- actions + time2 <- liftIO $ getTime Realtime + let delta = time2 - time1 + $debug "{}: {}s + {}ns" (message, sec delta, nsec delta) + return result + +event :: (MonadIO m, MonadMask m) => String -> m a -> m a +event label actions = + bracket_ (liftIO $ traceEventIO ("START " ++ label)) + (liftIO $ traceEventIO ("STOP " ++ label)) + actions + +repeatTimed :: forall m. (MonadIO m, HasLogging m) => String -> Int -> m Bool -> m () +repeatTimed label seconds action = repeatTimed' label seconds action' () + where + + action' _ = do + continue <- action + if continue + then return ((), Just ()) + else return ((), Nothing) + +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 + run 0 x start + where + run :: Int -> a -> TimeSpec -> m b + run i x start = do + (result, mbX') <- action x + case mbX' of + Just x' -> do + time2 <- liftIO $ getTime Monotonic + let delta = time2 - start + if sec delta >= fromIntegral seconds + then do + $info "{}: timeout exhaused, done {} iterations" (label, i+1) + return result + else run (i+1) x' start + Nothing -> do + $info "{}: work done, in {} iterations" (label, i) + return result + diff --git a/src/Formats/Compact.hs b/src/Formats/Compact.hs new file mode 100644 --- /dev/null +++ b/src/Formats/Compact.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +module Formats.Compact where + +import Control.Monad +import Control.Monad.State +import Data.Char +import Data.Maybe +import qualified Data.Text as T +import Text.Megaparsec hiding (Label, State) +import Text.Megaparsec.Char +import Text.Megaparsec.Error (parseErrorPretty) +import qualified Data.Text.IO as TIO +import Text.Printf + +import Core.Types +import Core.Board +import Formats.Types +import Formats.Fen (boardToFen, showFen) +import Formats.Pdn (showPdn, movesToInstructions) +import Rules.Russian + +data SemiMove = + Skip + | Short Line Line Line + | Full Label Label + deriving (Eq, Show) + +pSemiMove :: Parser SemiMove +pSemiMove = try pSkip <|> try pShort <|> pFull + +pSkip :: Parser SemiMove +pSkip = do + string "---" + return Skip + +pLetter :: Parser Line +pLetter = do + let letters = ['a' .. 'l'] + letter <- oneOf letters + return $ fromIntegral $ ord letter - ord 'a' + +pDigit :: Parser Line +pDigit = do + ch <- digitChar + return $ fromIntegral $ ord ch - ord '1' + +pShort :: Parser SemiMove +pShort = do + letter1 <- pLetter + letter2 <- pLetter + digit <- pDigit + return $ Short letter1 letter2 digit + +pFull :: Parser SemiMove +pFull = do + letter1 <- pLetter + digit1 <- pDigit + char '-' + letter2 <- pLetter + digit2 <- pDigit + return $ Full (Label letter1 digit1) (Label letter2 digit2) + +pGame :: Parser [SemiMove] +pGame = try pSemiMove `sepBy` space1 + +pGames :: Parser [[SemiMove]] +pGames = try pGame `sepBy` char ';' + +parseCompactFile :: FilePath -> IO [[SemiMove]] +parseCompactFile path = do + text <- TIO.readFile path + forM (T.lines text) $ \line -> do + case evalState (runParserT pGame path line) Nothing of + Left err -> fail $ parseErrorPretty err + Right game -> return game + +findMove :: Side -> SemiMove -> Board -> Either String PossibleMove +findMove side (Short colFrom colTo rowTo) board = + let suits pm = aLabel (pmEnd pm) == Label colTo rowTo && + labelColumn (aLabel (pmBegin pm)) == colFrom + in case filter suits (possibleMoves russian side board) of + [] -> Left $ printf "findMove: no pieces of %s at column %d" (show side) colFrom + [pm] -> Right pm + xs -> Left $ printf "findMove: ambigous move: %s" (show xs) + +applySemiMove :: Side -> SemiMove -> Board -> Board +applySemiMove _ Skip b = b +applySemiMove _ (Full from to) board = + let piece = fromJust $ getPiece' from board + fromA = resolve from board + toA = resolve to board + actions = [Take fromA, Put toA piece] + in applyMoveActions actions board +applySemiMove side sm@(Short colFrom colTo rowTo) board = + case findMove side sm board of + Left err -> error $ printf "applySemiMove: %s: %s" (show sm) err + Right pm -> + applyMoveActions (pmResult pm) board + +convertSemiMove :: Side -> Board -> SemiMove -> Maybe SemiMoveRec +convertSemiMove _ _ Skip = Nothing +convertSemiMove _ _ (Full from to) = Just $ ShortSemiMoveRec from to False +convertSemiMove side board sm = + case findMove side sm board of + Left err -> error $ printf "convertSemiMove: %s: %s" (show sm) err + Right pm -> Just $ ShortSemiMoveRec { + smrFrom = aLabel (pmBegin pm), + smrTo = aLabel (pmEnd pm), + smrCapture = False + } + +convertMoves :: SupervisorState -> [SemiMove] -> [MoveRec] +convertMoves rnd game = go (initBoard rnd russian) game + where + go _ [] = [] + go board0 [sm] = + let smr = convertSemiMove First board0 sm + board1 = applySemiMove First sm board0 + move = MoveRec smr Nothing + in [move] + go board0 (sm1 : sm2 : rest) = + let smr1 = convertSemiMove First board0 sm1 + board1 = applySemiMove First sm1 board0 + smr2 = convertSemiMove Second board1 sm2 + board2 = applySemiMove Second sm2 board1 + move = MoveRec smr1 smr2 + in move : go board2 rest + +gameToBoard :: SupervisorState -> [SemiMove] -> (Side, Board) +gameToBoard rnd game = go First (initBoard rnd russian) game + where + go side board [] = (side, board) + go side board (sm : rest) = + let board' = applySemiMove side sm board + in go (opposite side) board' rest + +compactFileToFen :: SupervisorState -> FilePath -> IO () +compactFileToFen rnd path = do + games <- parseCompactFile path + forM_ (zip [1.. ] games) $ \(i, game) -> do + if null game + then printf "empty game: %d" i + else do + let (side, board) = gameToBoard rnd game + fen = boardToFen side board + fenText = showFen (boardSize russian) fen + targetPath = printf "draw%d.fen" (i :: Int) + TIO.writeFile targetPath fenText + +compactFileToPdn :: SupervisorState -> FilePath -> IO () +compactFileToPdn rnd path = do + games <- parseCompactFile path + forM_ (zip [1.. ] $ filter (not . null) games) $ \(i, game) -> do + let targetPath = printf "draw%d.pdn" (i :: Int) + pdn = GameRecord tags (movesToInstructions moves) Nothing + moves = convertMoves rnd game + rules = SomeRules russian + tags = [Event "Game Opening", GameType rules] + pdnText = showPdn rules pdn + TIO.writeFile targetPath pdnText + diff --git a/src/Formats/Fen.hs b/src/Formats/Fen.hs new file mode 100644 --- /dev/null +++ b/src/Formats/Fen.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Formats.Fen where + +import Control.Monad.State +import qualified Data.Text as T +import Data.Monoid ((<>)) +import Text.Megaparsec hiding (Label) +import Text.Megaparsec.Char +import Text.Megaparsec.Error (parseErrorPretty) + +import Core.Types +import Core.Board +import Formats.Types + +pSide :: Parser Side +pSide = do + l <- oneOf ['W', 'B'] :: Parser Char + case l of + 'W' -> return First + 'B' -> return Second + +pPiece :: SomeRules -> Parser (Label, PieceKind) +pPiece (SomeRules rules) = do + kind <- do + k <- optional $ try $ char 'K' + case k of + Nothing -> return Man + Just _ -> return King + not <- some digitChar + lbl <- case parseNumericNotation (boardSize rules) (T.pack not) of + Left err -> fail err + Right lbl -> return lbl + return (lbl, kind) + +pFen :: SomeRules -> Parser Fen +pFen rules = do + turn <- pSide + char ':' + side1 <- pSide + pieces1 <- try (pPiece rules) `sepBy` char ',' + char ':' + side2 <- pSide + pieces2 <- try (pPiece rules) `sepBy` char ',' + if side1 == First + then return $ Fen turn pieces1 pieces2 + else return $ Fen turn pieces2 pieces1 + +fenToBoardRep :: Fen -> BoardRep +fenToBoardRep fen = + BoardRep $ [(lbl, Piece kind First) | (lbl, kind) <- fenFirst fen] ++ + [(lbl, Piece kind Second) | (lbl, kind) <- fenSecond fen] + +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 + Right fen -> Right (fenNextMove fen, fenToBoardRep fen) + +boardToFen :: Side -> Board -> Fen +boardToFen side b = + Fen { + fenNextMove = side, + fenFirst = [(lbl, Man) | lbl <- myMen First b] ++ + [(lbl, King) | lbl <- myKings First b], + fenSecond = [(lbl, Man) | lbl <- myMen Second b] ++ + [(lbl, King) | lbl <- myKings Second b] + } + +showFen :: BoardSize -> Fen -> T.Text +showFen bsize fen = + showSide (fenNextMove fen) <> ":W" <> + T.intercalate "," (map showPiece $ fenFirst fen) <> ":B" <> + T.intercalate "," (map showPiece $ fenSecond fen) + where + showSide First = "W" + showSide Second = "B" + + showPiece (lbl, Man) = numericNotation bsize lbl + showPiece (lbl, King) = "K" <> numericNotation bsize lbl + diff --git a/src/Formats/Pdn.hs b/src/Formats/Pdn.hs new file mode 100644 --- /dev/null +++ b/src/Formats/Pdn.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +module Formats.Pdn where + +import Control.Monad +import Control.Monad.State +import Data.Char +import Data.Maybe +import Data.List +import qualified Data.Map as M +import qualified Data.Text as T +import Text.Megaparsec hiding (Label, State) +import Text.Megaparsec.Char +import Text.Megaparsec.Error (parseErrorPretty) +import qualified Data.Text.IO as TIO +import Text.Printf + +import Core.Types +import Core.Board +import Rules.Diagonal +import Rules.English +import Rules.International +import Rules.Canadian +import Rules.Russian +import Rules.Simple +import Rules.Spancirety +import Formats.Types +import Formats.Fen + +pLabel :: SomeRules -> Parser Label +pLabel (SomeRules rules) = do + let letters = ['a' .. 'l'] + word <- some $ oneOf $ letters ++ map toUpper letters ++ ['0'..'9'] + case parseNotation rules (T.pack word) of + Left err -> fail err + Right label -> return label + +pSemiMove :: SomeRules -> Parser SemiMoveRec +pSemiMove rules = try full <|> try short + where + short = do + from <- pLabel rules + x <- oneOf ['-', 'x'] + let capture = (x == 'x') + to <- pLabel rules + return $ ShortSemiMoveRec from to capture + + full = do + first <- pLabel rules + char 'x' + second <- pLabel rules + char 'x' + rest <- pLabel rules `sepBy1` char 'x' + return $ FullSemiMoveRec (first : second : rest) + +whitespace :: Parser () +whitespace = label "white space or comment" $ do + some $ try pComment <|> try pNag <|> space1 + return () + +pNag :: Parser () +pNag = label "NAG" $ do + char '$' + some digitChar + return () + +pComment :: Parser () +pComment = between (char '{') (char '}') $ do + skipSome $ noneOf ['}'] + +pMove :: SomeRules -> Parser MoveRec +pMove rules = do + n <- some digitChar + char '.' + whitespace + first <- pSemiMove rules + whitespace + second <- optional $ try (pSemiMove rules) + return $ MoveRec (Just first) second + +pInstruction :: SomeRules -> Parser Instruction +pInstruction rules = + (try pSetSecondMoveNr) <|> (try pSetMoveNr) <|> + (try $ SemiMove `fmap` pSemiMove rules) <|> (try $ pVariant rules) + +pSetMoveNr :: Parser Instruction +pSetMoveNr = do + n <- some digitChar + char '.' + return $ SetMoveNumber (read n) + +pSetSecondMoveNr :: Parser Instruction +pSetSecondMoveNr = do + n <- some digitChar + char '.' + char '.' + char '.' + return $ SetSecondMoveNumber (read n) + +pVariant :: SomeRules -> Parser Instruction +pVariant rules = between (char '(') (char ')') $ do + optional whitespace + instructions <- try (pInstruction rules) `sepEndBy` whitespace + return $ Variant instructions + +pResult :: Parser (Maybe GameResult) +pResult = + (try $ string "*" >> return Nothing) + <|> (try $ string "1-0" >> return (Just FirstWin)) + <|> (try $ string "2-0" >> return (Just FirstWin)) + <|> (try $ string "0-1" >> return (Just SecondWin)) + <|> (try $ string "0-2" >> return (Just SecondWin)) + <|> (try $ string "1/2-1/2" >> return (Just Draw)) + <|> (try $ string "1-1" >> return (Just Draw)) + +pText :: Parser T.Text +pText = between (char '"') (char '"') $ do + str <- many $ noneOf ['"'] + return $ T.pack str + +pTag :: Parser Tag +pTag = do + tag <- choice $ map try [pEvent, pSite, pDate, pRound, pWhite, pBlack, pResultTag, pFenTag, pGameTypeTag, pOpening, pUnknown] + eol + return tag + where + pTag tag name parser = between (char '[') (char ']') $ do + string name + space1 + value <- parser + return $ tag value + + textTag tag name = pTag tag name pText + + pEvent = textTag Event "Event" + pSite = textTag Site "Site" + pDate = textTag Date "Date" + pRound = textTag Round "Round" + pWhite = textTag White "White" + pBlack = textTag Black "Black" + pResultTag = pTag Result "Result" $ between (char '"') (char '"') pResult + pFenTag = do + mbRules <- lift get + case mbRules of + Nothing -> fail "cant apply FEN: rules are not defined" + Just rules -> pTag FEN "FEN" $ between (char '"') (char '"') (pFen rules) + pGameTypeTag = do + tag@(GameType rules) <- pTag GameType "GameType" $ between (char '"') (char '"') pGameType + lift $ put $ Just rules + return tag + + pOpening = textTag Opening "Opening" + + pUnknown = between (char '[') (char ']') $ do + name <- some alphaNumChar + space1 + value <- pText + return $ Unknown (T.pack name) value + +pGameType :: Parser SomeRules +pGameType = do + n <- some digitChar + case n of + "20" -> return $ SomeRules international + "21" -> return $ SomeRules english + "25" -> return $ SomeRules russian + "27" -> return $ SomeRules canadian + "41" -> return $ SomeRules spancirety + "42" -> return $ SomeRules diagonal + "43" -> return $ SomeRules simple + _ -> fail $ "Unsupported rules: " ++ n + +rulesFromTags :: [Tag] -> Maybe SomeRules +rulesFromTags [] = Nothing +rulesFromTags (GameType r:_) = Just r +rulesFromTags (_:rest) = rulesFromTags rest + +pGame :: Maybe SomeRules -> Parser GameRecord +pGame dfltRules = do + tags <- some (try pTag) + case rulesFromTags tags `mplus` dfltRules of + Nothing -> fail "Rules are not defined" + Just rules -> do + eol + optional whitespace + moves <- try (pInstruction rules) `sepEndBy` whitespace + result <- pResult + return $ GameRecord tags moves result + +parsePdn :: Maybe SomeRules -> T.Text -> Either String GameRecord +parsePdn dfltRules text = + case evalState (runParserT (pGame dfltRules) "" text) dfltRules of + Left err -> Left $ parseErrorPretty 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 + Right pdn -> return pdn + +parseMoveRec :: GameRules rules => rules -> Side -> Board -> SemiMoveRec -> Move +parseMoveRec rules side board rec = + let moves = possibleMoves rules side board + passedFields m = nonCaptureLabels rules side board (pmMove m) + suits m = + case rec of + ShortSemiMoveRec {..} -> + aLabel (pmBegin m) == smrFrom && + aLabel (pmEnd m) == smrTo && + (not $ null $ pmVictims m) == smrCapture + FullSemiMoveRec {..} -> + (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) + +fenFromTags :: [Tag] -> Maybe Fen +fenFromTags [] = Nothing +fenFromTags (FEN fen:_) = Just fen +fenFromTags (_:rest) = fenFromTags rest + +initBoardFromTags :: SupervisorState -> SomeRules -> [Tag] -> Board +initBoardFromTags rnd (SomeRules rules) tags = + case fenFromTags tags of + Nothing -> initBoard rnd rules + Just fen -> parseBoardRep rnd rules $ fenToBoardRep fen + +resultFromTags :: [Tag] -> Maybe GameResult +resultFromTags [] = Nothing +resultFromTags (Result result : _) = result +resultFromTags (_ : rest) = resultFromTags rest + +data InterpreterState = InterpreterState { + isCurrentVariant :: Int + , isLastVariant :: Int + , isCurrentMove :: Int + , isCurrentSide :: Side + , isVariants :: M.Map Int (M.Map Int MoveRec) + } + +type Interpreter a = State InterpreterState a + +interpret :: Instruction -> Interpreter () +interpret (SetMoveNumber n) = + modify $ \st -> st {isCurrentMove = n, isCurrentSide = First} +interpret (SetSecondMoveNumber n) = + modify $ \st -> st {isCurrentMove = n, isCurrentSide = Second} +interpret (SemiMove rec) = do + side <- gets isCurrentSide + variant <- gets isCurrentVariant + moveNr <- gets isCurrentMove + modify $ \st -> + let updateVariant (Just moves) = Just $ M.alter setMove moveNr moves + updateVariant Nothing = Just $ M.singleton moveNr singleMove + + singleMove :: MoveRec + singleMove = + case side of + First -> MoveRec (Just rec) Nothing + Second -> MoveRec Nothing (Just rec) + + setMove :: Maybe MoveRec -> Maybe MoveRec + setMove Nothing = Just singleMove + setMove (Just old) = + case side of + First -> Just $ old {mrFirst = Just rec} + Second -> Just $ old {mrSecond = Just rec} + + in st {isVariants = M.alter updateVariant variant (isVariants st)} + when (side == First) $ + modify $ \st -> st {isCurrentSide = Second} +interpret (Variant instructions) = do + src <- gets isCurrentVariant + v <- gets isLastVariant + init <- gets (fromJust . M.lookup src . isVariants) + modify $ \st -> st { + isLastVariant = v+1, + isCurrentVariant = v+1, + isVariants = M.insert (v+1) init (isVariants st) + } + + forM_ instructions interpret + + modify $ \st -> st {isCurrentVariant = src} + +instructionsToMoves :: [Instruction] -> [[MoveRec]] +instructionsToMoves instructions = + let initState = InterpreterState 0 0 0 First M.empty + state = execState (forM_ instructions interpret) initState + in map M.elems $ M.elems $ isVariants state + +loadPdn :: SupervisorState -> GameRecord -> Board +loadPdn rnd r = + let findRules [] = Nothing + findRules (GameType rules:_) = Just rules + findRules (_:rest) = findRules rest + + withRules :: SomeRules -> Board + withRules some@(SomeRules rules) = + 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 + + in case instructionsToMoves (grMoves r) of + [moves] -> go board0 moves + vars -> error $ "multiple variants: " ++ show vars + + in case findRules (grTags r) of + Nothing -> error "rules are not specified" + Just rules -> withRules rules + +moveToInstructions :: Int -> MoveRec -> [Instruction] +moveToInstructions n move = + [SetMoveNumber n] + ++ case mrFirst move of + Nothing -> [] + Just rec -> [SemiMove rec] + ++ case mrSecond move of + Nothing -> [] + Just rec -> [SemiMove rec] + +movesToInstructions :: [MoveRec] -> [Instruction] +movesToInstructions moves = concat $ zipWith moveToInstructions [1..] moves + +gameToPdn :: SupervisorState -> Game -> GameRecord +gameToPdn rnd game = + GameRecord { + grTags = tags + , grMoves = moves + , grResult = result + } + where + result = case gStatus game of + Ended result -> Just result + _ -> Nothing + + tags = [Event "HCheckers game", GameType (gRules game)] + + moves = movesToInstructions $ translate (gRules game) board0 (reverse $ gsHistory $ gState game) + + board0 = case gRules game of + SomeRules rules -> initBoard rnd rules + + translate :: SomeRules -> Board -> [HistoryRecord] -> [MoveRec] + translate _ _ [] = [] + translate rules board [r] = [MoveRec (Just $ translateMove rules First board $ hrMove r) Nothing] + translate some@(SomeRules rules) board0 (r1:r2:rest) = + let m1 = translateMove some First board0 $ hrMove r1 + (board1,_,_) = applyMove rules First (hrMove r1) board0 + m2 = translateMove some Second board1 $ hrMove r2 + (board2,_,_) = applyMove rules Second (hrMove r2) board1 + rec = MoveRec (Just m1) (Just m2) + in rec : translate some board2 rest + + translateMove :: SomeRules -> Side -> Board -> Move -> SemiMoveRec + translateMove (SomeRules rules) side board move = + ShortSemiMoveRec { + smrFrom = aLabel (moveBegin move) + , smrTo = aLabel (moveEnd rules side board move) + , smrCapture = isCaptureM move + } + +showPdn :: SomeRules -> GameRecord -> T.Text +showPdn (SomeRules rules) gr = + T.unlines (map showTag $ grTags gr) <> "\n" <> + T.unlines (zipWith showMove [1..] (head $ instructionsToMoves $ grMoves gr)) <> "\n" <> + showResult (grResult gr) + where + showResult Nothing = "*" + showResult (Just FirstWin) = "1-0" + showResult (Just SecondWin) = "0-1" + showResult (Just Draw) = "1/2-1/2" + + showMove n (MoveRec (Just s1) Nothing) = T.pack (show n) <> ". " <> showSemiMove s1 + showMove n (MoveRec (Just s1) (Just s2)) = T.pack (show n) <> ". " <> showSemiMove s1 <> " " <> showSemiMove s2 + + showSemiMove (ShortSemiMoveRec from to False) = + boardNotation rules from <> "-" <> boardNotation rules to + showSemiMove (ShortSemiMoveRec from to True) = + boardNotation rules from <> "x" <> boardNotation rules to + + showTag (Event text) = T.pack (printf "[Event \"%s\"]" text) + showTag (Site text) = T.pack (printf "[Site \"%s\"]" text) + showTag (Date text) = T.pack (printf "[Date \"%s\"]" text) + showTag (Round text) = T.pack (printf "[Round \"%s\"]" text) + showTag (White text) = T.pack (printf "[White \"%s\"]" text) + showTag (Black text) = T.pack (printf "[Black \"%s\"]" text) + showTag (SetUp text) = T.pack (printf "[SetUp \"%s\"]" text) + showTag (Opening text) = T.pack (printf "[Opening \"%s\"]" text) + 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) + diff --git a/src/Formats/Types.hs b/src/Formats/Types.hs new file mode 100644 --- /dev/null +++ b/src/Formats/Types.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Formats.Types where + +import Control.Monad.State +import qualified Data.Text as T +import Data.List (intercalate) +import Data.Typeable +import Text.Megaparsec hiding (Label, State) +import Data.Void + +import Core.Types + +type Parser a = ParsecT Void T.Text (State (Maybe SomeRules)) a + +data Tag = + Event T.Text + | Site T.Text + | Date T.Text + | Round T.Text + | White T.Text + | Black T.Text + | Result (Maybe GameResult) + | SetUp T.Text + | FEN Fen + | GameType SomeRules + | Opening T.Text + | Unknown T.Text T.Text + deriving (Show, Typeable) + +data SemiMoveRec = + FullSemiMoveRec { + smrLabels :: [Label] + } + | ShortSemiMoveRec { + smrFrom :: Label + , smrTo :: Label + , smrCapture :: Bool + } + deriving (Eq, Typeable) + +instance Show SemiMoveRec where + show (r@(ShortSemiMoveRec{})) + | smrCapture r = show (smrFrom r) ++ "x" ++ show (smrTo r) + | otherwise = show (smrFrom r) ++ "-" ++ show (smrTo r) + show r = intercalate "x" $ map show (smrLabels r) + +data MoveRec = MoveRec { + mrFirst :: Maybe SemiMoveRec + , mrSecond :: Maybe SemiMoveRec + } + deriving (Eq, Typeable) + +instance Show MoveRec where + show r = show (mrFirst r) ++ ", " ++ show (mrSecond r) + +data Instruction = + SetMoveNumber Int + | SetSecondMoveNumber Int + | SemiMove SemiMoveRec + | Variant [Instruction] + deriving (Typeable) + +instance Show Instruction where + show (SetMoveNumber n) = show n ++ "." + show (SetSecondMoveNumber n) = show n ++ "..." + show (SemiMove rec) = show rec + show (Variant list) = show list + +data GameRecord = GameRecord { + grTags :: [Tag] + , grMoves :: [Instruction] + , grResult :: Maybe GameResult + } + deriving (Show, Typeable) + +data Fen = Fen { + fenNextMove :: Side + , fenFirst :: [(Label, PieceKind)] + , fenSecond :: [(Label, PieceKind)] + } + deriving (Eq, Show, Typeable) + diff --git a/src/Learn.hs b/src/Learn.hs new file mode 100644 --- /dev/null +++ b/src/Learn.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Learn where + +import Control.Monad +import Control.Monad.State +import Control.Concurrent.STM +import qualified Control.Monad.Metrics as Metrics +import Control.Monad.Catch +import Data.Text.Format.Heavy +import System.Log.Heavy +import System.Log.Heavy.TH + +import Core.Types +import Core.Board +import AI.AlphaBeta +import AI.AlphaBeta.Types +import AI.AlphaBeta.Cache +import AI.AlphaBeta.Persistent +import Formats.Types +import Formats.Pdn + +doLearn' :: (GameRules rules, Evaluator eval) => rules -> eval -> AICacheHandle rules eval -> AlphaBetaParams -> GameRecord -> Checkers () +doLearn' rules eval var params gameRec = do + sup <- askSupervisor + supervisor <- liftIO $ atomically $ readTVar sup + let startBoard = initBoardFromTags supervisor (SomeRules rules) (grTags gameRec) + let result = resultFromTags $ grTags gameRec + $info "Initial board: {}; result: {}" (show startBoard, show result) + forM_ (instructionsToMoves $ grMoves gameRec) $ \moves -> (do + let (endScore, allBoards) = go [] startBoard result moves + $info "End score: {}" (Single endScore) + runStorage var $ forM_ allBoards $ \board -> do + let stats = Stats 1 endScore endScore endScore + putStatsFile board stats + ) + `catch` + (\(e :: SomeException) -> $reportError "Exception: {}" (Single $ show e)) + where + go boards lastBoard (Just result) [] = (resultToScore result, lastBoard : boards) + go boards lastBoard Nothing [] = + let score = evalBoard eval First lastBoard + in (score, lastBoard : boards) + go boards board0 mbResult (moveRec : rest) = + let board1 = case mrFirst moveRec of + Nothing -> board0 + Just rec -> + let 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 + (board2, _, _) = applyMove rules Second move2 board1 + in board2 + in go (board1 : boards) board2 mbResult rest + + resultToScore FirstWin = win + resultToScore SecondWin = loose + resultToScore Draw = 0 + +doLearn :: (GameRules rules, Evaluator eval) + => rules + -> eval + -> AICacheHandle rules eval + -> AlphaBetaParams + -> GameId + -> GameRecord + -> Checkers () +doLearn rules eval var params gameId gameRec = do + sup <- askSupervisor + supervisor <- liftIO $ atomically $ readTVar sup + let startBoard = initBoardFromTags supervisor (SomeRules rules) (grTags gameRec) + $info "Initial board: {}; tags: {}" (show startBoard, show $ grTags gameRec) + forM_ (instructionsToMoves $ grMoves gameRec) $ \moves -> do + (endScore, allBoards) <- go (0, []) startBoard [] moves + $info "End score: {}" (Single endScore) + runStorage var $ forM_ allBoards $ \board -> do + let stats = Stats 1 endScore endScore endScore + putStatsFile board stats + + where + go (score, boards) lastBoard _ [] = return (score, lastBoard : boards) + go (score0, boards) board0 predicted (moveRec : rest) = do + (board1, predict2, score2) <- do + case mrFirst moveRec of + Nothing -> return (board0, [], score0) + Just rec -> do + let move1 = parseMoveRec rules First board0 rec + if move1 `elem` map pmMove predicted + then Metrics.increment "learn.hit" + else Metrics.increment "learn.miss" + let (board1, _,_) = applyMove rules First move1 board0 + (predict2, score2) <- processMove rules eval var params gameId Second move1 board1 + return (board1, predict2, score2) + case mrSecond moveRec of + Nothing -> return (score2, board0 : board1 : boards) + Just rec -> do + let move2 = parseMoveRec rules Second board1 rec + if move2 `elem` map pmMove predict2 + then Metrics.increment "learn.hit" + else Metrics.increment "learn.miss" + let (board2, _, _) = applyMove rules Second move2 board1 + (predict1, score1) <- processMove rules eval var params gameId First move2 board2 + go (score1, board0 : board1 : boards) board2 predict1 rest + +processMove :: (GameRules rules, Evaluator eval) + => rules + -> eval + -> AICacheHandle rules eval + -> AlphaBetaParams + -> GameId + -> Side + -> Move + -> Board + -> Checkers ([PossibleMove], Score) +processMove rules eval var params gameId side move board = do + let ai = AlphaBeta params rules eval + (moves, score) <- runAI ai var gameId side board + $info "Processed: side {}, move: {}, depth: {} => score {}; we think next best moves are: {}" (show side, show move, abDepth params, show score, show moves) + return (moves, score) + +learnPdn :: (GameRules rules, Evaluator eval) => AlphaBeta rules eval -> FilePath -> Checkers () +learnPdn ai@(AlphaBeta params rules eval) path = do + cache <- loadAiCache scoreMove ai + pdn <- liftIO $ parsePdnFile (Just $ SomeRules rules) path + let n = length pdn + forM_ (zip [1.. ] pdn) $ \(i, gameRec) -> do + -- liftIO $ print pdn + $info "Processing game {}/{}..." (i :: Int, n) + doLearn rules eval cache params (show i) gameRec + -- saveAiCache rules params cache + return () + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Main where + +import Control.Monad.Reader +import Control.Concurrent.STM +import Data.Default +import System.Log.Heavy +import Options.Applicative + +import Core.Types +import Core.Board +import AI.AlphaBeta.Types +import AI.AlphaBeta.Persistent +import Core.Rest +import Core.Checkers +import Core.CmdLine + +import Learn +import Rules.Russian + + -- let stdout = LoggingSettings $ filtering defaultLogFilter defStdoutSettings + -- debug = LoggingSettings $ Filtering (\m -> lmLevel m == trace_level) ((defFileSettings "trace.log") {lsFormat = "{time} {source} [{thread}]: {message}\n"}) + -- settings = LoggingSettings $ ParallelLogSettings [stdout, debug] + +main :: IO () +main = do + cmd <- execParser parserInfo + case cmdSpecial cmd of + Nothing -> + withCheckers cmd $ do + cfg <- asks csConfig + let fltr = [([], gcLogLevel cfg)] + withLogContext (LogContextFrame [] (include fltr)) $ + runRestServer + Just str -> special cmd (words str) + +special :: CmdLine -> [String] -> IO () +special cmd args = + case args of + ["learn", path] -> do + let rules = russian + eval = ai + params = def { + abDepth = 4 + , abCombinationDepth = 9 + } + ai = AlphaBeta params rules (dfltEvaluator rules) + withCheckers cmd $ + withLogContext (LogContextFrame [] (include defaultLogFilter)) $ + learnPdn ai 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'') + +-- main :: IO () +-- main = do +-- let a3 = resolve "a3" board8 +-- let b4 = resolve "b4" board8 +-- let c5 = resolve "c5" board8 +-- let b6 = resolve "b6" board8 +-- let board8' = movePiece' "h8" "b4" $ removePiece' "a7" board8 +-- let capture = simpleCapture First a3 ForwardRight +-- putStrLn "1." +-- print capture +-- +-- putStrLn "2." +-- let (board', addr', p) = applyMove First capture board8' +-- print $ getPiece a3 board' +-- print $ getPiece b4 board' +-- print $ getPiece c5 board' +-- print $ getPiece b6 board' +-- +-- let capture' = simpleCapture First c5 +-- +-- putStrLn "3." +-- print $ +-- let addr = resolve "c5" board' +-- piece = fromJust $ getPiece addr board' +-- in captures1 piece board' addr +-- +-- putStrLn "4." +-- print $ +-- let addr = resolve "a3" board8' +-- piece = fromJust $ getPiece addr board8' +-- in manCaptures piece board8' addr +-- +-- putStrLn "5." +-- print $ possibleMoves Russian First board8' +-- +-- putStrLn "6." +-- let board8'' = setPiece' "b2" (Piece King First) $ +-- setManyPieces' ["d4", "d6", "g7"] (Piece Man Second) $ buildBoard 8 +-- print $ kingSimpleMoves First board8'' (resolve "b2" board8'') +-- +-- putStrLn "7." +-- print $ possibleMoves Russian First board8'' +-- +-- putStrLn "8." +-- let board = board8'' +-- let moves = possibleMoves Russian Second board +-- forM_ moves $ \move -> do +-- print move +-- let (board', addr', _) = applyMove Second move board +-- moves' = possibleMoves Russian Second board' +-- let score1 = evalBoard Russian First board' +-- score2 = evalBoard Russian Second board' +-- putStrLn $ show score1 ++ " vs " ++ show score2 +-- +-- putStrLn "9." +-- let board = movePiece' "e3" "f4" board8 +-- let moves = possibleMoves Russian Second board +-- forM_ moves $ \move -> do +-- let (board', addr', _) = applyMove Second move board +-- moves' = possibleMoves Russian Second board' +-- let score1 = evalBoard Russian First board' +-- score2 = evalBoard Russian Second board' +-- putStrLn $ show move ++ " => " ++ show score1 ++ " vs " ++ show score2 +-- +-- putStrLn "10." +-- let board = setManyPieces' ["c3", "e3"] (Piece Man First) $ +-- setManyPieces' ["e5", "f6"] (Piece Man Second) $ buildBoard 8 +-- let ai = AlphaBeta 2 Russian Russian +-- print =<< chooseMove ai Second board +-- +-- +-- putStrLn "11." +-- let board = setManyPieces' ["c3", "e3"] (Piece Man First) $ +-- setManyPieces' ["e5", "f6"] (Piece Man Second) $ buildBoard 8 +-- let ai = AlphaBeta 2 Russian Russian +-- print =<< chooseMove ai First board +-- +-- diff --git a/src/Rules/Brazilian.hs b/src/Rules/Brazilian.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Brazilian.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Rules.Brazilian (Brazilian, brazilian) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic +import Rules.International +import Rules.Russian + +newtype Brazilian = Brazilian GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Brazilian where + show = rulesName + +instance GameRules Brazilian where + boardSize _ = (8, 8) + + initBoard rnd _ = initBoard rnd russian + + dfltEvaluator r = SomeEval $ defaultEvaluator r + + boardNotation _ = boardNotation international + parseNotation _ = parseNotation international + + rulesName _ = "brazilian" + + pdnId _ = "26" + + updateRules r _ = r + + possibleMoves (Brazilian rules) side board = gPossibleMoves rules side board + mobilityScore (Brazilian rules) side board = gMobilityScore rules side board + + getGameResult = genericGameResult + +brazilian :: Brazilian +brazilian = Brazilian $ + let rules = internationalBase rules + in rules + diff --git a/src/Rules/Canadian.hs b/src/Rules/Canadian.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Canadian.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Rules.Canadian (Canadian, canadian) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic +import Rules.International + +newtype Canadian = Canadian GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Canadian where + show = rulesName + +instance GameRules Canadian where + boardSize _ = (12, 12) + + initBoard rnd r = + let board = buildBoard rnd (boardOrientation r) (12, 12) + labels1 = ["a1", "c1", "e1", "g1", "i1", "k1", + "b2", "d2", "f2", "h2", "j2", "l2", + "a3", "c3", "e3", "g3", "i3", "k3", + "b4", "d4", "f4", "h4", "j4", "l4", + "a5", "c5", "e5", "g5", "i5", "k5"] + + labels2 = ["b12", "d12", "f12", "h12", "j12", "l12", + "a11", "c11", "e11", "g11", "i11", "k11", + "b10", "d10", "f10", "h10", "j10", "l10", + "a9", "c9", "e9", "g9", "i9", "k9", + "b8", "d8", "f8", "h8", "j8", "l8"] + + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} + + boardNotation r = numericNotation (boardSize r) + + parseNotation r = parseNumericNotation (boardSize r) + + rulesName _ = "canadian" + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "27" + + possibleMoves (Canadian rules) side board = gPossibleMoves rules side board + mobilityScore (Canadian rules) side board = gMobilityScore rules side board + +canadian :: Canadian +canadian = Canadian $ + let rules = internationalBase rules + in rules + diff --git a/src/Rules/Diagonal.hs b/src/Rules/Diagonal.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Diagonal.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rules.Diagonal (Diagonal, diagonal) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Russian +import Rules.Generic + +newtype Diagonal = Diagonal GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Diagonal where + show = rulesName + +instance GameRules Diagonal where + initBoard rnd r = + let board = buildBoard rnd (boardOrientation r) (8, 8) + labels1 = ["c1", "e1", "g1", + "d2", "f2", "h2", + "e3", "g3", + "f4", "h4", + "g5", + "h6"] + labels2 = ["b8", "d8", "f8", + "a7", "c7", "e7", + "b6", "d6", + "a5", "c5", + "b4", + "a3"] + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + boardSize _ = (8, 8) + + dfltEvaluator r = SomeEval $ defaultEvaluator r + + boardNotation _ = boardNotation russian + + parseNotation _ = parseNotation russian + + rulesName _ = "diagonal" + + possibleMoves _ = possibleMoves russian + mobilityScore _ = mobilityScore russian + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "42" + +diagonal :: Diagonal +diagonal = Diagonal $ + let rules = russianBase rules + in rules + diff --git a/src/Rules/English.hs b/src/Rules/English.hs new file mode 100644 --- /dev/null +++ b/src/Rules/English.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rules.English (English (..), english) where + +import Data.Typeable +import Data.List + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Evaluator +import qualified Rules.Russian as Russian +import Rules.Generic + +newtype English = English GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show English where + show = rulesName + +instance GameRules English where + boardSize _ = boardSize Russian.russian + + initBoard rnd r = + let board = buildBoard rnd (boardOrientation r) (boardSize r) + labels1 = line1labels ++ line2labels ++ line3labels + labels2 = line8labels ++ line7labels ++ line6labels + in setManyPieces' labels1 (Piece Man Second) $ setManyPieces' labels2 (Piece Man First) board + + boardNotation r = numericNotation (boardSize r) + parseNotation r = parseNumericNotation (boardSize r) + + dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 2, seHelpedKingCoef = 3} + + rulesName _ = "english" + updateRules r _ = r + getGameResult = genericGameResult + + possibleMoves (English rules) side board = gPossibleMoves rules side board + mobilityScore (English rules) side board = gMobilityScore rules side board + + pdnId _ = "21" + +english :: English +english = English $ + let rules = (abstractRules rules) { + gKingSimpleMoves = kingSimpleMoves rules, + gManCaptures = manCaptures rules, + gKingCaptures = kingCaptures rules, + gKingCaptures1 = kingCaptures1 rules, + gManCaptureDirections = [ForwardLeft, ForwardRight], + gBoardOrientation = SecondAtBottom + } + in rules + +kingSimpleMoves :: GenericRules -> Side -> Board -> Address -> [PossibleMove] +kingSimpleMoves rules side board src = + concatMap check (gKingSimpleMoveDirections rules) + where + piece = Piece King side + + check dir = + case myNeighbour rules side dir src of + Nothing -> [] + Just dst -> if isFree dst board + then [PossibleMove { + pmBegin = src, + pmEnd = dst, + pmVictims = [], + pmMove = Move src [Step dir False False], + pmPromote = False, + pmResult = [Take src, Put dst piece] + }] + else [] + +captures1 :: GenericRules -> CaptureState -> [PlayerDirection] -> [Capture] +captures1 rules ct@(CaptureState {..}) dirs = + concatMap (check ctCurrent) $ filter allowedDir dirs + where + side = pieceSide ctPiece + + allowedDir dir = + case ctPrevDirection of + Nothing -> True + Just prevDir -> oppositeDirection prevDir /= dir + + check a dir = + case neighbour (myDirection 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 neighbour (myDirection rules side dir) victimAddr of + Nothing -> [] + Just freeAddr -> if isFree freeAddr ctBoard + then [Capture { + cSrc = a, + cDirection = dir, + cInitSteps = 0, + cFreeSteps = 1, + cVictim = victimAddr, + cDst = freeAddr, + cPromote = isLastHorizontal side freeAddr + }] + else [] + _ -> [] + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let side = pieceSide ctPiece + captures = gManCaptures1 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] + +kingCaptures1 :: GenericRules -> CaptureState -> [Capture] +kingCaptures1 rules ct = + captures1 rules ct (gKingCaptureDirections rules) + +kingCaptures :: GenericRules -> CaptureState -> [PossibleMove] +kingCaptures rules ct@(CaptureState {..}) = + let captures = gKingCaptures1 rules ct + -- king cant be promoted anyway + nextMoves pm = genericNextMoves rules ct False pm + in nub $ concat $ flip map captures $ \capture1 -> + let moves1 = translateCapture ctPiece capture1 + allNext = map nextMoves moves1 + isLast = all null allNext + in if isLast + then moves1 + else [catPMoves move1 move2 | move1 <- moves1, move2 <- nextMoves move1] + diff --git a/src/Rules/Generic.hs b/src/Rules/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Generic.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +module Rules.Generic where + +import Data.List +import Data.Maybe + +import Core.Types +import Core.Board +import Core.BoardMap + +-- | Describes one jump during capture move; +-- capture can conssit of several jumps. +data Capture = Capture { + cSrc :: Address -- ^ Source piece position + , cDirection :: PlayerDirection -- ^ Direction of jump + , cInitSteps :: Int -- ^ Number of steps by free fields that we have to do before the actual capture. + -- If a piece is a man, this is obviously always 0. + , cVictim :: Address -- ^ Position of piece being captured + , cFreeSteps :: Int -- ^ Number of steps by free fields that we are doing after actual capture. + -- For man, this is always 1. + , cDst :: Address -- ^ End position of capture. + , cPromote :: Bool -- ^ Whether the piece should be promoted at the end of this jump. + } + +-- | State that we have to track during single capture move. +data CaptureState = CaptureState { + ctPrevDirection :: Maybe PlayerDirection -- ^ Previous capture direction + , ctCaptured :: LabelSet -- ^ Fields that were already captured; we have to track this to prevent one piece being captured twice + , ctPiece :: Piece -- ^ Piece that is performing the capture + , ctBoard :: Board -- ^ Current board state + , ctCurrent :: Address -- ^ Current position of the piece + , ctSource :: Address -- ^ Starting position of capture + } + +-- | Initial capture state +initState :: Piece -> Board -> Address -> CaptureState +initState piece board src = CaptureState Nothing emptyLabelSet piece board src src + +-- | An `Abstract class` for game rules +data GenericRules = GenericRules { + gPossibleMoves :: Side -> Board -> [PossibleMove] + , gMobilityScore :: Side -> Board -> Int + , gPossibleSimpleMoves1 :: Board -> Address -> [PossibleMove] + , gPossibleCaptures1 :: Board -> Address -> [PossibleMove] + , gManSimpleMoves :: Side -> Board -> Address -> [PossibleMove] + , gKingSimpleMoves :: Side -> Board -> Address -> [PossibleMove] + , gManCaptures :: CaptureState -> [PossibleMove] + , gKingCaptures :: CaptureState -> [PossibleMove] + , gPieceCaptures1 :: CaptureState -> [Capture] + , gPieceCaptures :: CaptureState -> [PossibleMove] + , gManCaptures1 :: CaptureState -> [Capture] + , gKingCaptures1 :: CaptureState -> [Capture] + , gCanCaptureFrom :: CaptureState -> Bool + , gManSimpleMoveDirections :: [PlayerDirection] + , gKingSimpleMoveDirections :: [PlayerDirection] + , gManCaptureDirections :: [PlayerDirection] + , gKingCaptureDirections :: [PlayerDirection] + , gBoardOrientation :: BoardOrientation + , gCaptureMax :: Bool + } + +instance HasBoardOrientation GenericRules where + boardOrientation = gBoardOrientation + +translateCapture :: Piece -> Capture -> [PossibleMove] +translateCapture piece@(Piece _ side) capture = + [PossibleMove { + pmBegin = src, + pmEnd = dst, + pmVictims = [victim], + pmMove = Move src (steps $ cFreeSteps capture), + pmPromote = promote, + pmResult = [Take src, RemoveCaptured victim, Put dst piece'] + }] + where + steps n = replicate (cInitSteps capture) (Step dir False False) ++ + [Step dir True False] ++ + replicate (n-1) (Step dir False False) ++ + [Step dir False promote] + dir = cDirection capture + promote = cPromote capture + src = cSrc capture + dst = cDst capture + victim = cVictim capture + piece' = if promote then promotePiece piece else piece + + +freeFields :: HasBoardOrientation rules => rules -> Side -> PlayerDirection -> Address -> Board -> (Int, [Address]) +freeFields rules side dir addr board = + case myNeighbour rules side dir addr of + Nothing -> (0, []) + Just a' -> if isFree a' board + then let (n, prev) = freeFields rules side dir a' board + in (n+1, a' : prev) + else (0, []) + +genericNextMoves :: GenericRules -> CaptureState -> Bool -> PossibleMove -> [PossibleMove] +genericNextMoves rules ct@(CaptureState {..}) continuePromoted pm = + gPieceCaptures rules $ ct { + ctPrevDirection = Just (firstMoveDirection m), + ctCaptured = captured', + ctPiece = piece', + ctBoard = b, + ctCurrent = pmEnd pm + } + where + m = pmMove pm + promoted = if pmPromote pm + then promotePiece ctPiece + else ctPiece + piece' = if continuePromoted + then promoted + else ctPiece + b = setPiece (pmEnd pm) piece' $ removePiece ctCurrent ctBoard + captured' = foldr insertLabelSet ctCaptured (map aLabel $ pmVictims pm) + +abstractRules :: GenericRules -> GenericRules +abstractRules = + let + possibleMoves rules side board = + -- let (simpleMoves, captures) = searchMoves rules side board False ([], []) + let simpleMoves = concatMap (gManSimpleMoves rules side board) (filter (manHasSimpleMoves rules side board) $ myMenA side board) ++ + concatMap (gKingSimpleMoves rules side board) (myKingsA side board) + captures = concatMap (manCaptures' rules side board) (filter (manHasCaptures rules side board) $ myMenA side board) ++ + concatMap (kingCaptures' rules side board) (myKingsA side board) + -- concatMap (gPossibleCaptures1 rules board) (allMyAddresses side board) + in if gCaptureMax rules + then + if null captures + then simpleMoves + else + let captures' = sortOn (negate . length . pmVictims) captures + n = length $ pmVictims (head captures') + in filter (\c -> length (pmVictims c) == n) captures' + else if null captures + then simpleMoves + else captures + +-- searchMoves _ _ _ _ (accSimple, accCaptures) [] = (accSimple, accCaptures) +-- searchMoves rules side board False (accSimple, accCaptures) ((addr, pieceKind) : rest) = +-- case pieceKind of +-- Man | manHasCaptures rules side board addr -> +-- let captures = manCaptures' rules side board addr +-- in searchMoves rules side board True ([], captures ++ accCaptures) rest +-- | manHasSimpleMoves rules side board addr -> +-- let moves = gManSimpleMoves rules side board addr +-- in searchMoves rules side board False (moves ++ accSimple, accCaptures) rest +-- | otherwise -> +-- searchMoves rules side board False (accSimple, accCaptures) rest +-- King -> let captures = kingCaptures' rules side board addr +-- simple = gKingSimpleMoves rules side board addr +-- in if null captures +-- then searchMoves rules side board False (simple ++ accSimple, accCaptures) rest +-- else searchMoves rules side board True ([], captures ++ accCaptures) rest +-- searchMoves rules side board True (accSimple, accCaptures) ((addr, pieceKind) : rest) = +-- case pieceKind of +-- Man | manHasCaptures rules side board addr -> +-- let captures = manCaptures' rules side board addr +-- in searchMoves rules side board True ([], captures ++ accCaptures) rest +-- | otherwise -> +-- searchMoves rules side board True (accSimple, accCaptures) rest +-- King -> let captures = kingCaptures' rules side board addr +-- in searchMoves rules side board True ([], captures ++ accCaptures) rest + + mobility rules side board = + let (men, kings) = myCounts side board + in if kings > 0 + then kings * 4 + else sum $ map (manSimpleMovesCount rules side board) (myMenA side board) + + manCaptures' rules side board src = + gManCaptures rules $ initState (Piece Man side) board src + + kingCaptures' rules side board src = + gKingCaptures rules $ initState (Piece King side) board src + + possibleSimpleMoves1 rules board src = + case getPiece src board of + Nothing -> error $ "possibleSimpleMoves1: not my field" + Just (Piece Man side) -> gManSimpleMoves rules side board src + Just (Piece King side) -> gKingSimpleMoves rules side board src + + possibleCaptures1 rules board src = + case getPiece src board of + Nothing -> error $ "possibleCaptures: not my field" + Just piece@(Piece Man _) -> gManCaptures rules $ initState piece board src + Just piece@(Piece King _) -> gKingCaptures rules $ initState piece board src + + pieceCaptures rules ct@(CaptureState {..}) = + case ctPiece of + (Piece Man _) -> gManCaptures rules ct + (Piece King _) -> gKingCaptures rules ct + + manHasSimpleMoves rules side board src = any check (gManSimpleMoveDirections rules) + where + check dir = + case myNeighbour rules side dir src of + Nothing -> False + Just dst -> isFree dst board + + manSimpleMovesCount rules side board src = sum $ map check (gManSimpleMoveDirections rules) + where + check dir = + case myNeighbour rules side dir src of + Nothing -> 0 + Just dst -> if isFree dst board then 1 else 0 + + manSimpleMoves rules side board src = + mapMaybe check (gManSimpleMoveDirections rules) + where + check dir = + case myNeighbour rules side dir src of + Nothing -> Nothing + Just dst -> if isFree dst board + then let move = Move src [Step dir False promote] + promote = isLastHorizontal side dst + piece' = if promote then Piece King side else Piece Man side + in Just $ PossibleMove { + pmBegin = src, + pmEnd = dst, + pmVictims = [], + pmMove = move, + pmPromote = promote, + pmResult = [Take src, Put dst piece'] + } + + else Nothing + + pieceCaptures1 rules ct@(CaptureState {..}) = + case ctPiece of + (Piece Man _) -> gManCaptures1 rules ct + (Piece King _) -> gKingCaptures1 rules ct + + manHasCaptures rules side board src = any check (gManCaptureDirections rules) + where + check dir = + case myNeighbour rules side dir src of + Nothing -> False + Just victimAddr -> + if isPieceAt victimAddr board (opposite side) + then case myNeighbour rules side dir victimAddr of + Nothing -> False + Just dst -> isFree dst board + else False + + manCaptures1 rules (CaptureState {..}) = + mapMaybe (check ctCurrent) $ filter allowedDir (gManCaptureDirections rules) + where + side = pieceSide ctPiece + + allowedDir dir = + case ctPrevDirection of + Nothing -> True + Just prevDir -> oppositeDirection prevDir /= dir + + check a dir = + case myNeighbour rules side dir a of + Just victimAddr | not (aLabel victimAddr `labelSetMember` ctCaptured) -> + if isPieceAt victimAddr ctBoard (opposite side) + then case myNeighbour rules side dir victimAddr of + Nothing -> Nothing + Just freeAddr -> if isFree freeAddr ctBoard + then Just $ Capture { + cSrc = a, + cDirection = dir, + cInitSteps = 0, + cVictim = victimAddr, + cFreeSteps = 1, + cDst = freeAddr, + cPromote = isLastHorizontal side freeAddr + } + else Nothing + else Nothing + _ -> Nothing + + -- This is a most popular implementation, which fits most rules + -- except for english / checkers. + kingCaptures1 rules (CaptureState {..}) = + concatMap check $ filter allowedDir (gKingCaptureDirections rules) + where + side = pieceSide ctPiece + + allowedDir dir = + case ctPrevDirection of + Nothing -> True + Just prevDir -> oppositeDirection prevDir /= dir + + check dir = + case search dir ctCurrent of + Nothing -> [] + Just (victimAddr, initSteps) -> + case freeFields rules side dir victimAddr ctBoard of + (0,_) -> [] + (nFree, fields) -> + [mkCapture dir initSteps victimAddr freeSteps (fields !! (freeSteps-1)) | freeSteps <- [1 .. nFree]] + + mkCapture dir init victim free dst = + Capture { + cSrc = ctCurrent, + cDirection = dir, + cInitSteps = init, + cVictim = victim, + cFreeSteps = free, + cDst = dst, + cPromote = False + } + + search :: PlayerDirection -> Address -> Maybe (Address, Int) + search dir a = + case myNeighbour rules side dir a of + Nothing -> Nothing + Just a' -> case getPiece a' ctBoard of + Nothing -> case search dir a' of + Nothing -> Nothing + Just (victimAddr, steps) -> Just (victimAddr, steps + 1) + Just p -> if isOpponentPiece side p && not (aLabel a' `labelSetMember` ctCaptured) + then Just (a', 0) + else Nothing + + -- This is most popular implementation, which fits most rules + -- except for english / checkers + kingCaptures rules ct@(CaptureState {..}) = + let side = pieceSide ctPiece + captures = gPieceCaptures1 rules ct + grouped = groupBy (\c1 c2 -> cDirection c1 == cDirection c2) $ sortOn cDirection captures + capturesByDirection = [(cDirection (head cs), cs) | cs <- grouped] + nextMoves pm = genericNextMoves rules ct False pm + in nub $ concat $ flip map capturesByDirection $ \(dir, captures) -> + let moves1 c = translateCapture ctPiece c + allNext c = map nextMoves (moves1 c) + isLast c = all null (allNext c) + in if all isLast captures + then concatMap moves1 captures + else [catPMoves move1 move2 | c <- captures, move1 <- moves1 c, move2 <- nextMoves move1] + + -- This is most popular implementation, which fits most rules + -- except for english / checkers + kingSimpleMoves rules side board src = + concatMap check (gKingSimpleMoveDirections rules) + where + check dir = + let (nFree,free) = freeFields rules side dir src board + piece = Piece King side + in [PossibleMove { + pmBegin = src, + pmEnd = free !! (n-1), + pmVictims = [], + pmMove = Move src (replicate n (Step dir False False)), + pmPromote = False, + pmResult = [Take src, Put (free !! (n-1)) piece] + } | n <- [1..nFree]] + + canCaptureFrom rules ct@(CaptureState {ctPiece = Piece Man side}) = + not $ null (gManCaptures1 rules ct) + canCaptureFrom rules ct@(CaptureState {ctPiece = Piece King side}) = + not $ null (gKingCaptures1 rules ct) + + manSimpleMoveDirections rules = [ForwardLeft, ForwardRight] + + orientation rules = FirstAtBottom + + rules this = GenericRules { + gPossibleMoves = possibleMoves this + , gMobilityScore = mobility this + , gPossibleSimpleMoves1 = possibleSimpleMoves1 this + , gPossibleCaptures1 = possibleCaptures1 this + , gManSimpleMoves = manSimpleMoves this + , gKingSimpleMoves = kingSimpleMoves this + , gKingCaptures1 = kingCaptures1 this + , gKingCaptures = kingCaptures this + , gPieceCaptures1 = pieceCaptures1 this + , gPieceCaptures = pieceCaptures this + , gManCaptures1 = manCaptures1 this + , gManCaptures = error "gManCaptures has to be implemented in specific rules" + , gCanCaptureFrom = canCaptureFrom this + , gManSimpleMoveDirections = manSimpleMoveDirections this + , gKingSimpleMoveDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight] + , gManCaptureDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight] + , gKingCaptureDirections = [ForwardLeft, ForwardRight, BackwardLeft, BackwardRight] + , gBoardOrientation = orientation this + , gCaptureMax = False + } + in rules + diff --git a/src/Rules/International.hs b/src/Rules/International.hs new file mode 100644 --- /dev/null +++ b/src/Rules/International.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Rules.International (International, international, internationalBase) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Evaluator +import Rules.Generic + +-- import Debug.Trace + +newtype International = International GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show International where + show = rulesName + +instance GameRules International where + boardSize _ = (10, 10) + + initBoard rnd r = + let board = buildBoard rnd (boardOrientation r) (10, 10) + labels1 = ["a1", "c1", "e1", "g1", "i1", + "b2", "d2", "f2", "h2", "j2", + "a3", "c3", "e3", "g3", "i3", + "b4", "d4", "f4", "h4", "j4"] + + labels2 = ["b10", "d10", "f10", "h10", "j10", + "a9", "c9", "e9", "g9", "i9", + "b8", "d8", "f8", "h8", "j8", + "a7", "c7", "e7", "g7", "i7"] + + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + boardNotation r = numericNotation (boardSize r) + + dfltEvaluator r = SomeEval $ (defaultEvaluator r) {seKingCoef = 5, seHelpedKingCoef = 6} + + parseNotation r = parseNumericNotation (boardSize r) + + rulesName _ = "international" + + updateRules r _ = r + + getGameResult = genericGameResult + + possibleMoves (International rules) side board = gPossibleMoves rules side board + mobilityScore (International rules) side board = gMobilityScore rules side board + + pdnId _ = "20" + +internationalBase :: GenericRules -> GenericRules +internationalBase = + let rules this = abstractRules this { + gManCaptures = manCaptures this, + gManCaptures1 = manCaptures1 this, + gCaptureMax = True + } + in rules + +international :: International +international = International $ + let rules = internationalBase 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 capture backward, so it will + -- continue capture as a man if it can. + 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 + 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, + cDst = freeAddr, + cPromote = isLastHorizontal side freeAddr && + not (gCanCaptureFrom rules next) + }] + else [] + _ -> [] + diff --git a/src/Rules/Russian.hs b/src/Rules/Russian.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Russian.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rules.Russian ( + Russian, russian, russianBase + ) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic + +-- import Debug.Trace + +newtype Russian = Russian GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Russian where + show = rulesName + +instance GameRules Russian where + initBoard rnd _ = board8 rnd + + boardSize _ = (8, 8) + + boardNotation _ = chessNotation + + dfltEvaluator r = SomeEval $ defaultEvaluator r + + parseNotation _ = parseChessNotation + + rulesName _ = "russian" + + possibleMoves (Russian rules) side board = gPossibleMoves rules side board + mobilityScore (Russian rules) side board = gMobilityScore rules side board + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "25" + +russianBase :: GenericRules -> GenericRules +russianBase = + let rules this = abstractRules this { + gManCaptures = manCaptures this + } + in rules + +russian :: Russian +russian = Russian $ + let rules = russianBase rules + in rules + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let captures = gPieceCaptures1 rules ct + -- when last horizontal reached, pass promoted piece to + -- next moves check; so it will continue capture as a king + -- if it can + nextMoves pm = genericNextMoves rules ct True pm + in concat $ flip map captures $ \capture -> + let [move1] = translateCapture ctPiece capture + moves2 = nextMoves move1 + in if null moves2 + then [move1] + else [catPMoves move1 move2 | move2 <- moves2] + diff --git a/src/Rules/Simple.hs b/src/Rules/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Simple.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rules.Simple (Simple, simple) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.BoardMap +import Core.Evaluator +import qualified Rules.Russian as Russian +import Rules.Generic + +newtype Simple = Simple GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Simple where + show = rulesName + +instance GameRules Simple where + initBoard rnd _ = initBoard rnd Russian.russian + boardSize _ = boardSize Russian.russian + + boardNotation _ = boardNotation Russian.russian + + parseNotation _ = parseNotation Russian.russian + + dfltEvaluator r = SomeEval $ defaultEvaluator r + + rulesName _ = "simple" + + updateRules r _ = r + + getGameResult = genericGameResult + + possibleMoves (Simple rules) side board = gPossibleMoves rules side board + mobilityScore (Simple rules) side board = gMobilityScore rules side board + + pdnId _ = "43" + +simple :: Simple +simple = Simple $ + let rules = (Russian.russianBase rules) { + gManSimpleMoves = manSimpleMoves rules, + gManCaptures = manCaptures rules, + gManCaptures1 = manCaptures1 rules + } + in rules + +manSimpleMoves :: GenericRules -> Side -> Board -> Address -> [PossibleMove] +manSimpleMoves rules side board src = + concatMap check (gManSimpleMoveDirections rules) + where + piece = Piece Man side + check dir = + case myNeighbour rules side dir src of + Nothing -> [] + Just dst -> if isFree dst board + then [PossibleMove { + pmBegin = src, + pmEnd = dst, + pmVictims = [], + pmMove = Move src [Step dir False False], + pmPromote = False, + pmResult = [Take src, Put dst piece] + }] + else [] + +manCaptures :: GenericRules -> CaptureState -> [PossibleMove] +manCaptures rules ct@(CaptureState {..}) = + let captures = gManCaptures1 rules ct + 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 neighbour (myDirection 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 neighbour (myDirection rules side dir) victimAddr of + Nothing -> [] + Just freeAddr -> + if isFree freeAddr ctBoard + then [Capture { + cSrc = a, + cDirection = dir, + cInitSteps = 0, + cVictim = victimAddr, + cFreeSteps = 1, + cDst = freeAddr, + cPromote = False + }] + else [] + _ -> [] + diff --git a/src/Rules/Spancirety.hs b/src/Rules/Spancirety.hs new file mode 100644 --- /dev/null +++ b/src/Rules/Spancirety.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Rules.Spancirety (Spancirety, spancirety) where + +import Data.Typeable + +import Core.Types +import Core.Board +import Core.Evaluator +import Rules.Generic +import Rules.Russian + +newtype Spancirety = Spancirety GenericRules + deriving (Typeable, HasBoardOrientation) + +instance Show Spancirety where + show = rulesName + +instance GameRules Spancirety where + initBoard rnd r = + let board = buildBoard rnd (boardOrientation r) (8, 10) + labels1 = ["a1", "c1", "e1", "g1", "i1", + "b2", "d2", "f2", "h2", "j2", + "a3", "c3", "e3", "g3", "i3"] + labels2 = ["b8", "d8", "f8", "h8", "j8", + "a7", "c7", "e7", "g7", "i7", + "b6", "d6", "f6", "h6", "j6"] + in setManyPieces' labels1 (Piece Man First) $ setManyPieces' labels2 (Piece Man Second) board + + boardSize _ = (8, 10) + + boardNotation _ = boardNotation russian + + dfltEvaluator r = SomeEval $ defaultEvaluator r + + parseNotation _ = parseNotation russian + + rulesName _ = "spancirety" + + possibleMoves _ = possibleMoves russian + mobilityScore _ = mobilityScore russian + + updateRules r _ = r + + getGameResult = genericGameResult + + pdnId _ = "41" + +spancirety :: Spancirety +spancirety = Spancirety $ + let rules = russianBase rules + in rules +