packages feed

hcheckers (empty) → 0.1.0.0

raw patch · 38 files changed

+7841/−0 lines, 38 filesdep +aesondep +arraydep +basesetup-changed

Dependencies added: aeson, array, base, 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

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for hcheckers++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hcheckers.cabal view
@@ -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 <https://github.com/githubuser/hcheckers#readme>+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
+ src/AI/AlphaBeta.hs view
@@ -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+
+ src/AI/AlphaBeta/Cache.hs view
@@ -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+
+ src/AI/AlphaBeta/Persistent.hs view
@@ -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+    +
+ src/AI/AlphaBeta/Types.hs view
@@ -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+
+ src/Core/Board.hs view
@@ -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)+
+ src/Core/BoardMap.hs view
@@ -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)+
+ src/Core/Checkers.hs view
@@ -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+
+ src/Core/CmdLine.hs view
@@ -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" )+
+ src/Core/Config.hs view
@@ -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'+
+ src/Core/Evaluator.hs view
@@ -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)+--
+ src/Core/Game.hs view
@@ -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}+
+ src/Core/Json.hs view
@@ -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+
+ src/Core/Logging.hs view
@@ -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+
+ src/Core/Monitoring.hs view
@@ -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+
+ src/Core/Parallel.hs view
@@ -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+
+ src/Core/Rest.hs view
@@ -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)+
+ src/Core/Supervisor.hs view
@@ -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+
+ src/Core/Types.hs view
@@ -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 "<Game: %s, 1: %s, 2: %s>"+                  (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+
+ src/Formats/Compact.hs view
@@ -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+
+ src/Formats/Fen.hs view
@@ -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+
+ src/Formats/Pdn.hs view
@@ -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) "<PDN>" 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)+
+ src/Formats/Types.hs view
@@ -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)+
+ src/Learn.hs view
@@ -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 ()+
+ src/Main.hs view
@@ -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+-- +--
+ src/Rules/Brazilian.hs view
@@ -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+
+ src/Rules/Canadian.hs view
@@ -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+
+ src/Rules/Diagonal.hs view
@@ -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+
+ src/Rules/English.hs view
@@ -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]+
+ src/Rules/Generic.hs view
@@ -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+
+ src/Rules/International.hs view
@@ -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 []+        _ -> []+
+ src/Rules/Russian.hs view
@@ -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]+
+ src/Rules/Simple.hs view
@@ -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 []+        _ -> []+
+ src/Rules/Spancirety.hs view
@@ -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+