Prepare file structure for stats.

refs #6.

Author: portnov

src/AI/AlphaBeta/Cache.hs

@@ -202,7 +202,7 @@ lookupAiCache params board depth side handle = do
             AICache _ _ cache <- liftIO $ atomically $ readTVar (aichData handle)
             case lookupBoardMap (bc,bk) cache of
               Nothing -> return Nothing
-              Just byDepth -> do
+              Just (PerBoardData {boardScores = byDepth}) -> do
                 let ds = [dpTarget depth .. dpTarget depth + aiUseCacheMaxDepthPlus cfg] ++
                              [dpTarget depth - aiUseCacheMaxDepthMinus cfg .. dpTarget depth-1] 
                     depths = [depth {dpTarget = d} | d <- ds]
@@ -230,20 +230,13 @@ putAiCache' params board depth side sideItem handle = do
       store <- asks (aiStoreCache . gcAiConfig . csConfig)
       liftIO $ atomically $ do
         aic <- readTVar (aichData handle)
-        let updateItem item1 item2 =
-              case side of
-                First -> item1 {ciFirst = ciFirst item2 `mplus` ciFirst item1}
-                Second -> item2 {ciSecond = ciSecond item2 `mplus` ciSecond item1}
-
-            updateDepthMap m1 m2 = M.unionWith updateItem m1 m2
-
-            item = case side of
+        let item = case side of
                      First -> CacheItem {ciFirst = Just sideItem, ciSecond = Nothing}
                      Second -> CacheItem {ciFirst = Nothing, ciSecond = Just sideItem}
 
-            init = M.singleton depth item
+            init = PerBoardData (M.singleton depth item) Nothing
 
-            newAicData = putBoardMapWith updateDepthMap (bc,bk) init (aicData aic)
+            newAicData = putBoardMapWith (<>) (bc,bk) init (aicData aic)
             aic' = aic {aicDirty = True, aicData = newAicData}
 
             Just perBoard = lookupBoardMap (bc,bk) newAicData 

src/AI/AlphaBeta/Persistent.hs

@@ -274,7 +274,7 @@ instance Store IndexRecord where
     dataBlock <- peek
     return $ IndexRecord idxBlock dataBlock
 
-lookupFileB :: B.ByteString -> Storage (Maybe (M.Map DepthParams CacheItem))
+lookupFileB :: B.ByteString -> Storage (Maybe PerBoardData)
 lookupFileB bstr = do
     st <- get
     case ssData st of
@@ -311,14 +311,19 @@ lookupFile board depth side = Metrics.timed "cache.lookup.file" $ do
   mbItem <- lookupFileB (encodeBoard board)
   case mbItem of
     Nothing -> return Nothing
-    Just item -> case M.lookup depth item of
+    Just item -> case M.lookup depth (boardScores item) of
                    Nothing -> return Nothing
                    Just ci -> case side of
                                 First -> return $ ciFirst ci
                                 Second -> return $ ciSecond ci
 
-putRecordFileB :: B.ByteString -> DepthParams -> Side -> StorageValue -> Storage ()
-putRecordFileB bstr depth side value = do
+lookupStatsFile :: Board -> Storage (Maybe Stats)
+lookupStatsFile board = Metrics.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 ()
@@ -338,17 +343,16 @@ putRecordFileB bstr depth side value = do
                  seek IndexFile idxOffset
                  writeData IndexFile record'
                  seek DataFile $ calcDataBlockOffset newDataBlock
-                 let newData = M.singleton depth newItem
                  writeDataSized DataFile newData
                  return ()
             else do
-                   let dataOffset = calcDataBlockOffset dataBlockNumber
-                   seek DataFile dataOffset
-                   oldData <- readDataSized DataFile
-                   let newData = updateData oldData
-                   seek DataFile dataOffset
-                   writeDataSized DataFile newData
-                   return ()
+                 let dataOffset = calcDataBlockOffset dataBlockNumber
+                 seek DataFile dataOffset
+                 oldData <- readDataSized DataFile
+                 let newData' = oldData <> newData
+                 seek DataFile dataOffset
+                 writeDataSized DataFile newData'
+                 return ()
       | otherwise = do
           bsize <- gets ssBoardSize
           let idxOffset = calcIndexOffset bsize blockNumber (B.head bstr)
@@ -389,22 +393,14 @@ putRecordFileB bstr depth side value = do
       writeBytes DataFile empty
       return newBlockNumber
 
-    updateData oldMap =
-      M.insertWith updateItem depth newItem oldMap
-
-    newItem = case side of
-                First -> CacheItem {ciFirst = Just value, ciSecond = Nothing}
-                Second -> CacheItem {ciFirst = Nothing, ciSecond = Just value}
-
-    updateItem item1 item2 =
-              case side of
-                First -> item1 {ciFirst = ciFirst item2 `mplus` ciFirst item1}
-                Second -> item2 {ciSecond = ciSecond item2 `mplus` ciSecond item1}
-
 putRecordFile :: Board -> DepthParams -> Side -> StorageValue -> Storage ()
 putRecordFile board depth side value = Metrics.timed "cache.put.file" $ do
   let bstr = encodeBoard board
-  putRecordFileB bstr depth side value
+      newData = PerBoardData (M.singleton depth item) Nothing
+      item = case side of
+               First -> CacheItem {ciFirst = Just value, ciSecond = Nothing}
+               Second -> CacheItem {ciFirst = Nothing, ciSecond = Just value}
+  putRecordFileB bstr newData
 
 initFile :: Storage ()
 initFile = do

src/AI/AlphaBeta/Types.hs

@@ -15,6 +15,7 @@ import qualified Control.Concurrent.ReadWriteLock as RWL
 import Control.Concurrent.STM
 import qualified Data.Map as M
 import qualified Data.HashPSQ as PQ
+import Data.Int
 import Data.Word
 import Data.Binary
 import Data.Store
@@ -58,14 +59,35 @@ data DepthParams = DepthParams {
   deriving (Eq, Ord, Show, Typeable, Generic)
 
 instance Store DepthParams
+instance Binary DepthParams
+
+data Stats = Stats {
+    statsCount :: Int16
+  , statsMaxScore :: Score
+  , statsMinScore :: Score
+  , statsSumScore :: Score
+  }
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Binary Stats
+instance Store Stats
+
+instance Semigroup Stats where
+  s1 <> s2 =
+    Stats (statsCount s1 + statsCount s2)
+          (max (statsMaxScore s1) (statsMaxScore s2))
+          (min (statsMinScore s1) (statsMinScore s2))
+          (statsSumScore s1 + statsSumScore s2)
+
+instance Monoid Stats where
+  mempty = Stats 0 0 0 0
 
 data CacheItemSide = CacheItemSide {
     cisScore :: ! Score
   }
   deriving (Eq, Show, Generic, Typeable)
 
 instance Binary CacheItemSide
-
 instance Store CacheItemSide
 
 data CacheItem = CacheItem {
@@ -75,10 +97,34 @@ data CacheItem = CacheItem {
   deriving (Generic, Typeable, Show)
 
 instance Binary CacheItem
-
 instance Store CacheItem
 
-type PerBoardData = M.Map DepthParams CacheItem
+instance Semigroup CacheItem where
+  item1 <> item2 = CacheItem {
+    ciFirst = ciFirst item2 `mplus` ciFirst item1,
+    ciSecond = ciSecond item2 `mplus` ciSecond item1
+  }
+
+instance Monoid CacheItem where
+  mempty = CacheItem Nothing Nothing
+
+data PerBoardData = PerBoardData {
+    boardScores :: M.Map DepthParams CacheItem
+  , boardStats :: Maybe Stats
+  }
+  deriving (Generic, Typeable, Show)
+
+instance Semigroup PerBoardData where
+  d1 <> d2 = PerBoardData {
+    boardScores = M.unionWith (<>) (boardScores d1) (boardScores d2),
+    boardStats = liftM2 (<>) (boardStats d1) (boardStats d2)
+  }
+
+instance Monoid PerBoardData where
+  mempty = PerBoardData M.empty Nothing
+
+instance Binary PerBoardData
+instance Store PerBoardData
 
 type AIData = BoardMap PerBoardData