packages feed

hcheckers 0.1.0.1 → 0.1.0.2

raw patch · 38 files changed

+1114/−1335 lines, 38 filesdep +Globdep +list-tdep +modern-uri

Dependencies added: Glob, list-t, modern-uri, req

Files

hcheckers.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 635560919d6a9de9e4c5b6a6b7f636cc443c21aa7be4d1d72d363288b4404426+-- hash: b7d691d6b82b6e15d986f5c2f31becaaeb09f9c1ea620d4a27ee842c5067f771  name:           hcheckers-version:        0.1.0.1+version:        0.1.0.2 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@@ -52,7 +52,6 @@       Core.Logging       Core.Monitoring       Core.Parallel-      Core.Rest       Core.Supervisor       Core.Types       Formats.Compact@@ -60,6 +59,9 @@       Formats.Pdn       Formats.Types       Learn+      Rest.Battle+      Rest.Common+      Rest.Game       Rules.Armenian       Rules.Brazilian       Rules.Canadian@@ -77,7 +79,8 @@       src   ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -fwarn-unused-imports   build-depends:-      aeson+      Glob+    , aeson     , array     , base >=4.7 && <5     , binary@@ -99,8 +102,10 @@     , heavy-logger     , hsyslog     , http-types+    , list-t     , megaparsec     , microlens+    , modern-uri     , monad-metrics     , mtl     , mwc-random@@ -110,6 +115,7 @@     , random     , random-access-file     , random-shuffle+    , req     , scotty     , stm     , stm-containers
src/AI.hs view
@@ -8,15 +8,11 @@  module AI where -import Data.Maybe import Data.Default import Data.Aeson  import Core.Types-import Core.Board-import Core.Logging-import Core.Supervisor-import Core.Evaluator+import Core.Supervisor () -- import instances only import AI.AlphaBeta.Types  loadAi :: (GameRules rules) => String -> rules -> FilePath -> IO (AlphaBeta rules (EvaluatorForRules rules))@@ -28,4 +24,10 @@       let rules' = SomeRules rules           ai = AlphaBeta def rules (dfltEvaluator rules)       return $ updateAi ai value++parseAi :: (GameRules rules) => rules -> Value -> AlphaBeta rules (EvaluatorForRules rules)+parseAi rules json =+      let rules' = SomeRules rules+          ai = AlphaBeta def rules (dfltEvaluator rules)+      in  updateAi ai json
src/AI/AlphaBeta.hs view
@@ -34,20 +34,14 @@  import Core.Types import Core.Board-import Core.BoardMap (labelSetMember)+import Core.BoardMap import Core.Game import Core.Parallel import Core.Logging import qualified Core.Monitoring as Monitoring import AI.AlphaBeta.Types import AI.AlphaBeta.Cache--chunksOf :: Int -> [a] -> [[a]]-chunksOf n list-  | length list <= n = [list]-  | otherwise =-      let (first, other) = splitAt n list-      in  first : chunksOf n other+import AI.AlphaBeta.Persistent  concatE :: [Int] -> [Either e [a]] -> [Either e a] concatE _ [] = []@@ -87,7 +81,7 @@         Object evalV = toJSON eval     in  Object $ H.union paramsV evalV -instance (GameRules rules, Evaluator eval) => GameAi (AlphaBeta rules eval) where+instance (GameRules rules, VectorEvaluator eval, ToJSON eval) => GameAi (AlphaBeta rules eval) where    type AiStorage (AlphaBeta rules eval) = AICacheHandle rules eval @@ -95,8 +89,8 @@     cache <- loadAiCache scoreMoveGroup ai     return cache -  saveAiStorage (AlphaBeta params rules _) cache = do-      -- saveAiCache rules params cache+  saveAiStorage (AlphaBeta params rules _) handle = do+      saveAiData rules (aichData handle)       return ()    resetAiStorage ai cache = do@@ -114,8 +108,8 @@    aiName _ = "default" -instance (GameRules rules, VectorEvaluator eval) => VectorAi (AlphaBeta rules eval) where-  type VectorAiSupport (AlphaBeta rules eval) r = (VectorEvaluatorSupport eval r, rules ~ r)+instance (GameRules rules, VectorEvaluator eval, ToJSON eval) => VectorAi (AlphaBeta rules eval) where+  type VectorAiSupport (AlphaBeta rules eval) r = (rules ~ r)    aiToVector (AlphaBeta params rules eval) = aiVector V.++ evalVector     where@@ -147,7 +141,7 @@       eval = evalFromVector rules v'  -- | Calculate score of one possible move.-scoreMove :: (GameRules rules, Evaluator eval) => ScoreMoveInput rules eval -> Checkers MoveAndScore+scoreMove :: (GameRules rules, VectorEvaluator eval) => ScoreMoveInput rules eval -> Checkers MoveAndScore scoreMove (ScoreMoveInput {..}) = do      let AlphaBeta params rules eval = smiAi      score <- Monitoring.timed "ai.score.move" $ do@@ -162,7 +156,7 @@            return $ MoveAndScore smiMove score -scoreMoveGroup :: (GameRules rules, Evaluator eval) => [ScoreMoveInput rules eval] -> Checkers [MoveAndScore]+scoreMoveGroup :: (GameRules rules, VectorEvaluator eval) => [ScoreMoveInput rules eval] -> Checkers [MoveAndScore] scoreMoveGroup inputs = go worst [] inputs   where     input0 = head inputs@@ -229,24 +223,25 @@ --     return result  class Monad m => EvalMoveMonad m where-  checkPrimeVariation :: (GameRules rules, Evaluator eval) => AICacheHandle rules eval -> AlphaBetaParams -> Board -> DepthParams -> m (Maybe PerBoardData)+  checkPrimeVariation :: (GameRules rules, VectorEvaluator eval) => AICacheHandle rules eval -> eval -> AlphaBetaParams -> Board -> DepthParams -> m (Maybe PerBoardData)   getKillerMove :: Int -> m (Maybe MoveAndScore)  instance EvalMoveMonad Checkers where-  checkPrimeVariation var params board dp = do-      lookupAiCache params board dp var+  checkPrimeVariation var eval params board dp = do+      lookupAiCache eval params board dp var    getKillerMove _ = return Nothing  -- ScoreM instance instance EvalMoveMonad (StateT (ScoreState rules eval) Checkers) where-  checkPrimeVariation var params board dp = do-      lift $ lookupAiCache params board dp var+  checkPrimeVariation var eval params board dp = do+      lift $ lookupAiCache eval params board dp var    getKillerMove = getGoodMove   -evalMove :: (EvalMoveMonad m, GameRules rules, Evaluator eval)-        => AlphaBetaParams+evalMove :: (EvalMoveMonad m, GameRules rules, VectorEvaluator eval)+        => eval+        -> AlphaBetaParams         -> AICacheHandle rules eval         -> Side         -> DepthParams@@ -254,8 +249,8 @@         -> Maybe PossibleMove         -> LabelSet         -> PossibleMove -> m Int-evalMove params var side dp board mbPrevMove attacked move = do-  prime <- checkPrimeVariation var params board dp+evalMove eval params var side dp board mbPrevMove attacked move = do+  prime <- checkPrimeVariation var eval params board dp   let victimFields = pmVictims move       -- nVictims = sum $ map victimWeight victimFields       promotion = if isPromotion move then 1 else 0@@ -304,8 +299,9 @@           signedScore = if maximize then score else -score       return $ fromIntegral signedScore -sortMoves :: (EvalMoveMonad m, GameRules rules, Evaluator eval)-          => AlphaBetaParams+sortMoves :: (EvalMoveMonad m, GameRules rules, VectorEvaluator eval)+          => eval+          -> AlphaBetaParams           -> AICacheHandle rules eval           -> Side           -> DepthParams@@ -313,12 +309,12 @@           -> Maybe PossibleMove           -> [PossibleMove]           -> m [PossibleMove]-sortMoves params var side dp board mbPrevMove moves = do+sortMoves eval params var side dp board mbPrevMove moves = do --   if length moves >= 4 --     then do       let rules = aichRules var           attacked = boardAttacked side board-      interest <- mapM (evalMove params var side dp board mbPrevMove attacked) moves+      interest <- mapM (evalMove eval params var side dp board mbPrevMove attacked) moves       if any (/= 0) interest         then return $ map fst $ sortOn (negate . snd) $ zip moves interest         else return moves@@ -779,7 +775,7 @@           return (goodMoves, maxScore)  -- | Calculate score of the board-doScore :: (GameRules rules, Evaluator eval)+doScore :: (GameRules rules, VectorEvaluator eval)         => rules         -> eval         -> AICacheHandle rules eval@@ -793,7 +789,7 @@         -> Checkers Score doScore rules eval var params gameId side dp board alpha beta = do     initState <- mkInitState-    out <- evalStateT (cachedScoreAB var params input) initState+    out <- evalStateT (cachedScoreAB var eval params input) initState     return $ soScore out   where     input = ScoreInput side dp alpha beta board Nothing @@ -812,19 +808,20 @@  -- | 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)+cachedScoreAB :: forall rules eval. (GameRules rules, VectorEvaluator eval)               => AICacheHandle rules eval+              -> eval               -> AlphaBetaParams               -> ScoreInput               -> ScoreM rules eval ScoreOutput-cachedScoreAB var params input = do+cachedScoreAB var eval 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+  mbItem <- lift $ lookupAiCache eval params board dp var   mbCached <- case mbItem of                 Just item -> do                   let cachedScore = itemScore item@@ -844,7 +841,7 @@   case mbCached of     Just out -> return out     Nothing -> do-      out <- Monitoring.timed "ai.score.board" $ scoreAB var params input+      out <- Monitoring.timed "ai.score.board" $ scoreAB var eval params input       let score = soScore out           bound             | score <= alpha = Alpha@@ -856,8 +853,8 @@           item = PerBoardData (dpLast dp) score bound           item' = PerBoardData (dpLast dp) (negate score) bound       when (bound == Exact && soQuiescene out && not (dpStaticMode dp)) $ do-          lift $ putAiCache params board item var-          lift $ putAiCache params (flipBoard board) item' var+          lift $ putAiCache eval params board item var+          lift $ putAiCache eval params (flipBoard board) item' var       return out  -- | Check if target depth is reached@@ -927,12 +924,13 @@  -- | Calculate score for the board. -- This implements the alpha-beta section algorithm itself.-scoreAB :: forall rules eval. (GameRules rules, Evaluator eval)+scoreAB :: forall rules eval. (GameRules rules, VectorEvaluator eval)         => AICacheHandle rules eval+        -> eval         -> AlphaBetaParams         -> ScoreInput         -> ScoreM rules eval ScoreOutput-scoreAB var params input+scoreAB var eval params input   | alpha == beta = do       $verbose "Alpha == Beta == {}, return it" (Single $ show alpha)       quiescene <- checkQuiescene@@ -985,7 +983,7 @@                   rules <- gets ssRules                   dp' <- updateDepth params moves dp                   let prevMove = siPrevMove input-                  moves' <- sortMoves params var side dp board prevMove moves+                  moves' <- sortMoves eval params var side dp board prevMove moves --                   let depths = correspondingDepths (length moves') score0 quiescene dp'                   let depths = repeat dp'                   out <- iterateMoves $ zip3 [1..] moves' depths@@ -1120,9 +1118,9 @@         let inputs = [input {siAlpha = alpha, siBeta = beta} | (alpha, beta) <- intervals]         go inputs       where-        go [input] = cachedScoreAB var params input+        go [input] = cachedScoreAB var eval params input         go (input : inputs) = do-          out <- cachedScoreAB var params input+          out <- cachedScoreAB var eval params input           let score = soScore out           if maximize && score >= beta || minimize && score <= alpha             then go inputs@@ -1156,7 +1154,7 @@                     , siBoard = markAttacked rules $ applyMoveActions (pmResult move) board                     , siDepth = dp                   }-      out <- cachedScoreAB var params input'+      out <- cachedScoreAB var eval params input'       let score = soScore out       $verbose "{}| score for side {}: {}" (indent, show side, show score)
src/AI/AlphaBeta/Cache.hs view
@@ -13,24 +13,13 @@     resetAiCache   ) where -import Control.Monad+import Control.Concurrent 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 StmContainers.Map as SM 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 @@ -42,6 +31,28 @@ import AI.AlphaBeta.Types import AI.AlphaBeta.Persistent +putAiData :: VectorEvaluator eval => AIData -> eval -> Board -> PerBoardData -> Checkers ()+putAiData aiData eval board item =+  liftIO $ atomically $ do+    perEval <- readTVar aiData+    let vec = evalToVector eval+    forEval <- case M.lookup vec perEval of+                 Just map -> return map+                 Nothing -> do+                    map <- SM.new+                    writeTVar aiData $ M.insert vec map perEval+                    return map+    putBoardMapWith' forEval (<>) board item++lookupAiData :: VectorEvaluator eval => AIData -> eval -> Board -> Checkers (Maybe PerBoardData)+lookupAiData aiData eval board =+  liftIO $ atomically $ do+    perEval <- readTVar aiData+    let vec = evalToVector eval+    case M.lookup vec perEval of+      Nothing -> return Nothing+      Just forEval -> lookupBoardMap' forEval board+ -- | Prepare AI storage instance. -- This also contains Processor instance with several threads. loadAiCache :: (GameRules rules, Evaluator eval)@@ -52,58 +63,9 @@   let getKey inputs = map smiIndex inputs   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)+  cache <- loadAiData rules    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@@ -115,40 +77,20 @@       aichProcessor = processor,       aichPossibleMoves = moves,       aichLastMoveScoreShift = scoreShift,-      aichWriteQueue = writeQueue,-      aichCleanupQueue = cleanupQueue,-      aichCurrentCounts = counts,-      aichIndexFile = indexHandle,-      aichDataFile = dataHandle+      aichCurrentCounts = counts     }-  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+  save <- asks (aiStoreCache . gcAiConfig . csConfig)+  when save $+      forkCheckers $ aiStorageSaver rules cache -    liftIO $ threadDelay $ 30 * 1000 * 1000+  return handle -cacheCleaner :: AICacheHandle rules eval -> Checkers ()-cacheCleaner handle = forever $ do-    liftIO $ threadDelay $ 30 * 1000 * 1000+aiStorageSaver :: GameRules rules => rules -> AIData -> Checkers ()+aiStorageSaver rules aiData = do+      saveAiData rules aiData+      liftIO $ threadDelay $ 10 * 1000 * 1000+      aiStorageSaver rules aiData  normalize :: BoardSize -> (BoardCounts,BoardKey,Side) -> (BoardCounts,BoardKey,Side) normalize bsize (bc,bk,side) =@@ -160,41 +102,23 @@  -- | 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+lookupAiCache :: (GameRules rules, VectorEvaluator eval) => eval -> AlphaBetaParams -> Board -> DepthParams -> AICacheHandle rules eval -> Checkers (Maybe PerBoardData)+lookupAiCache eval 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-            putAiCache params board file handle-            return $ Just file-+        Monitoring.increment "cache.miss"+        return Nothing   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 +      mbItem <- lookupAiData cache eval board        case mbItem of         Nothing -> return Nothing         Just item@(PerBoardData {..}) ->@@ -202,48 +126,24 @@             then return $ Just item             else return Nothing -    lookupFile' :: Board -> DepthParams -> Checkers (Maybe PerBoardData)-    lookupFile' board depth = do-      load <- asks (aiLoadCache . gcAiConfig . csConfig)-      if load-        then do-          let bc = calcBoardCounts board-          let total = bcFirstMen bc + bcSecondMen bc + bcFirstKings bc + bcSecondKings bc-          cfg <- asks (gcAiConfig . csConfig)-          if {-total <= aiUseCacheMaxPieces cfg &&-} dpTarget depth >= aiUseCacheMaxDepth cfg-            then runStorage handle (lookupFile board depth)-                  `catch`-                      \(e :: SomeException) -> do-                          $reportError "Exception: lookupFile: {}" (Single $ show e)-                          return Nothing-            else return Nothing-        else return Nothing- -- | Put an item to the cache. -- 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+putAiCache :: (GameRules rules, VectorEvaluator eval) => eval -> AlphaBetaParams -> Board -> StorageValue -> AICacheHandle rules eval -> Checkers ()+putAiCache eval 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 RealtimeCoarse     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+    putAiData cache eval board newItem  resetAiCache :: AICacheHandle rules eval -> Checkers ()-resetAiCache handle= do+resetAiCache handle = do   let cache = aichData handle-  liftIO $ resetBoardMap cache+  liftIO $ atomically $+    writeTVar cache M.empty
src/AI/AlphaBeta/Persistent.hs view
@@ -9,24 +9,19 @@ {-# LANGUAGE TemplateHaskell #-}  module AI.AlphaBeta.Persistent-  (lookupFile,-   putRecordFile,-   putStatsFile,-   putWriteQueue,-   checkWriteQueue,-   initFile,-   -- checkDataFile',-   loadIndexIO-  ) where+  where  import Control.Monad import Control.Monad.State+import Control.Monad.Reader+import qualified ListT import Control.Monad.Catch (catch, SomeException) import Control.Concurrent.STM-import qualified Data.HashPSQ as PQ+import qualified StmContainers.Map as SM import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M+import qualified Data.Vector as V import Data.Maybe import Data.Word import Data.Text.Format.Heavy@@ -38,12 +33,16 @@ 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 System.Environment+import System.FilePath+import System.FilePath.Glob+import System.Directory  import Core.Types import Core.Board+import Core.BoardMap import qualified Core.Monitoring as Monitoring import AI.AlphaBeta.Types @@ -83,484 +82,63 @@     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)+getCachePath :: GameRules rules => rules -> Checkers FilePath+getCachePath rules = liftIO $ do+  home <- getEnv "HOME"+  let directory = home </> ".cache" </> "hcheckers" </> rulesName rules+  createDirectoryIfMissing True directory+  return directory --- 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)+newAiData :: Checkers AIData+newAiData = liftIO $ atomically $ newTVar $ M.empty -data ParserState = ParserState {-    psIndex :: File.MMaped-  , psUnfinished :: M.Map IndexBlockNumber BL.ByteString-  , psFinished :: M.Map BL.ByteString DataBlockNumber-  }+loadAiData' :: FilePath -> Checkers (V.Vector Double, M.Map BoardHash PerBoardData)+loadAiData' path = do+  sHandle <- askSupervisor+  sState <- liftIO $ atomically $ readTVar sHandle+  bytes <- liftIO $ B.readFile path+  (vec, pairs) <- liftIO $ decodeIO bytes :: Checkers (V.Vector Double, [(BoardHash, PerBoardData)])+  $info "Load AI cache: {} - {} boards" (path, length pairs)+  return (vec, M.fromList pairs) -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)+loadAiData :: GameRules rules => rules -> Checkers AIData+loadAiData rules = do+  cachePath <- getCachePath rules+  aiData <- newAiData+  load <- asks (aiLoadCache . gcAiConfig . csConfig)+  if load+    then do+      paths <- liftIO $ glob (cachePath </> "*.data")+      sHandle <- askSupervisor+      sState <- liftIO $ atomically $ readTVar sHandle+      perEvalPairs <- forM paths $ \path -> do+        bytes <- liftIO $ B.readFile path+        (vec, pairs) <- liftIO $ decodeIO bytes :: Checkers (V.Vector Double, [(BoardHash, PerBoardData)])+        $info "Load AI cache: {} - {} boards" (path, length pairs)+        return (vec, pairs) -    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'+      let vecs = map fst perEvalPairs+          cachesForEval = map snd perEvalPairs+      maps <- forM cachesForEval $ \pairs -> liftIO $ atomically $ do+                bmap <- SM.new+                forM pairs $ \(bHash, item) -> do+                  SM.insert item bHash bmap+                return bmap+      liftIO $ atomically $ do+        aiData <- newTVar $ M.fromList $ zip vecs maps+        return aiData+    else+      return aiData --- 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-    +saveAiData :: GameRules rules => rules -> AIData -> Checkers ()+saveAiData rules var = do+  cachePath <- getCachePath rules+  perEvalMap <- liftIO $ atomically $ readTVar var+  forM_ (zip [1..] $ M.assocs perEvalMap) $ \(i, (vec, mapForEval)) -> do+    let path = cachePath </> show i ++ ".data"+        getPairs = ListT.toList $ SM.listT mapForEval+    boardsData <- liftIO $ atomically getPairs+    let fileData = (vec, boardsData) :: (V.Vector Double, [(BoardHash, PerBoardData)])+    liftIO $ B.writeFile path $ Data.Store.encode fileData+    $info "Save AI cache: {} - {} boards" (path, length boardsData)
src/AI/AlphaBeta/Types.hs view
@@ -39,6 +39,7 @@ import Control.Concurrent.STM import qualified Data.HashPSQ as PQ import qualified Data.Map as M+import qualified Data.Vector as V import Data.Word import Data.Binary import Data.Store@@ -59,6 +60,8 @@ data AlphaBeta rules eval = AlphaBeta AlphaBetaParams rules eval   deriving (Eq, Ord, Show, Typeable) +type AlphaBetaR rules = AlphaBeta rules (EvaluatorForRules rules)+ data AlphaBetaParams = AlphaBetaParams {     abDepth :: Depth   , abStartDepth :: Maybe Depth@@ -151,7 +154,7 @@ instance Binary PerBoardData instance Store PerBoardData -type AIData = TBoardMap PerBoardData+type AIData = TVar (M.Map (V.Vector Double) (TBoardMap PerBoardData))  type StorageKey = (DepthParams, BoardKey) @@ -196,11 +199,7 @@   , aichProcessor ::  Processor [Int] [ScoreMoveInput rules eval] [MoveAndScore]   , 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)@@ -221,8 +220,6 @@   , ssMetrics :: Metrics.Metrics   , ssMetricsEnabled :: Bool   , ssBoardSize :: BoardSize-  , ssIndex :: Maybe FHandle-  , ssData :: Maybe FHandle   }  -- | Storage monad.@@ -319,11 +316,9 @@ 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+  let initState = StorageState lts metrics metricsEnabled bsize   liftIO $ evalStateT actions initState
src/Battle.hs view
@@ -7,14 +7,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}  module Battle where  import Control.Monad import Control.Monad.IO.Class-import Data.List (intercalate, sortOn)-import Data.Aeson+import Control.Concurrent+import Data.List (sortOn)+import Data.Aeson hiding (json) import Data.Aeson.Types+import Data.Yaml+import Data.Maybe import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.HashMap.Strict as H@@ -23,14 +27,48 @@ import Text.Printf import System.Random import System.Random.Shuffle+import Web.Scotty.Trans+import Network.HTTP.Req+import Text.URI (mkURI) -import Core.Types+import Core.Types hiding (timed) import Core.Board+import Core.Json () -- instances only import Core.Supervisor+import Core.Parallel+import Core.Monitoring+import Rest.Common import AI.AlphaBeta.Types+import AI  type AB rules = AlphaBeta rules (EvaluatorForRules rules) +type BattleRunner = SomeRules -> (Int,SomeAi) -> (Int,SomeAi) -> FilePath -> Checkers GameResult++type MatchRunner = Int -> SomeRules -> [(Int,Int)] -> [SomeAi] -> Checkers [(Int, Int, Int)]++data GeneticSettings = GeneticSettings {+    gsRules :: String+  , gsUrls :: [T.Text]+  , gsGenerations :: Int+  , gsGames :: Int+  , gsGenerationSize :: Int+  , gsPrevGeneration :: Int+  , gsBestCount :: Int+  , gsInitFiles :: [FilePath]+  } deriving (Show)++instance FromJSON GeneticSettings where+  parseJSON = withObject "GeneticSettings" $ \v -> GeneticSettings+    <$> v .: "rules"+    <*> v .: "urls"+    <*> v .: "generations"+    <*> v .: "games_per_match"+    <*> v .: "generation_size"+    <*> v .: "keep_previous_generation"+    <*> v .: "select_best"+    <*> v .: "init_files"+ (<+>) :: Num a => V.Vector a -> V.Vector a -> V.Vector a v1 <+> v2 = V.zipWith (+) v1 v2 @@ -44,35 +82,89 @@ -- norm v = sqrt $ V.sum $ V.map (\x -> x*x) v norm v = (V.sum $ V.map abs v) / fromIntegral (V.length v) -cross :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules) => rules -> (AB rules, AB rules) -> Checkers (AB rules)+mix :: V.Vector a -> V.Vector a -> IO (V.Vector a)+mix v1 v2 = do+  t <- randomRIO (0.0, 1.0) :: IO Double+  V.forM (V.zip v1 v2) $ \(x1, x2) -> do+    p <- randomRIO (0.0, 1.0)+    if p < t+      then return x1+      else return x2++cross :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules)) => rules -> (AB rules, AB rules) -> Checkers (AB rules) cross rules (ai1, ai2) = do   let v1 = aiToVector ai1       v2 = aiToVector ai2-  t <- liftIO $ randomRIO (0.0, 1.0)-  let mid = scale (1.0 - t) v1 <+> scale t v2+  mid <- liftIO $ mix v1 v2   p <- liftIO $ randomRIO (0.0, 1.0) :: Checkers Double-  v3 <- if p < 0.9+  v3 <- if p < 0.7           then return mid           else do-            let delta = {-0.5 *-} norm (v1 <-> v2)-            dv <- liftIO $ replicateM (V.length v1) $ randomRIO (-delta, delta)-            -- liftIO $ print delta-            return $ mid <+> V.fromList dv+            let delta = 0.05+            liftIO $ V.forM mid $ \v -> do+                             let a = abs v+                             randomRIO (v - delta*a, v + delta*a)   let v3' = V.take 3 v1 V.++ V.drop 3 v3   return $ aiFromVector rules v3' -breed :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules) => rules -> Int -> [AB rules] -> Checkers [AB rules]-breed rules nNew ais = do+breed :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules)) => rules -> Int -> Int -> [AB rules] -> Checkers [AB rules]+breed rules nNew nOld ais = do   let n = length ais       idxPairs = [(i,j) | i <- [0..n-1], j <- [i+1 .. n-1]]+      nNew' = nNew - nOld   idxPairs' <- liftIO $ shuffleM idxPairs   let ais' = [(ais !! i, ais !! j) | (i,j) <- idxPairs']-  mapM (cross rules) $ take nNew $ cycle ais'+  new <- mapM (cross rules) $ take nNew' $ cycle ais'+  let old = take nOld ais+  return $ old ++ new -runGenetics :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules), VectorEvaluatorSupport (EvaluatorForRules rules) rules)-            => rules -> Int -> Int -> Int -> [AB rules] -> Checkers [AB rules]-runGenetics rules nGenerations generationSize nBest ais = do-      generation0 <- breed rules generationSize ais+runGeneticsJ :: FilePath -> Checkers [SomeAi]+runGeneticsJ cfgPath = do+  cfg <- liftIO $ decodeYamlFile cfgPath+  matchRunner <- if null (gsUrls cfg)+                    then return $ dumbMatchRunner runBattleLocal+                    else do+                         let process url (gameNr, rules, (i,ai1), (j,ai2), path) = do+                                liftIO $ printf "Battle AI#%d vs AI#%d on %s\n" i j (T.unpack url)+                                timed ("battle.duration." <> url) $ do+                                  increment ("battle.count." <> url)+                                  runBattleRemote url rules (i,ai1) (j,ai2) path+                         processor <- runProcessor' (gsUrls cfg) getJobKey process+                         return $ mkRemoteRunner processor+  withRules (gsRules cfg) $ \rules -> do+      ais <- forM (gsInitFiles cfg) $ \path -> liftIO $ loadAi "default" rules path+      rs <- runGenetics matchRunner rules (gsGenerations cfg) (gsGenerationSize cfg) (gsPrevGeneration cfg) (gsBestCount cfg) (gsGames cfg) ais+      return $ map SomeAi rs++type BattleProcessor = Processor (Int,Int,Int) (Int, SomeRules, (Int,SomeAi), (Int,SomeAi), FilePath) GameResult++getJobKey (gameNr, rules, (i,ai1), (j,ai2), _) = (gameNr, i,j)++mkRemoteRunner :: BattleProcessor -> MatchRunner+mkRemoteRunner processor nGames rules idxPairs ais = do+  let inputs = [(gameNr, rules, (i, ais !! i), (j, ais !! j), "battle.pdn") | (i,j) <- idxPairs, gameNr <- [1..nGames]]+      keys = map getJobKey inputs+  gameResults <- process processor inputs+  let list = [((i,j), result) | (result, (gameNr, i,j)) <- zip gameResults keys]+      byPair = foldr (\(ij, result) m -> M.insertWith (++) ij [result] m) M.empty list+      groupedResults = [fromJust $ M.lookup ij byPair | ij <- idxPairs]+      totals = [calcMatchStats results | results <- groupedResults]+  forM_ (zip idxPairs totals) $ \((i,j), (first, second, draw)) -> do+    liftIO $ printf "Match: AI#%d: %d, AI#%d: %d, Draws(?): %d\n" i first j second draw+  return totals++runGenetics :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules))+            => MatchRunner+            -> rules+            -> Int           -- ^ Number of generations+            -> Int           -- ^ Generation size+            -> Int           -- ^ number of items to keep from previous generation+            -> Int           -- ^ Number of best items to select for breeding+            -> Int           -- ^ number of games in each match+            -> [AB rules]+            -> Checkers [AB rules]+runGenetics runMatches rules nGenerations generationSize nOld nBest nGames ais = do+      generation0 <- breed rules generationSize nOld ais       run 1 generation0   where       run n generation = do@@ -81,30 +173,49 @@         if n == nGenerations           then return best           else do-              generation' <- breed rules generationSize best+              generation' <- breed rules generationSize nOld best               run (n+1) generation' -      nGames = 5       nMatches = generationSize        selectBest generation = do-        results <- runTournament rules generation nMatches nGames+        results <- runTournament runMatches rules generation nMatches nGames         let best = take nBest $ sortOn (negate . snd) $ M.assocs results             idxs = map fst best         return [generation !! i | i <- idxs] -runTournament :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules)) => rules -> [AlphaBeta rules (EvaluatorForRules rules)] -> Int -> Int -> Checkers (M.Map Int Int)-runTournament rules ais nMatches nGames = do+mapP :: Int -> (input -> Checkers output) -> [input] -> Checkers [output]+mapP nThreads fn inputs = do+    let groups = splitBy nThreads inputs+    vars <- replicateM nThreads $ liftIO $ newEmptyMVar+    forM_ (zip groups vars) $ \(group, var) -> do+      forkCheckers $ do+        rs <- forM group fn+        liftIO $ putMVar var rs+    rsGroups <- forM vars $ \var -> liftIO $ takeMVar var+    return $ concat rsGroups++forMP :: Int -> [input] -> (input -> Checkers output) -> Checkers [output]+forMP nThreads inputs fn = mapP nThreads fn inputs++dumbMatchRunner :: BattleRunner -> MatchRunner+dumbMatchRunner runBattle nGames rules idxPairs ais =+  forMP 4 idxPairs $ \(i,j) ->+      runMatch runBattle rules (i, ais !! i) (j, ais !! j) nGames++runTournament :: (GameRules rules, VectorEvaluator (EvaluatorForRules rules))+    => MatchRunner -> rules -> [AlphaBeta rules (EvaluatorForRules rules)] -> Int -> Int -> Checkers (M.Map Int Int)+runTournament runMatches rules ais nMatches nGames = do   forM_ ais $ \ai ->     liftIO $ print $ aiToVector ai   let n = length ais       idxPairs = [(i,j) | i <- [0..n-1], j <- [i+1 .. n-1]]       ais' = map SomeAi ais   idxPairs' <- liftIO $ shuffleM idxPairs-  stats <- forM (take nMatches idxPairs') $ \(i,j) ->-             runMatch (SomeRules rules) (ais' !! i) (ais' !! j) nGames-  forM_ (zip idxPairs' stats) $ \((i,j),(first,second,draw)) -> do-      liftIO $ printf "AI#%d vs AI#%d: First %d, Second %d, Draw %d\n" i j first second draw+  stats <- runMatches nGames (SomeRules rules) (take nMatches idxPairs') ais'+  liftIO $ putStrLn "Tournament results:"+  -- forM_ (zip idxPairs' stats) $ \((i,j),(first,second,draw)) -> do+  --     liftIO $ printf "AI#%d vs AI#%d: First %d, Second %d, Draw %d\n" i j first second draw    let results1 = [(i, first - second) | ((i,j), (first,second,draw)) <- zip idxPairs' stats]       results2 = [(j, second - first) | ((i,j), (first,second,draw)) <- zip idxPairs' stats]@@ -117,25 +228,36 @@ --       liftIO $ putStrLn str   return results -runMatch :: SomeRules -> SomeAi -> SomeAi -> Int -> Checkers (Int, Int, Int)-runMatch rules ai1 ai2 nGames = do+runMatch :: BattleRunner -> SomeRules -> (Int, SomeAi) -> (Int, SomeAi) -> Int -> Checkers (Int, Int, Int)+runMatch runBattle rules (i,ai1) (j,ai2) nGames = do     (nFirst, nSecond, nDraw) <- go 0 (0, 0, 0)-    liftIO $ printf "First: %d, Second: %d, Draws(?): %d\n" nFirst nSecond nDraw+    liftIO $ printf "Match: AI#%d: %d, AI#%d: %d, Draws(?): %d\n" i nFirst j nSecond nDraw     return (nFirst, nSecond, nDraw)   where     go :: Int -> (Int, Int, Int) -> Checkers (Int, Int, Int)-    go i (first, second, draw)-      | i >= nGames = return (first, second, draw)+    go k (first, second, draw)+      | k >= nGames = return (first, second, draw)       | otherwise = do-          result <- runBattle rules ai1 ai2 (printf "battle_%d.pdn" i)+          result <- runBattle rules (i,ai1) (j,ai2) (printf "battle_%d.pdn" k)           let stats = case result of                         FirstWin -> (first+1, second, draw)                         SecondWin -> (first, second+1, draw)                         Draw -> (first, second, draw+1)-          go (i+1) stats+          go (k+1) stats -runBattle :: SomeRules -> SomeAi -> SomeAi -> FilePath -> Checkers GameResult-runBattle rules ai1 ai2 path = do+calcMatchStats :: [GameResult] -> (Int, Int, Int)+calcMatchStats rs = go (0, 0, 0) rs+  where+    go (first, second, draw) [] = (first, second, draw)+    go (first, second, draw) (r : rs) =+      let stats = case r of+                    FirstWin -> (first+1, second, draw)+                    SecondWin -> (first, second+1, draw)+                    Draw -> (first, second, draw+1)+      in go stats rs++runBattleLocal :: BattleRunner+runBattleLocal rules (i,ai1) (j,ai2) path = do   initAiStorage rules ai1   let firstSide = First   gameId <- newGame rules firstSide Nothing@@ -147,7 +269,7 @@   resetAiStorageG gameId Second   runGame gameId   result <- loopGame path gameId (opposite firstSide) 0-  liftIO $ print result+  liftIO $ printf "Battle AI#%d vs AI#%d: %s\n" i j (show result)   return result  hasKing :: Side -> BoardRep -> Bool@@ -159,7 +281,7 @@ loopGame :: FilePath -> GameId -> Side -> Int -> Checkers GameResult loopGame path gameId side i = do   StateRs board status side <- getState gameId-  if (i > 100) || (i > 60 && boardRepLen board <= 8 && hasKing First board && hasKing Second board)+  if (i > 200) || (i > 120 && boardRepLen board <= 8 && hasKing First board && hasKing Second board)     then do       liftIO $ putStrLn "Too long a game, probably a draw"       -- pdn <- getPdn gameId@@ -220,5 +342,46 @@     Nothing -> fail "Cannot load initial AI"     Just initValue -> forM_ [1..n] $ \i -> do                         value <- generateVariation dv initValue-                        encodeFile (printf "ai_variation_%d.json" i) value+                        Data.Aeson.encodeFile (printf "ai_variation_%d.json" i) value++decodeJsonFile :: FromJSON a => FilePath -> IO a+decodeJsonFile path = do+  r <- eitherDecodeFileStrict' path+  case r of+    Left err -> fail err+    Right x -> return x++decodeYamlFile :: FromJSON a => FilePath -> IO a+decodeYamlFile path = do+  r <- Data.Yaml.decodeFileEither path+  case r of+    Left err -> fail (show err)+    Right x -> return x++http_ :: T.Text -> (Url 'Http, Option s)+http_ text =+  case mkURI text of+    Nothing -> error $ "Can't parse URI: " ++ T.unpack text+    Just uri ->+      case useHttpURI uri of+        Nothing -> error $ "Unsupported URI: " ++ T.unpack text+        Just (url, opts) -> (url, opts)++runBattleRemote :: T.Text -> BattleRunner+runBattleRemote baseUrl (SomeRules rules) (i,SomeAi ai1) (j,SomeAi ai2) path = do+  let rq = BattleRq (rulesName rules) (toJSON ai1) (toJSON ai2)+      (url, opts) = http_ baseUrl+  rs <- liftIO $ runReq defaultHttpConfig $+          req POST (url /: "battle" /: "run") (ReqBodyJson rq) jsonResponse opts+  return (responseBody rs)++runBattleRemoteIO :: T.Text -> String -> FilePath -> FilePath -> IO GameResult+runBattleRemoteIO baseUrl rulesName aiPath1 aiPath2 = do+  ai1 <- decodeJsonFile aiPath1+  ai2 <- decodeJsonFile aiPath2+  let rq = BattleRq rulesName ai1 ai2+      (url, opts) = http_ baseUrl +  rs <- runReq defaultHttpConfig $+          req POST (url /: "battle" /: "run") (ReqBodyJson rq) jsonResponse opts+  return (responseBody rs)
src/Core/Board.hs view
@@ -342,6 +342,9 @@ isCapture :: PossibleMove -> Bool isCapture pm = not $ null $ pmVictims pm +isPromotionM :: Move -> Bool+isPromotionM move = any sPromote (moveSteps move)+ isPromotion :: PossibleMove -> Bool isPromotion = pmPromote @@ -748,11 +751,40 @@  -- | Generic implementation of @getGameResult@, which suits most rules. -- This can not, however, recognize draws.-genericGameResult :: GameRules rules => rules -> Board -> Side -> Maybe GameResult-genericGameResult rules board side+genericGameResult :: GameRules rules => rules -> GameState -> Board -> Side -> Maybe GameResult+genericGameResult rules st board side   | side == First && null (possibleMoves rules First board) = Just SecondWin   | side == Second && null (possibleMoves rules Second board) = Just FirstWin+  | detectRepeatedPosition 3 (gsHistory st) board = Just Draw+  | detectStalemate (gsHistory st) board = Just Draw   | otherwise = Nothing++detectRepeatedPosition :: Int -> [HistoryRecord] -> Board -> Bool+detectRepeatedPosition n history board =+  case history of+    [] -> False+    [_] -> False+    (record : prevRecord: history') ->+      if hrPrevBoard record == board+        then detectRepeatedPosition (n-1) history' (hrPrevBoard record)+        else False++detectStalemate :: [HistoryRecord] -> Board -> Bool+detectStalemate history board+  | totalCount board <= 3 = detectStalemate' 5 history board+  | totalCount board <= 5 = detectStalemate' 30 history board+  | totalCount board <= 7 = detectStalemate' 60 history board+  | otherwise = False+      +detectStalemate' :: Int -> [HistoryRecord] -> Board -> Bool+detectStalemate' nMoves history board =+  let counts = calcBoardCounts board+      change r = isCaptureM (hrMove r) || isPromotionM (hrMove r)+      nHalfMoves = 2*nMoves+  in  if bcFirstKings counts > 0 && bcSecondKings counts > 0+        then  length history > nHalfMoves &&+                (not $ any change $ take nHalfMoves history)+        else False  instance IsString Label where   fromString str =
src/Core/BoardMap.hs view
@@ -101,39 +101,28 @@ newTBoardMap :: IO (TBoardMap a) newTBoardMap = atomically SM.new -putBoardMap :: TBoardMap a -> Board -> a -> IO ()-putBoardMap bmap board value = atomically $ do+putBoardMap' :: TBoardMap a -> Board -> a -> STM ()+putBoardMap' bmap board value =    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+putBoardMap :: TBoardMap a -> Board -> a -> IO ()+putBoardMap bmap board value = atomically $ putBoardMap' bmap board value++putBoardMapWith' :: TBoardMap a -> (a -> a -> a) -> Board -> a -> STM ()+putBoardMapWith' bmap plus board value = 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 +putBoardMapWith :: TBoardMap a -> (a -> a -> a) -> Board -> a -> IO ()+putBoardMapWith bmap plus board value = atomically $ putBoardMapWith' bmap plus board value++lookupBoardMap' :: TBoardMap a -> Board -> STM (Maybe a)+lookupBoardMap' bmap board = SM.lookup (boardHash board) bmap+ 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+lookupBoardMap bmap board = atomically $ lookupBoardMap' bmap board  resetBoardMap :: TBoardMap a -> IO () resetBoardMap bmap = atomically $ SM.reset bmap
src/Core/CmdLine.hs view
@@ -2,12 +2,13 @@ module Core.CmdLine where  import Options.Applicative-import Data.Semigroup ((<>)) import Data.Char (toLower)  data CmdLine = CmdLine {       cmdConfigPath :: Maybe FilePath     , cmdLocal :: Maybe Bool+    , cmdBattleServer :: Maybe Bool+    , cmdMetrics :: Maybe Bool     , cmdSpecial :: Maybe String     }   deriving (Eq, Show)@@ -33,6 +34,16 @@          <> short 'L'          <> metavar "on|off"          <> help "Run server in local mode" ) )+  <*> optional (option bool+        ( long "battle"+          <> short 'B'+          <> metavar "on|off"+          <> help "Run `battle server' instead of normal game server") )+  <*> optional (option bool+        ( long "metrics"+          <> metavar "on|off"+          <> help "Enable or disable metrics monitoring. This command-line option overrides one specified in the config file.")+        )   <*> optional (strOption         ( long "special"          <> metavar "COMMAND" ) )
src/Core/Config.hs view
@@ -45,5 +45,8 @@   let config' = case cmdLocal cmd of                   Nothing -> config                   Just local -> config {gcLocal = local}-  return config'+      config'' = case cmdMetrics cmd of+                  Nothing -> config'+                  Just metrics -> config {gcEnableMetrics = metrics}+  return config''
src/Core/Evaluator.hs view
@@ -6,8 +6,6 @@ {-# LANGUAGE ConstraintKinds #-} module Core.Evaluator   ( SimpleEvaluator (..),-    SimpleEvaluatorInterface (..),-    SimpleEvaluatorSupport (..),     SimpleEvaluatorData (..),     weightForSide,     defaultEvaluator@@ -38,7 +36,7 @@   deriving (Show)  data SimpleEvaluator = SimpleEvaluator {-    seRules :: SimpleEvaluatorInterface,+    seRules :: SomeRules,     seUsePositionalScore :: Bool,     seMobilityWeight :: ScoreBase,     seBackyardWeight :: ScoreBase,@@ -57,21 +55,7 @@   }   deriving (Show) -class GameRules rules => SimpleEvaluatorSupport rules where-  getBackDirections :: rules -> [PlayerDirection]-  getBackDirections _ = [BackwardLeft, BackwardRight]--  getForwardDirections :: rules -> [PlayerDirection]-  getForwardDirections _ = [ForwardLeft, ForwardRight]--  getAllAddresses :: rules -> [Address]--data SimpleEvaluatorInterface = forall g. SimpleEvaluatorSupport g => SimpleEvaluatorInterface g--instance Show SimpleEvaluatorInterface where-  show (SimpleEvaluatorInterface rules) = rulesName rules--defaultEvaluator :: SimpleEvaluatorSupport rules => rules -> SimpleEvaluator+defaultEvaluator :: GameRules rules => rules -> SimpleEvaluator defaultEvaluator rules = SimpleEvaluator     { seRules              = iface     , seUsePositionalScore = True@@ -91,7 +75,7 @@     , seCache = buildCache iface     }   where-    iface = SimpleEvaluatorInterface rules+    iface = SomeRules rules  parseEvaluator :: SimpleEvaluator -> Value -> AT.Parser SimpleEvaluator parseEvaluator def = withObject "Evaluator" $ \v -> SimpleEvaluator@@ -177,8 +161,8 @@           , psThreats = 0         } -waveRho :: SimpleEvaluatorInterface -> Side -> (Address -> Bool) -> Address -> ScoreBase -> ScoreBase-waveRho (SimpleEvaluatorInterface rules) side isGood addr best = go addr+waveRho :: SomeRules -> Side -> (Address -> Bool) -> Address -> ScoreBase -> ScoreBase+waveRho (SomeRules rules) side isGood addr best = go addr   where     go :: Address -> ScoreBase     go addr@@ -191,8 +175,8 @@                 Just dst -> max 0 $ go dst - 1         in  maximum $ map check $ getForwardDirections rules -buildCache :: SimpleEvaluatorInterface -> M.Map Address SimpleEvaluatorData-buildCache iface@(SimpleEvaluatorInterface rules) = M.fromList [(addr, labelData addr) | addr <- getAllAddresses rules]+buildCache :: SomeRules -> M.Map Address SimpleEvaluatorData+buildCache iface@(SomeRules rules) = M.fromList [(addr, labelData addr) | addr <- getAllAddresses rules]   where     labelData addr = SimpleEvaluatorData $ SimpleEvaluatorWeights {         sewFirst = waveRho iface First (isCenter . aLabel) addr best,@@ -214,7 +198,7 @@         -- && (row >= crow - halfRow && row < crow + halfRow)  preEval :: SimpleEvaluator -> Side -> Board -> PreScore-preEval (SimpleEvaluator { seRules = iface@(SimpleEvaluatorInterface rules), ..}) side board =+preEval (SimpleEvaluator { seRules = iface@(SomeRules rules), ..}) side board =   let     kingCoef = seKingCoef       -- King is much more useful when there are enough men to help it@@ -337,7 +321,7 @@       Nothing -> e       Just e' -> e' -  evalBoard eval@(SimpleEvaluator {seRules = SimpleEvaluatorInterface rules, ..}) whoAsks board =+  evalBoard eval@(SimpleEvaluator {seRules = SomeRules rules, ..}) whoAsks board =     let ps1 = preEval eval whoAsks board         ps2 = preEval eval (opposite whoAsks) board @@ -387,7 +371,6 @@                  else (myScore - opponentScore)  instance VectorEvaluator SimpleEvaluator where-  type VectorEvaluatorSupport SimpleEvaluator rules = SimpleEvaluatorSupport rules    evalToVector (SimpleEvaluator {..}) = V.fromList $ map fromIntegral $ [         seMobilityWeight, seBackyardWeight,@@ -417,7 +400,7 @@         , seCache = buildCache iface       }     where-      iface = SimpleEvaluatorInterface rules+      iface = SomeRules rules           -- data ComplexEvaluator rules = ComplexEvaluator {
src/Core/Game.hs view
@@ -95,6 +95,13 @@       let side = hrSide r       in  HistoryRecordRep side (moveRep rules side $ hrMove r) +setGameHistory :: [HistoryRecord] -> GameM ()+setGameHistory history = do+  checkStatus New+  modify $ \st -> st {+              gState = (gState st) {gsHistory = history}+            }+ -- | Number of half-moves done in this game gameMoveNumber :: Game -> Int gameMoveNumber g =@@ -114,9 +121,10 @@   if move `notElem` (map pmMove $ possibleMoves rules side board)      then throwError NotAllowedMove      else do+          st <- gets gState           let (board', _, _) = applyMove rules side move board               moveMsg = MoveNotify (opposite side) side (moveRep rules side move) (boardRep board')-              mbResult = getGameResult rules board' (opposite side)+              mbResult = getGameResult rules st board' (opposite side)               messages = case mbResult of                            Nothing -> [moveMsg]                            Just result ->
src/Core/Json.hs view
@@ -6,6 +6,7 @@ import Data.Aeson.Types import qualified Data.Text as T import Data.Default+import qualified Data.HashMap.Strict as HM import System.Log.Heavy  import Core.Types@@ -25,6 +26,8 @@  instance ToJSON GameResult +instance FromJSON GameResult+ instance ToJSON BoardOrientation  instance ToJSON BoardTopology@@ -183,6 +186,12 @@       <*> v .:? "update_cache_max_depth" .!= (aiUpdateCacheMaxDepth def)       <*> v .:? "update_cache_max_pieces" .!= (aiUpdateCacheMaxPieces def) +instance FromJSON BattleServerConfig where+  parseJSON = withObject "BattleServerConfig" $ \v -> BattleServerConfig+    <$> v .:? "enable" .!= bsEnable def+    <*> v .:? "host" .!= bsHost def+    <*> v .:? "port" .!= bsPort def+ instance FromJSON GeneralConfig where   parseJSON = withObject "GeneralConfig" $ \v -> GeneralConfig     <$> v .:? "host" .!= (gcHost def)@@ -193,6 +202,7 @@     <*> v .:? "log_path" .!= (gcLogFile def)     <*> v .:? "log_level" .!= (gcLogLevel def)     <*> v .:? "ai" .!= (gcAiConfig def)+    <*> v .:? "battle_server" .!= (gcBattleServerConfig def)  instance FromJSON Level where   parseJSON (String "debug") = return debug_level@@ -204,4 +214,8 @@   parseJSON (String "fatal") = return fatal_level   parseJSON (String "disable") = return disable_logging   parseJSON invalid = typeMismatch "logging level" invalid++mergeObjects :: Value -> Value -> Value+mergeObjects (Object v1) (Object v2) = Object (HM.union v1 v2)+mergeObjects _ _ = error "not object value"
src/Core/Parallel.hs view
@@ -10,27 +10,41 @@ import Control.Concurrent import Data.Maybe import qualified Data.Map as M+import qualified Data.Text as T import System.Log.Heavy  import Core.Types -data Processor key input output = Processor (input -> key) (Chan input) (Chan (key, Either Error output))+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+       liftIO $ forkIO $ worker st inputChan i+    return $ Processor getKey inputChan   where-    worker st inChan outChan i = forever $ do-      input <- readChan inChan+    worker st inChan i = forever $ do+      (input, outChan) <- readChan inChan       output <- runCheckersT (withLogVariable "thread" (i :: Int) $ fn input) st       writeChan outChan (getKey input, output) +runProcessor' :: [T.Text] -> (input -> key) -> (T.Text -> input -> Checkers output) -> Checkers (Processor key input output)+runProcessor' labels getKey fn = do+    st <- ask+    inputChan <- liftIO newChan++    forM_ labels $ \label -> do+       liftIO $ forkIO $ worker st inputChan label+    return $ Processor getKey inputChan+  where+    worker st inChan label = forever $ do+      (input, outChan) <- readChan inChan+      output <- runCheckersT (withLogVariable "thread" label $ fn label 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@@ -39,12 +53,22 @@       Left err -> throwError err  process' :: Ord key => Processor key input output -> [input] -> Checkers [Either Error output]-process' (Processor getKey inChan outChan) inputs = do+process' (Processor getKey inChan) inputs = do     let n = length inputs+    outChan <- liftIO newChan     forM_ inputs $ \input ->-      liftIO $ writeChan inChan input+      liftIO $ writeChan inChan (input, outChan)     results <- replicateM n $ liftIO $ readChan outChan     let m = M.fromList results     let results = [fromJust $ M.lookup (getKey input) m | input <- inputs]     return results++processSingle :: Processor key input output -> input -> Checkers output+processSingle (Processor _ inChan) input = do+    outChan <- liftIO newChan+    liftIO $ writeChan inChan (input, outChan)+    result <- liftIO $ readChan outChan+    case snd result of+      Right output -> return output+      Left err -> throwError err
− src/Core/Rest.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Core.Rest where--import           Control.Monad.Reader-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception as E-import Control.Monad.Catch-import Data.String-import qualified Data.Text                     as T-import qualified Data.Text.Lazy                as TL-import           Data.Default-import           Data.Maybe-import           Data.Aeson              hiding ( json )-import           Web.Scotty.Trans-import qualified Network.HTTP.Types as H-import           Network.HTTP.Types.Status-import           Network.Wai.Handler.Warp-import qualified Network.Wai as Wai-import           System.Log.Heavy-import           System.Log.Heavy.TH-import Network.Socket-import System.Exit--import           Core.Types-import           Core.Board-import           Core.Supervisor-import           Core.Json                      ( ) -- import instances only-import           Formats.Types-import           Formats.Fen-import           Formats.Pdn--type Rest a = ActionT Error Checkers a--error400 :: T.Text -> Rest ()-error400 message = do-  json $ object ["error" .= message]-  status status400--transformError :: Error -> Rest ()-transformError (Unhandled err) = do-  error400 $ T.pack err-transformError (NoSuchMoveExt move side board possible) = do-  json $ object [-      "error" .= ("no such move" :: T.Text),-      "move" .= move,-      "side" .= side,-      "board" .= board,-      "possible" .= possible-    ]-  status status400-transformError err = do-  error400 $ T.pack $ show err--raise500 :: Error -> Rest a-raise500 err = do-  text $ TL.pack $ show err-  raiseStatus status500 err--instance Parsable Side where-  parseParam "1" = Right First-  parseParam "2" = Right Second-  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    -> raise500 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  ->-      case loadPdn rnd gr of-        Left err -> raise err-        Right board -> return (Nothing, Just $ boardRep board)-boardRq _ _ (NewGameRq { rqPrevBoard = Just gameId }) = do-  board <- liftCheckers_ $ getInitialBoard gameId-  return (Nothing, Just $ boardRep board)-boardRq _ _ (NewGameRq { rqBoard = Nothing, rqFen = Nothing, rqPdn = Nothing }) =-  return (Nothing, Nothing)-boardRq _ _ _ =-  raise $ InvalidBoard "only one of fields must be filled: board, fen, pdn"--parsePdnInfo :: PdnInfoRq -> Rest PdnInfo-parsePdnInfo (PdnInfoRq rname text) = do-  case selectRules' rname of-    Nothing -> raise UnknownRules-    Just rules ->-      case parsePdn (Just rules) text of-        Left err -> raise $ InvalidBoard err-        Right gr -> return $ pdnInfo gr--restServer :: MVar () -> ScottyT Error Checkers ()-restServer shutdownVar = do--  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) []--  get "/topology/:rules" $ do-    rules <- param "rules"-    topology <- liftCheckers_ $ getTopology rules-    json $ Response (TopologyRs topology) []--  post "/file/info/pdn" $ do-    rq <- jsonData-    info <- parsePdnInfo rq-    json $ Response (PdnInfoRs info) []--  post "/server/shutdown" $ do-    isLocal <- lift $ asks (gcLocal . csConfig)-    if isLocal-      then do-        json $ Response ShutdownRs []-        liftIO $ putMVar shutdownVar ()-      else error400 "Server is not running in local mode"--  get "/status" $ do-    json $ object [-        "status" .= ("ready" :: T.Text)-      ]--restOptions :: String -> Port -> Web.Scotty.Trans.Options-restOptions host port =-  Options 0 $ setOnExceptionResponse errorHandler $-              setHost (fromString host) $-              setPort port (settings def)--errorHandler :: SomeException -> Wai.Response-errorHandler e-  | Just (err :: Error) <- fromException e =-      Wai.responseLBS H.internalServerError500-         [(H.hContentType, "text/plain; charset=utf-8")]-         (fromString $ show err)-  | otherwise =-      Wai.responseLBS H.internalServerError500-         [(H.hContentType, "text/plain; charset=utf-8")]-         (fromString $ show e)---- openSocket :: AddrInfo -> IO Socket--- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)--- --- checkPort :: HostName -> Port -> IO Bool--- checkPort host port = do---   addr <- head <$> getAddrInfo (Just defaultHints) (Just host) (Just $ show port)---   E.bracketOnError (openSocket addr) close $ \sock -> do---     withFdSocket sock setCloseOnExecIfNeeded---     r <- E.try $ bind sock $ addrAddress addr---     case r of---       Right _ -> return True---       Left (e :: SomeException) -> do---         print e---         return False--ioErrorHandler :: IOError -> Checkers ()-ioErrorHandler err = liftIO $ do-  putStrLn $ "IO error: " ++ show err-  exitWith (ExitFailure 2)--runRestServer :: Checkers ()-runRestServer = do-  cs <- ask-  let getResponse m = do-        res <- runCheckersT m cs-        case res of-          Right response -> return response-          Left  err      -> fail $ show err-  host <- asks (T.unpack . gcHost . csConfig)-  port <- asks (gcPort . csConfig)-  -- portOpen <- liftIO $ checkPort host port-  shutdownVar <- liftIO newEmptyMVar-  forkCheckers $ handleIOError ioErrorHandler $ scottyOptsT (restOptions host (fromIntegral port)) getResponse (restServer shutdownVar)-  liftIO $ takeMVar shutdownVar-  -- REST thread should be able to write the response to Shutdown request.-  liftIO $ threadDelay (1000 * 1000)-
src/Core/Supervisor.hs view
@@ -21,10 +21,12 @@ import qualified Data.Map as M import qualified Data.Text as T import Data.Array.IArray as A+import qualified Data.ByteString as B import Data.Text.Format.Heavy import Data.Default import Data.Aeson hiding (Error) import Data.Dynamic+import Data.Store import GHC.Generics import System.Random import System.Log.Heavy@@ -32,6 +34,9 @@ import System.Log.Heavy.Format import System.Log.FastLogger.Date import System.Random.MWC+import System.Environment+import System.FilePath+import System.Directory  import Core.Types import Core.Board@@ -102,14 +107,33 @@   | ShutdownRs   deriving (Eq, Show, Generic) --- | Create supervisor handle-mkSupervisor :: IO SupervisorHandle-mkSupervisor = do+newRandomTable :: IO RandomTable+newRandomTable = 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+  return randomArray++loadRandomTable :: IO RandomTable+loadRandomTable = do+  home <- getEnv "HOME"+  let path = home </> ".cache" </> "hcheckers" </> "random.table"+  ex <- doesFileExist path+  if ex+    then do+      bytes <- B.readFile path+      Data.Store.decodeIO bytes+    else do+      table <- newRandomTable+      B.writeFile path $ Data.Store.encode table+      return table++-- | Create supervisor handle+mkSupervisor :: IO SupervisorHandle+mkSupervisor = do+  randomArray <- loadRandomTable   var <- atomically $ newTVar $ SupervisorState M.empty 0 M.empty $! randomArray   return var @@ -185,15 +209,26 @@ 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 ->+  storage <- createAiStorage ai++  liftIO $ atomically $ do+    st <- readTVar var+    case M.lookup key (ssAiStorages st) of+      Nothing -> do+        modifyTVar var $ \st ->           st {ssAiStorages = M.insert key (toDyn storage) (ssAiStorages st)}-    Just _ -> return ()+      Just _ -> return () +-- initAiStorage_ :: SomeRules -> SomeAi -> Checkers ()+-- initAiStorage_ (SomeRules rules) (SomeAi ai) = do+--   var <- askSupervisor+--   let key = (rulesName rules, aiName ai)+--   storage <- createAiStorage ai+--   liftIO $ atomically $ modifyTVar var $ \st ->+--           st {ssAiStorages = M.insert key (toDyn storage) (ssAiStorages st)}+--   return ()+ -- | Create a game in the New state newGame :: SomeRules -> Side -> Maybe BoardRep -> Checkers GameId newGame r@(SomeRules rules) firstSide mbBoardRep = do@@ -206,6 +241,10 @@     game <- mkGame st' rules gameId firstSide mbBoardRep     modifyTVar var $ \st -> st {ssGames = M.insert (show gameId) game (ssGames st)}     return $ show gameId++setHistory :: GameId -> [HistoryRecord] -> Checkers ()+setHistory gameId history = +  withGame gameId $ \_ -> setGameHistory history  -- | Register a user in the game registerUser :: GameId -> Side -> String -> Checkers ()
src/Core/Types.hs view
@@ -17,9 +17,9 @@ import Control.Monad.Metrics as Metrics import Control.Concurrent import Control.Concurrent.STM-import Control.Exception as E (try) import Data.List import Data.Array.Unboxed+import Data.Aeson.Types import qualified Data.Vector as V import qualified Data.Map as M import qualified Data.IntMap.Strict as IM@@ -31,7 +31,6 @@ 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@@ -43,6 +42,7 @@ import System.Log.Heavy import System.Log.Heavy.TH import System.Clock+import Web.Scotty.Trans import GHC.Exts (Constraint)  import Debug.Trace (traceEventIO)@@ -86,6 +86,8 @@ data PieceKind = Man | King   deriving (Eq, Ord, Generic, Typeable) +instance Store PieceKind+ instance Show PieceKind where   show Man = "M"   show King = "K"@@ -128,8 +130,10 @@     pieceKind :: PieceKind   , pieceSide :: Side   }-  deriving (Eq, Ord, Typeable)+  deriving (Eq, Ord, Typeable, Generic) +instance Store Piece+ instance Show Piece where   show (Piece k s) = show k ++ show s @@ -379,8 +383,10 @@  -- | Representation of Board for JSON data BoardRep = BoardRep [(Label, Piece)]-  deriving (Eq, Ord, Show, Typeable)+  deriving (Eq, Ord, Show, Typeable, Generic) +instance Store BoardRep+ boardRepLen :: BoardRep -> Int boardRepLen (BoardRep lst) = length lst @@ -435,7 +441,7 @@   boardTopology :: a -> BoardTopology  -- | Interface of game rules-class (Typeable g, Show g, HasBoardOrientation g, HasTopology g, VectorEvaluator (EvaluatorForRules g)) => GameRules g where+class (Typeable g, Show g, HasBoardOrientation g, HasTopology g, VectorEvaluator (EvaluatorForRules g), ToJSON (EvaluatorForRules g)) => GameRules g where   type EvaluatorForRules g   -- | Initial board with initial pieces position   initBoard :: SupervisorState -> g -> Board@@ -455,10 +461,18 @@   mobilityScore g side board = length $ possibleMoves g side board    updateRules :: g -> Value -> g-  getGameResult :: g -> Board -> Side -> Maybe GameResult+  getGameResult :: g -> GameState -> Board -> Side -> Maybe GameResult   rulesName :: g -> String   pdnId :: g -> String +  getBackDirections :: g -> [PlayerDirection]+  getBackDirections _ = [BackwardLeft, BackwardRight]++  getForwardDirections :: g -> [PlayerDirection]+  getForwardDirections _ = [ForwardLeft, ForwardRight]++  getAllAddresses :: g -> [Address]+ fieldsCount :: GameRules rules => rules -> Line fieldsCount rules =   let (nrows, ncols) = boardSize rules@@ -565,9 +579,8 @@   updateEval e _ = e  class Evaluator e => VectorEvaluator e where-  type VectorEvaluatorSupport e rules :: Constraint   evalToVector :: e -> V.Vector Double-  evalFromVector :: VectorEvaluatorSupport e rules => rules -> V.Vector Double -> e+  evalFromVector :: GameRules rules => rules -> V.Vector Double -> e  data SomeEval = forall e. VectorEvaluator e => SomeEval e   deriving (Typeable)@@ -580,7 +593,7 @@   evaluatorName (SomeEval e) = evaluatorName e   updateEval (SomeEval e) v = SomeEval (updateEval e v) -class (Show ai, Typeable (AiStorage ai)) => GameAi ai where+class (Show ai, Typeable (AiStorage ai), ToJSON ai) => GameAi ai where   type AiStorage ai    createAiStorage :: ai -> Checkers (AiStorage ai)@@ -747,6 +760,20 @@         , aiUpdateCacheMaxPieces = 8       } +data BattleServerConfig = BattleServerConfig {+    bsEnable :: Bool+  , bsHost :: T.Text+  , bsPort :: Int+  }+  deriving (Show, Typeable, Generic)++instance Default BattleServerConfig where+  def = BattleServerConfig {+            bsEnable = False+          , bsHost = "localhost"+          , bsPort = 8865+        }+ data GeneralConfig = GeneralConfig {     gcHost :: T.Text   , gcPort :: Int@@ -756,6 +783,7 @@   , gcLogFile :: FilePath   , gcLogLevel :: Level   , gcAiConfig :: AiConfig+  , gcBattleServerConfig :: BattleServerConfig   }   deriving (Show, Typeable, Generic) @@ -768,7 +796,8 @@     gcMetricsPort = 8000,     gcLogFile = "hcheckers.log",     gcLogLevel = info_level,-    gcAiConfig = def+    gcAiConfig = def,+    gcBattleServerConfig = def   }  -- | Commonly used data@@ -810,6 +839,8 @@ instance MonadFail Checkers where   fail msg = throwError (Unhandled msg) +type Rest a = ActionT Error Checkers a+ runCheckersT :: Checkers a -> CheckersState -> IO (Either Error a) runCheckersT actions st = runReaderT (runExceptT $ runCheckers actions) st @@ -917,4 +948,17 @@         Nothing -> do             $info "{}: work done, in {} iterations" (label, i)             return result++chunksOf :: Int -> [a] -> [[a]]+chunksOf n list+  | length list <= n = [list]+  | otherwise =+      let (first, other) = splitAt n list+      in  first : chunksOf n other++splitBy :: Int -> [a] -> [[a]]+splitBy n xs =+  let nxs = length xs+      m = (nxs `div` n) + 1+  in  chunksOf m xs
src/Formats/Compact.hs view
@@ -12,7 +12,6 @@ import qualified Data.Text as T import Text.Megaparsec hiding (Label, State) import Text.Megaparsec.Char-import Text.Megaparsec.Error (errorBundlePretty) import qualified Data.Text.IO as TIO import Text.Printf
src/Formats/Fen.hs view
@@ -6,10 +6,8 @@  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 (errorBundlePretty)  import Core.Types import Core.Board
src/Formats/Pdn.hs view
@@ -14,7 +14,6 @@ import qualified Data.Text as T import Text.Megaparsec hiding (Label, State) import Text.Megaparsec.Char-import Text.Megaparsec.Error (errorBundlePretty) import qualified Data.Text.IO as TIO import Text.Printf @@ -301,34 +300,37 @@       state = execState (forM_ instructions interpret) initState   in  map M.elems $ M.elems $ isVariants state -loadPdn :: SupervisorState -> GameRecord -> Either Error Board+loadPdn :: SupervisorState -> GameRecord -> Either Error ([HistoryRecord], Board) loadPdn rnd r = do     let findRules [] = Nothing         findRules (GameType rules:_) = Just rules         findRules (_:rest) = findRules rest -        withRules :: SomeRules -> Either Error Board+        withRules :: SomeRules -> Either Error ([HistoryRecord], Board)         withRules some@(SomeRules rules) = do             let board0 = initBoardFromTags rnd some (grTags r)                 -                go :: Board -> [MoveRec] -> Either Error Board-                go board [] = return board-                go board0 (moveRec : rest) = do-                  board1 <- case mrFirst moveRec of-                              Just rec -> do-                                move1 <- parseMoveRec rules First board0 rec-                                let (board1,_,_) = applyMove rules First move1 board0-                                return board1-                              Nothing -> return board0+                go :: ([HistoryRecord], Board) -> [MoveRec] -> Either Error ([HistoryRecord], Board)+                go (history, board) [] = return (history, board)+                go (history, board0) (moveRec : rest) = do+                  (records1, board1) <-+                      case mrFirst moveRec of+                        Just rec -> do+                          move1 <- parseMoveRec rules First board0 rec+                          let (board1,_,_) = applyMove rules First move1 board0+                              record = HistoryRecord First move1 board0+                          return ([record], board1)+                        Nothing -> return ([], board0)                   case mrSecond moveRec of-                    Nothing -> return board1+                    Nothing -> return (records1 ++ history, board1)                     Just rec -> do                       move2 <- parseMoveRec rules Second board1 rec                       let (board2,_,_) = applyMove rules Second move2 board1-                      go board2 rest+                          record = HistoryRecord Second move2 board1+                      go ([record] ++ records1 ++ history, board2) rest              case instructionsToMoves (grMoves r) of-              [moves] -> go board0 moves+              [moves] -> go ([], board0) moves               vars -> Left $ AmbigousPdnInstruction $ show vars      case findRules (grTags r) of
src/Formats/Types.hs view
@@ -11,7 +11,6 @@ import Data.Typeable import Text.Megaparsec hiding (Label, State) import Data.Void-import Data.Aeson import GHC.Generics  import Core.Types
src/Learn.hs view
@@ -8,7 +8,6 @@ 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@@ -18,7 +17,7 @@ import AI.AlphaBeta import AI.AlphaBeta.Types import AI.AlphaBeta.Cache-import AI.AlphaBeta.Persistent+-- import AI.AlphaBeta.Persistent import Formats.Types import Formats.Pdn @@ -29,15 +28,9 @@     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+    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 [] =@@ -78,9 +71,6 @@     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)@@ -123,7 +113,7 @@   $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 :: (GameRules rules, VectorEvaluator eval) => AlphaBeta rules eval -> FilePath -> Checkers () learnPdn ai@(AlphaBeta params rules eval) path = do   cache <- loadAiCache scoreMoveGroup ai   pdn <- liftIO $ parsePdnFile (Just $ SomeRules rules) path
src/Main.hs view
@@ -6,28 +6,35 @@ import Control.Monad.Reader import Control.Concurrent.STM import Data.Default+import Data.Maybe+import Data.List import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.IO as TIO import qualified Data.ByteString.Lazy.Char8 as C8 import qualified Data.Aeson as Aeson import System.Log.Heavy import Options.Applicative import Text.Printf+import System.Random -import Core.Types-import Core.Board+import Core.Types hiding (timed) import AI import AI.AlphaBeta.Types-import AI.AlphaBeta.Persistent-import Core.Rest+import AI.AlphaBeta.Persistent (loadAiData')+import Rest.Common (runRestServer)+import Rest.Game (restServer)+import Rest.Battle (restServer) import Core.Checkers import Core.CmdLine import Core.Supervisor (withRules)-import Core.Evaluator+import Core.Parallel+import Core.Monitoring  import Learn import Battle import Rules.Russian-import Rules.Spancirety+-- import Rules.Spancirety    -- let stdout = LoggingSettings $ filtering defaultLogFilter defStdoutSettings       -- debug = LoggingSettings $ Filtering (\m -> lmLevel m == trace_level) ((defFileSettings "trace.log") {lsFormat = "{time} {source} [{thread}]: {message}\n"})@@ -39,10 +46,18 @@   case cmdSpecial cmd of     Nothing ->       withCheckers cmd $ do-          cfg <- asks csConfig-          let fltr = [([], gcLogLevel cfg)]-          withLogContext (LogContextFrame [] (include fltr)) $-              runRestServer+          logLevel <- asks (gcLogLevel . csConfig)+          host <- asks (T.unpack . gcHost . csConfig)+          port <- asks (gcPort . csConfig)+          bsConfig <- asks (gcBattleServerConfig . csConfig)+          let fltr = [([], logLevel)]+          withLogContext (LogContextFrame [] (include fltr)) $ do+              if fromMaybe False (cmdBattleServer cmd)+                then if bsEnable bsConfig+                       then runRestServer (T.unpack $ bsHost bsConfig) (bsPort bsConfig) Rest.Battle.restServer+                       else fail "Battle server is not enabled in config"+                else runRestServer host port Rest.Game.restServer+                     Just str -> special cmd (words str)  special :: CmdLine -> [String] -> IO ()@@ -66,9 +81,19 @@         ai2 <- loadAi "default" rules path2         withCheckers cmd $             withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do-              runBattle (SomeRules rules) (SomeAi ai1) (SomeAi ai2) "battle.pdn"+              runBattleLocal (SomeRules rules) (1,SomeAi ai1) (2,SomeAi ai2) "battle.pdn"               return () +    ["battle-remote", host, rulesName, path1, path2] -> do+      withRules rulesName $ \rules -> do+        ai1 <- loadAi "default" rules path1+        ai2 <- loadAi "default" rules path2+        withCheckers cmd $+            withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do+              rs <- runBattleRemote (T.pack host) (SomeRules rules) (1,SomeAi ai1) (2,SomeAi ai2) "battle.pdn"+              liftIO $ putStrLn $ "Remote: " ++ show rs+              return ()+     ["match", rulesName, ns, path1, path2] -> do       withRules rulesName $ \rules -> do         let n = read ns@@ -78,7 +103,7 @@         putStrLn $ "AI2: " ++ show ai2         withCheckers cmd $             withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do-              runMatch (SomeRules rules) (SomeAi ai1) (SomeAi ai2) n+              runMatch runBattleLocal (SomeRules rules) (1, SomeAi ai1) (2, SomeAi ai2) n               return ()      ("tournament": matches : games : paths) -> do @@ -88,19 +113,14 @@       ais <- forM paths $ \path -> loadAi "default" rules path       withCheckers cmd $           withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do-            runTournament rules ais nMatches nGames+            runTournament (dumbMatchRunner runBattleLocal) rules ais nMatches nGames             return () -    ("genetics": generations : size : best : paths) -> do-      let rules = spancirety-          nGenerations = read generations-          generationSize = read size-          nBest = read best-      ais <- forM paths $ \path -> loadAi "default" rules path-      withCheckers cmd $+    ["genetics", yamlPath] -> do+      withCheckers cmd $ do           withLogContext (LogContextFrame [] (include defaultLogFilter)) $ do-            result <- runGenetics rules nGenerations generationSize nBest ais-            forM_ result $ \ai -> liftIO $ C8.putStrLn $ Aeson.encode ai+            result <- runGeneticsJ yamlPath+            forM_ result $ \(SomeAi ai) -> liftIO $ C8.putStrLn $ Aeson.encode ai             return ()      ["generate", ns, deltas, path] -> do@@ -108,96 +128,11 @@           delta = read deltas       generateAiVariations n delta path -    -- ["dump", path] -> checkDataFile' path-    ["load", path] -> do-      idx <- loadIndexIO path-      print path--    ["test"] -> do+    ["dump", path] -> do       withCheckers cmd $ do         let rules = russian-            cache = seCache $ defaultEvaluator rules-        forM_ (M.assocs cache) $ \(addr, sed) -> do-            liftIO $ printf "%s => %s, %s\n"-                (show $ aLabel addr)-                (show $ weightForSide First $ sedCenter sed)-                (show $ weightForSide Second $ sedCenter sed)-    --- main :: IO ()--- main = do---   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--- --- +        (vec, bmap) <- loadAiData' path+        liftIO $ printf "Evaluator: %s\n" (show vec)+        forM_ (M.assocs bmap) $ \(bHash, item) -> do+            liftIO $ printf "Hash: %d => %s\n" bHash (show item)+
+ src/Rest/Battle.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}++module Rest.Battle where++import Control.Monad.Reader+import Control.Concurrent+import qualified Data.Text as T+import Data.Aeson hiding ( json )+import Web.Scotty.Trans+import Network.HTTP.Req+import Text.URI (mkURI)++import Core.Types+import Core.Json ( ) -- import instances only+import Core.Supervisor (selectRules')++import Battle (BattleRunner, runBattleLocal)+import AI (parseAi)+import Rest.Common++withRulesR :: String -> (forall rules. GameRules rules => rules -> Rest a) -> Rest a+withRulesR rname fn =+  case selectRules' rname of+    Just (SomeRules rules) -> fn rules+    Nothing -> raise UnknownRules++restServer :: MVar () -> ScottyT Error Checkers ()+restServer shutdownVar = do+  +  post "/battle/run" $ do+    rq <- jsonData+    withRulesR (brqRules rq) $ \rules -> do+      let ab1 = parseAi rules (brqAi1 rq)+          ab2 = parseAi rules (brqAi2 rq)+          ai1 = SomeAi ab1+          ai2 = SomeAi ab2+      result <- liftCheckers_ $ runBattleLocal (SomeRules rules) (1,ai1) (2,ai2) "battle.pdn"+      json result++  post "/server/shutdown" $ do+    isLocal <- lift $ asks (gcLocal . csConfig)+    if isLocal+      then do+        json $ object ["shutdown" .= ("ok" :: T.Text)]+        liftIO $ putMVar shutdownVar ()+      else error400 "Server is not running in local mode"+
+ src/Rest/Common.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Rest.Common where++import Control.Monad.Reader+import Control.Concurrent+import Control.Exception as E+import Control.Monad.Catch+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Default+import Data.Aeson hiding (json)+import Data.String+import System.Log.Heavy+import Web.Scotty.Trans+import Network.HTTP.Types.Status+import qualified Network.HTTP.Types as H+import qualified Network.Wai as Wai+import Network.Wai.Handler.Warp+import System.Exit++import Core.Types+import Core.Json () -- import instances only++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    -> raise500 err+ where+  wrap r = case mbId of+    Nothing     -> r+    Just gameId -> withGameContext gameId r++raise500 :: Error -> Rest a+raise500 err = do+  text $ TL.pack $ show err+  raiseStatus status500 err++error400 :: T.Text -> Rest ()+error400 message = do+  json $ object ["error" .= message]+  status status400++transformError :: Error -> Rest ()+transformError (Unhandled err) = do+  error400 $ T.pack err+transformError (NoSuchMoveExt move side board possible) = do+  json $ object [+      "error" .= ("no such move" :: T.Text),+      "move" .= move,+      "side" .= side,+      "board" .= board,+      "possible" .= possible+    ]+  status status400+transformError (InvalidGameStatus expected actual) = do+  json $ object [+      "error" .= ("invalid game status" :: T.Text),+      "expected" .= expected,+      "actual" .= actual+    ]+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++restOptions :: String -> Port -> Web.Scotty.Trans.Options+restOptions host port =+  Options 0 $ setOnExceptionResponse errorHandler $+              setHost (fromString host) $+              setPort port (settings def)++errorHandler :: SomeException -> Wai.Response+errorHandler e+  | Just (err :: Error) <- fromException e =+      Wai.responseLBS H.internalServerError500+         [(H.hContentType, "text/plain; charset=utf-8")]+         (fromString $ show err)+  | otherwise =+      Wai.responseLBS H.internalServerError500+         [(H.hContentType, "text/plain; charset=utf-8")]+         (fromString $ show e)++ioErrorHandler :: IOError -> Checkers ()+ioErrorHandler err = liftIO $ do+  putStrLn $ "IO error: " ++ show err+  exitWith (ExitFailure 2)++runRestServer :: String -> Int -> (MVar () -> ScottyT Error Checkers ()) -> Checkers ()+runRestServer host port restServer = do+  cs <- ask+  let getResponse m = do+        res <- runCheckersT m cs+        case res of+          Right response -> return response+          Left  err      -> fail $ show err+  -- portOpen <- liftIO $ checkPort host port+  shutdownVar <- liftIO newEmptyMVar+  forkCheckers $ handleIOError ioErrorHandler $ scottyOptsT (restOptions host (fromIntegral port)) getResponse (restServer shutdownVar)+  liftIO $ takeMVar shutdownVar+  -- REST thread should be able to write the response to Shutdown request.+  liftIO $ threadDelay (1000 * 1000)++data BattleRq = BattleRq {+      brqRules :: String+    , brqAi1 :: Value+    , brqAi2 :: Value+    }++instance ToJSON BattleRq where+  toJSON rq =+    object ["rules" .= brqRules rq, "ai1" .= brqAi1 rq, "ai2" .= brqAi2 rq]++instance FromJSON BattleRq where+  parseJSON (Object v) = BattleRq+    <$> v .: "rules"+    <*> v .: "ai1"+    <*> v .: "ai2"+
+ src/Rest/Game.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Rest.Game 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           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.Types+import           Formats.Fen+import           Formats.Pdn+import Rest.Common++boardRq :: SupervisorState -> SomeRules -> NewGameRq -> Rest (Maybe Side, [HistoryRecord], 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  ->+      case loadPdn rnd gr of+        Left err -> raise err+        Right (history, board) -> return (Nothing, history, Just $ boardRep board)+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"++parsePdnInfo :: PdnInfoRq -> Rest PdnInfo+parsePdnInfo (PdnInfoRq rname text) = do+  case selectRules' rname of+    Nothing -> raise UnknownRules+    Just rules ->+      case parsePdn (Just rules) text of+        Left err -> raise $ InvalidBoard err+        Right gr -> return $ pdnInfo gr++restServer :: MVar () -> ScottyT Error Checkers ()+restServer shutdownVar = do++  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, history, board) <- boardRq rnd rules rq+        let firstSide = fromMaybe First mbFirstSide+        gameId <- liftCheckers_ $ newGame rules firstSide board+        liftCheckers_ $ setHistory gameId history+        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) []++  get "/topology/:rules" $ do+    rules <- param "rules"+    topology <- liftCheckers_ $ getTopology rules+    json $ Response (TopologyRs topology) []++  post "/file/info/pdn" $ do+    rq <- jsonData+    info <- parsePdnInfo rq+    json $ Response (PdnInfoRs info) []++  post "/server/shutdown" $ do+    isLocal <- lift $ asks (gcLocal . csConfig)+    if isLocal+      then do+        json $ Response ShutdownRs []+        liftIO $ putMVar shutdownVar ()+      else error400 "Server is not running in local mode"++  get "/status" $ do+    json $ object [+        "status" .= ("ready" :: T.Text)+      ]++-- openSocket :: AddrInfo -> IO Socket+-- openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+-- +-- checkPort :: HostName -> Port -> IO Bool+-- checkPort host port = do+--   addr <- head <$> getAddrInfo (Just defaultHints) (Just host) (Just $ show port)+--   E.bracketOnError (openSocket addr) close $ \sock -> do+--     withFdSocket sock setCloseOnExecIfNeeded+--     r <- E.try $ bind sock $ addrAddress addr+--     case r of+--       Right _ -> return True+--       Left (e :: SomeException) -> do+--         print e+--         return False+
src/Rules/Armenian.hs view
@@ -23,11 +23,6 @@ instance HasTopology Armenian where   boardTopology _ = DiagonalAndOrthogonal -instance SimpleEvaluatorSupport Armenian where-  getBackDirections _ = [Backward]-  getForwardDirections _ = [ForwardLeft, Forward, ForwardRight]-  getAllAddresses r = addresses8 r- instance GameRules Armenian where   type EvaluatorForRules Armenian = SimpleEvaluator @@ -65,6 +60,10 @@   getGameResult = genericGameResult    pdnId _ = "44"++  getBackDirections _ = [Backward]+  getForwardDirections _ = [ForwardLeft, Forward, ForwardRight]+  getAllAddresses r = addresses8 r  armenianBase :: GenericRules -> GenericRules armenianBase =
src/Rules/Brazilian.hs view
@@ -19,9 +19,6 @@ instance HasTopology Brazilian where   boardTopology _ = Diagonal -instance SimpleEvaluatorSupport Brazilian where-  getAllAddresses r = addresses8 r- instance Show Brazilian where   show = rulesName @@ -49,6 +46,7 @@   mobilityScore (Brazilian rules) side board = gMobilityScore rules side board    getGameResult = genericGameResult+  getAllAddresses r = addresses8 r  brazilian :: Brazilian brazilian = Brazilian $
src/Rules/Canadian.hs view
@@ -21,9 +21,6 @@ instance HasTopology Canadian where   boardTopology _ = Diagonal -instance SimpleEvaluatorSupport Canadian where-  getAllAddresses r = addresses12 r- instance GameRules Canadian where   type EvaluatorForRules Canadian = SimpleEvaluator @@ -63,6 +60,7 @@    possibleMoves (Canadian rules) side board = gPossibleMoves rules side board   mobilityScore (Canadian rules) side board = gMobilityScore rules side board+  getAllAddresses r = addresses12 r  canadian :: Canadian canadian = Canadian $
src/Rules/Czech.hs view
@@ -21,9 +21,6 @@ instance HasTopology Czech where   boardTopology _ = Core.Types.Diagonal -instance SimpleEvaluatorSupport Czech where-  getAllAddresses r = addresses8 r- instance GameRules Czech where   type EvaluatorForRules Czech = SimpleEvaluator   pdnId _ = "29"@@ -47,6 +44,7 @@   updateRules r _ = r    getGameResult = genericGameResult+  getAllAddresses r = addresses8 r  manCaptures :: GenericRules -> CaptureState -> [PossibleMove] manCaptures rules ct@(CaptureState {..}) =
src/Rules/Diagonal.hs view
@@ -21,9 +21,6 @@ instance HasTopology DiagonalRussian where   boardTopology _ = Core.Types.Diagonal -instance SimpleEvaluatorSupport DiagonalRussian where-  getAllAddresses r = addresses8 r- instance GameRules DiagonalRussian where   type EvaluatorForRules DiagonalRussian = SimpleEvaluator   initBoard rnd r =@@ -62,6 +59,7 @@   getGameResult = genericGameResult    pdnId _ = "42"+  getAllAddresses r = addresses8 r  diagonal :: DiagonalRussian diagonal = DiagonalRussian $
src/Rules/English.hs view
@@ -23,9 +23,6 @@ instance HasTopology English where   boardTopology _ = Diagonal -instance SimpleEvaluatorSupport English where-  getAllAddresses r = addresses8' r- instance GameRules English where   type EvaluatorForRules English = SimpleEvaluator   boardSize _ = boardSize Russian.russian@@ -51,6 +48,7 @@   mobilityScore (English rules) side board = gMobilityScore rules side board    pdnId _ = "21"+  getAllAddresses r = addresses8' r  english :: English english = English $
src/Rules/International.hs view
@@ -24,9 +24,6 @@ instance HasTopology International where   boardTopology _ = Diagonal -instance SimpleEvaluatorSupport International where-  getAllAddresses r = addresses10 r- instance GameRules International where   type EvaluatorForRules International = SimpleEvaluator   boardSize _ = (10, 10)@@ -63,6 +60,7 @@   mobilityScore (International rules) side board = gMobilityScore rules side board    pdnId _ = "20"+  getAllAddresses r = addresses10 r  internationalBase :: GenericRules -> GenericRules internationalBase =
src/Rules/Russian.hs view
@@ -21,9 +21,6 @@ instance Show Russian where   show = rulesName -instance SimpleEvaluatorSupport Russian where-  getAllAddresses r = addresses8 r- instance HasTopology Russian where   boardTopology _ = Diagonal @@ -51,6 +48,7 @@   getGameResult = genericGameResult    pdnId _ = "25"+  getAllAddresses r = addresses8 r  russianBase :: GenericRules -> GenericRules russianBase =
src/Rules/Simple.hs view
@@ -19,9 +19,6 @@ instance Show Simple where   show = rulesName -instance SimpleEvaluatorSupport Simple where-  getAllAddresses r = addresses8 r- instance HasTopology Simple where   boardTopology _ = Diagonal @@ -47,6 +44,7 @@   mobilityScore (Simple rules) side board = gMobilityScore rules side board    pdnId _ = "43"+  getAllAddresses r = addresses8 r  simple :: Simple simple = Simple $
src/Rules/Spancirety.hs view
@@ -22,9 +22,6 @@ instance HasTopology Spancirety where   boardTopology _ = Diagonal -instance SimpleEvaluatorSupport Spancirety where-  getAllAddresses r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (8, 10)- instance GameRules Spancirety where   type EvaluatorForRules Spancirety = SimpleEvaluator   initBoard rnd r =@@ -57,6 +54,7 @@   getGameResult = genericGameResult    pdnId _ = "41"+  getAllAddresses r = IM.elems $ bAddresses $ buildBoard DummyRandomTableProvider r FirstAtBottom (8, 10)  spancirety :: Spancirety spancirety = Spancirety $
src/Rules/Turkish.hs view
@@ -24,10 +24,6 @@ instance HasTopology Turkish where   boardTopology _ = Orthogonal -instance SimpleEvaluatorSupport Turkish where-  getBackDirections _ = [Backward]-  getAllAddresses r = addresses8 r- instance GameRules Turkish where   type EvaluatorForRules Turkish = SimpleEvaluator   initBoard rnd r =@@ -57,6 +53,9 @@   getGameResult = genericGameResult    pdnId _ = "43"++  getBackDirections _ = [Backward]+  getAllAddresses r = addresses8 r  turkishBase :: GenericRules -> GenericRules turkishBase =