Learn: store statistics.

refs #6.

Author: portnov

src/AI/AlphaBeta/Persistent.hs

@@ -191,7 +191,7 @@ readDataSized file = do
   bstr <- readBytes file (fromIntegral size)
   when (B.null bstr) $ do
     offset <- tell file
-    fail $ "readDataSized: unexpected EOF, offset " ++ show offset
+    fail $ "readDataSized: zero data size, offset " ++ show offset
   liftIO $ Data.Store.decodeIO bstr
 
 writeDataSized :: forall a. Data.Store.Store a => FileType -> a -> Storage ()
@@ -338,6 +338,7 @@ putRecordFileB bstr newData = do
           let dataBlockNumber = irDataBlock record
           if dataBlockNumber == unexistingBlock 
             then do
+                 Metrics.increment "storage.data.block.created"
                  newDataBlock <- createDataBlock
                  let record' = record {irDataBlock = newDataBlock}
                  seek IndexFile idxOffset
@@ -346,6 +347,7 @@ putRecordFileB bstr newData = do
                  writeDataSized DataFile newData
                  return ()
             else do
+                 Metrics.increment "storage.data.block.reused"
                  let dataOffset = calcDataBlockOffset dataBlockNumber
                  seek DataFile dataOffset
                  oldData <- readDataSized DataFile
@@ -361,12 +363,15 @@ putRecordFileB bstr newData = do
           let nextBlockNumber = irIndexBlock record
           if nextBlockNumber == unexistingBlock
             then do
+                 Metrics.increment "storage.index.block.created"
                  newIndexBlock <- createIndexBlock
                  let record' = record {irIndexBlock = newIndexBlock}
                  seek IndexFile idxOffset
                  writeData IndexFile record'
                  tryBlock newIndexBlock (B.tail bstr)
-            else tryBlock nextBlockNumber (B.tail bstr)
+            else do
+                 Metrics.increment "storage.index.block.reused"
+                 tryBlock nextBlockNumber (B.tail bstr)
 
     createIndexBlock = do
       seek IndexFile 0
@@ -461,7 +466,7 @@ readDataSizedIO file = do
   bstr <- B.hGet file (fromIntegral size)
   when (B.null bstr) $ do
     offset <- hTell file
-    fail $ printf "readDataSized: unexpected EOF, offset %s, size %s" (show offset) (show size)
+    fail $ printf "readDataSizedIO: zero data size, offset %s, size %s" (show offset) (show size)
   Data.Store.decodeIO bstr
 
 dumpIndexBlock :: Handle -> BoardSize -> IndexBlockNumber -> IO ()
@@ -476,8 +481,11 @@ checkDataFile :: FilePath -> IO ()
 checkDataFile path = withFile path ReadMode $ \file -> do
   nBlocks <- readDataIO file :: IO DataBlockNumber
   forM_ [0 .. nBlocks - 1] $ \i -> do
-    let start = fromIntegral $ calcDataBlockOffset i
-    hSeek file AbsoluteSeek start
-    size <- readDataIO file :: IO Word16
-    printf "Block #%d: data size %d\n" i size
+      let start = fromIntegral $ calcDataBlockOffset i
+      hSeek file AbsoluteSeek start
+      size <- readDataIO file :: IO Word16
+      when (size > 0) $ do
+        bstr <- B.hGet file (fromIntegral size)
+        record <- Data.Store.decodeIO bstr :: IO PerBoardData
+        printf "Block #%d: data: %s\n" i (show record)
 

src/Learn.hs

@@ -16,47 +16,60 @@ import Core.Board
 import AI.AlphaBeta
 import AI.AlphaBeta.Types
 import AI.AlphaBeta.Cache
+import AI.AlphaBeta.Persistent
 import Formats.Types
 import Formats.Pdn
 
 doLearn :: (GameRules rules, Evaluator eval) => rules -> eval -> AICacheHandle rules eval -> AlphaBetaParams -> GameRecord -> Checkers ()
 doLearn rules eval var params gameRec = do
-    let board = initBoardFromTags (SomeRules rules) (grTags gameRec)
-    $info "Initial board: {}; tags: {}" (show board, show $ grTags gameRec)
+    let startBoard = initBoardFromTags (SomeRules rules) (grTags gameRec)
+    $info "Initial board: {}; tags: {}" (show startBoard, show $ grTags gameRec)
     forM_ (instructionsToMoves $ grMoves gameRec) $ \moves -> do
-      -- liftIO $ print moves
-      go board [] moves
+      (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 _ _ [] = return ()
-    go board0 predicted (moveRec : rest) = do
-      (board1, predict2) <- do
+    go (score, boards) lastBoard _ [] = return (score, lastBoard : boards)
+    go (score0, boards) board0 predicted (moveRec : rest) = do
+      (board1, predict2, score2) <- do
         case mrFirst moveRec of
-          Nothing -> return (board0, [])
+          Nothing -> return (board0, [], score0)
           Just rec -> do
             let move1 = parseMoveRec rules First board0 rec
             if move1 `elem` predicted
               then Metrics.increment "learn.hit"
               else Metrics.increment "learn.miss"
             let (board1, _,_) = applyMove rules First move1 board0
-            predict2 <- processMove rules eval var params Second move1 board1
-            return (board1, predict2)
+            (predict2, score2) <- processMove rules eval var params Second move1 board1
+            return (board1, predict2, score2)
       case mrSecond moveRec of
-        Nothing -> return ()
+        Nothing -> return (score2, board0 : board1 : boards)
         Just rec -> do
           let move2 = parseMoveRec rules Second board1 rec
           if move2 `elem` predict2
             then Metrics.increment "learn.hit"
             else Metrics.increment "learn.miss"
           let (board2, _, _) = applyMove rules Second move2 board1
-          predict1 <- processMove rules eval var params First move2 board2
-          go board2 predict1 rest
+          (predict1, score1) <- processMove rules eval var params First move2 board2
+          go (score1, board0 : board1 : boards) board2 predict1 rest
 
-processMove :: (GameRules rules, Evaluator eval) => rules -> eval -> AICacheHandle rules eval -> AlphaBetaParams -> Side -> Move -> Board -> Checkers [Move]
+processMove :: (GameRules rules, Evaluator eval)
+            => rules
+            -> eval
+            -> AICacheHandle rules eval
+            -> AlphaBetaParams
+            -> Side
+            -> Move
+            -> Board
+            -> Checkers ([Move], Score)
 processMove rules eval var params side move board = do
   let ai = AlphaBeta params rules eval
   (moves, score) <- runAI ai var side board
   $info "Processed: side {}, move: {}, depth: {} => score {}; we think next best moves are: {}" (show side, show move, abDepth params, show score, show moves)
-  return moves
+  return (moves, score)
 
 learnPdn :: (GameRules rules, Evaluator eval) => AlphaBeta rules eval -> FilePath -> Checkers ()
 learnPdn ai@(AlphaBeta params rules eval) path = do

src/Main.hs

@@ -36,7 +36,7 @@ main = do
       let rules = russian
           eval = ai
           params = def {
-                     abDepth = 6
+                     abDepth = 4
                    , abCombinationDepth = 9
                    }
           ai = AlphaBeta params rules (dfltEvaluator rules)