Skip to content

Commit ef4795c

Browse files
portnovportnov
committed
On statistics usage.
refs #6.
1 parent 022747b commit ef4795c

File tree

6 files changed

+83
-28
lines changed

6 files changed

+83
-28
lines changed

‎src/AI/AlphaBeta/Cache.hs

+10-1
Original file line numberDiff line numberDiff line change
@@ -4,14 +4,17 @@
44
{-# LANGUAGE DeriveDataTypeable #-}
55
{-# LANGUAGE StandaloneDeriving #-}
66
{-# LANGUAGE TemplateHaskell #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
78

89
module AI.AlphaBeta.Cache where
910

1011
import Control.Monad
1112
import Control.Monad.State
1213
import Control.Monad.Reader
14+
import Control.Monad.Catch
1315
import Control.Concurrent
1416
import Control.Concurrent.STM
17+
import Control.Exception (SomeException)
1518
import qualified Control.Concurrent.ReadWriteLock as RWL
1619
import qualified Control.Monad.Metrics as Metrics
1720
import qualified Data.Map as M
@@ -176,7 +179,13 @@ lookupAiCache params board depth side handle = do
176179
return cached
177180
-- return $ Just $ CacheItemSide $ fixSign $ cisScore result
178181
Nothing -> do
179-
(mbCached, mbStats) <- runStorage handle $ event "file lookup" $ lookupFile board depth side
182+
(mbCached, mbStats) <-
183+
(runStorage handle $ event "file lookup" $ lookupFile board depth side)
184+
`catch`
185+
(\(e :: SomeException) -> do
186+
$reportError "Exception: lookupFile: {}" (Single $ show e)
187+
return (Nothing, Nothing)
188+
)
180189
let mbStats' = join $ checkStats `fmap` mbStats
181190
case (mbCached, mbStats') of
182191
(Nothing, Nothing) -> do

‎src/AI/AlphaBeta/Persistent.hs

+8-2
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ module AI.AlphaBeta.Persistent where
1212

1313
import Control.Monad
1414
import Control.Monad.State
15-
import Control.Monad.Catch (bracket_)
15+
import Control.Monad.Catch (bracket_, catch, SomeException)
1616
import qualified Control.Monad.Metrics as Metrics
1717
import Control.Concurrent.STM
1818
import qualified Control.Concurrent.ReadWriteLock as RWL
@@ -24,6 +24,7 @@ import qualified Data.IntSet as IS
2424
import Data.Word
2525
import qualified Data.Binary
2626
import qualified Data.Binary.Put
27+
import Data.Text.Format.Heavy
2728
import Data.Store
2829
import Data.Bits.Coded
2930
import Data.Bits.Coding
@@ -214,7 +215,7 @@ indexBlockSize :: BoardSize -> FileOffset
214215
indexBlockSize (nrows, ncols) = 256 * indexRecordSize
215216

216217
dataBlockSize :: FileOffset
217-
dataBlockSize = 512
218+
dataBlockSize = 128
218219

219220
calcIndexBlockOffset :: BoardSize -> IndexBlockNumber -> FileOffset
220221
calcIndexBlockOffset bsize n = indexHeaderSize + indexBlockSize bsize * fromIntegral n
@@ -356,6 +357,11 @@ putRecordFileB bstr newData = do
356357
let dataOffset = calcDataBlockOffset dataBlockNumber
357358
seek DataFile dataOffset
358359
oldData <- readDataSized DataFile
360+
`catch`
361+
(\(e :: SomeException) -> do
362+
$reportError "putRecordFileB: {}" (Single $ show e)
363+
return mempty
364+
)
359365
let newData' = oldData <> newData
360366
seek DataFile dataOffset
361367
writeDataSized DataFile newData'

‎src/Core/Board.hs

+17-1
Original file line numberDiff line numberDiff line change
@@ -157,14 +157,30 @@ isWithinBoard rules side board move = go (moveBegin move) (moveSteps move)
157157
Nothing -> False
158158

159159
allPassedAddresses :: GameRules rules => rules -> Side -> Board -> Move -> [Address]
160-
allPassedAddresses rules side board move = reverse $ go [] (moveBegin move) (moveSteps move)
160+
allPassedAddresses rules side board move = moveBegin move : (reverse $ go [] (moveBegin move) (moveSteps move))
161161
where
162162
go acc _ [] = acc
163163
go acc addr (step : steps) =
164164
case neighbour (myDirection rules side (sDirection step)) addr of
165165
Just addr' -> go (addr' : acc) addr' steps
166166
Nothing -> error $ "allPassedAddresses: invalid step: " ++ show step
167167

168+
allPassedLabels :: GameRules rules => rules -> Side -> Board -> Move -> [Label]
169+
allPassedLabels rules side board move = map aLabel $ allPassedAddresses rules side board move
170+
171+
nonCaptureLabels :: GameRules rules => rules -> Side -> Board -> Move -> [Label]
172+
nonCaptureLabels rules side board move = map aLabel $
173+
moveBegin move : (reverse $ go [] (moveBegin move) (moveSteps move))
174+
where
175+
go acc _ [] = acc
176+
go acc addr (step : steps) =
177+
case neighbour (myDirection rules side (sDirection step)) addr of
178+
Just addr' ->
179+
if sCapture step
180+
then go acc addr' steps
181+
else go (addr' : acc) addr' steps
182+
Nothing -> error $ "nonCaptureLabels: invalid step: " ++ show step
183+
168184
isMyPiece :: Side -> Piece -> Bool
169185
isMyPiece side (Piece _ s) = side == s
170186

‎src/Formats/Pdn.hs

+25-12
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,15 @@
11
{-# LANGUAGE DeriveDataTypeable #-}
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE TypeFamilies #-}
4+
{-# LANGUAGE RecordWildCards #-}
45

56
module Formats.Pdn where
67

78
import Control.Monad
89
import Control.Monad.State
910
import Data.Char
1011
import Data.Maybe
12+
import Data.List
1113
import qualified Data.Map as M
1214
import qualified Data.Text as T
1315
import Text.Megaparsec hiding (Label, State)
@@ -44,13 +46,15 @@ pSemiMove rules = try full <|> try short
4446
x <- oneOf ['-', 'x']
4547
let capture = (x == 'x')
4648
to <- pLabel rules
47-
return $ SemiMoveRec from to capture
49+
return $ ShortSemiMoveRec from to capture
4850

4951
full = do
50-
from <- pLabel rules
52+
first <- pLabel rules
53+
char 'x'
54+
second <- pLabel rules
5155
char 'x'
52-
labels <- pLabel rules `sepBy1` char 'x'
53-
return $ SemiMoveRec from (last labels) True
56+
rest <- pLabel rules `sepBy1` char 'x'
57+
return $ FullSemiMoveRec (first : second : rest)
5458

5559
whitespace :: Parser ()
5660
whitespace = label "white space or comment" $ do
@@ -202,13 +206,22 @@ parsePdnFile dfltRules path = do
202206
parseMoveRec :: GameRules rules => rules -> Side -> Board -> SemiMoveRec -> Move
203207
parseMoveRec rules side board rec =
204208
let moves = possibleMoves rules side board
205-
suits m = aLabel (pmBegin m) == smrFrom rec &&
206-
aLabel (pmEnd m) == smrTo rec &&
207-
(not $ null $ pmVictims m) == smrCapture rec
209+
passedFields m = nonCaptureLabels rules side board (pmMove m)
210+
suits m =
211+
case rec of
212+
ShortSemiMoveRec {..} ->
213+
aLabel (pmBegin m) == smrFrom &&
214+
aLabel (pmEnd m) == smrTo &&
215+
(not $ null $ pmVictims m) == smrCapture
216+
FullSemiMoveRec {..} ->
217+
(not $ null $ pmVictims m) &&
218+
smrLabels `isSubsequenceOf` passedFields m
208219
in case filter suits moves of
209220
[m] -> pmMove m
210-
[] -> error $ printf "no such move: %s; side: %s; board: %s" (show rec) (show side) (show board)
211-
ms -> error $ "ambigous move: " ++ show ms
221+
[] -> error $ printf "no such move: %s; side: %s; board: %s; possible: %s"
222+
(show rec) (show side) (show board) (show $ map passedFields moves)
223+
ms -> error $ printf "ambigous move: %s; candidates are: %s; board: %s"
224+
(show rec) (show ms) (show board)
212225

213226
fenFromTags :: [Tag] -> Maybe Fen
214227
fenFromTags [] = Nothing
@@ -359,7 +372,7 @@ gameToPdn game =
359372

360373
translateMove :: SomeRules -> Side -> Board -> Move -> SemiMoveRec
361374
translateMove (SomeRules rules) side board move =
362-
SemiMoveRec {
375+
ShortSemiMoveRec {
363376
smrFrom = aLabel (moveBegin move)
364377
, smrTo = aLabel (moveEnd rules side board move)
365378
, smrCapture = isCapture move
@@ -379,9 +392,9 @@ showPdn (SomeRules rules) gr =
379392
showMove n (MoveRec (Just s1) Nothing) = T.pack (show n) <> ". " <> showSemiMove s1
380393
showMove n (MoveRec (Just s1) (Just s2)) = T.pack (show n) <> ". " <> showSemiMove s1 <> " " <> showSemiMove s2
381394

382-
showSemiMove (SemiMoveRec from to False) =
395+
showSemiMove (ShortSemiMoveRec from to False) =
383396
boardNotation rules from <> "-" <> boardNotation rules to
384-
showSemiMove (SemiMoveRec from to True) =
397+
showSemiMove (ShortSemiMoveRec from to True) =
385398
boardNotation rules from <> "x" <> boardNotation rules to
386399

387400
showTag (Event text) = T.pack (printf "[Event \"%s\"]" text)

‎src/Formats/Types.hs

+12-6
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Formats.Types where
66

77
import Control.Monad.State
88
import qualified Data.Text as T
9+
import Data.List (intercalate)
910
import Data.Typeable
1011
import Text.Megaparsec hiding (Label, State)
1112
import Data.Void
@@ -29,17 +30,22 @@ data Tag =
2930
| Unknown T.Text T.Text
3031
deriving (Show, Typeable)
3132

32-
data SemiMoveRec = SemiMoveRec {
33-
smrFrom :: Label
34-
, smrTo :: Label
35-
, smrCapture :: Bool
36-
}
33+
data SemiMoveRec =
34+
FullSemiMoveRec {
35+
smrLabels :: [Label]
36+
}
37+
| ShortSemiMoveRec {
38+
smrFrom :: Label
39+
, smrTo :: Label
40+
, smrCapture :: Bool
41+
}
3742
deriving (Eq, Typeable)
3843

3944
instance Show SemiMoveRec where
40-
show r
45+
show (r@(ShortSemiMoveRec{}))
4146
| smrCapture r = show (smrFrom r) ++ "x" ++ show (smrTo r)
4247
| otherwise = show (smrFrom r) ++ "-" ++ show (smrTo r)
48+
show r = intercalate "x" $ map show (smrLabels r)
4349

4450
data MoveRec = MoveRec {
4551
mrFirst :: Maybe SemiMoveRec

‎src/Learn.hs

+11-6
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
11
{-# LANGUAGE TemplateHaskell #-}
22
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
34

45
module Learn where
56

67
import Control.Monad
78
import Control.Monad.State
89
import qualified Control.Monad.Metrics as Metrics
10+
import Control.Monad.Catch
911
import Data.Maybe
1012
import Data.Text.Format.Heavy
1113
import System.Log.Heavy
@@ -26,12 +28,15 @@ doLearn' rules eval var params gameRec = do
2628
let startBoard = initBoardFromTags (SomeRules rules) (grTags gameRec)
2729
let result = resultFromTags $ grTags gameRec
2830
$info "Initial board: {}; result: {}" (show startBoard, show result)
29-
forM_ (instructionsToMoves $ grMoves gameRec) $ \moves -> do
30-
let (endScore, allBoards) = go [] startBoard result moves
31-
$info "End score: {}" (Single endScore)
32-
runStorage var $ forM_ allBoards $ \board -> do
33-
let stats = Stats 1 endScore endScore endScore
34-
putStatsFile board stats
31+
forM_ (instructionsToMoves $ grMoves gameRec) $ \moves -> (do
32+
let (endScore, allBoards) = go [] startBoard result moves
33+
$info "End score: {}" (Single endScore)
34+
runStorage var $ forM_ allBoards $ \board -> do
35+
let stats = Stats 1 endScore endScore endScore
36+
putStatsFile board stats
37+
)
38+
`catch`
39+
(\(e :: SomeException) -> $reportError "Exception: {}" (Single $ show e))
3540
where
3641
go boards lastBoard (Just result) [] = (resultToScore result, lastBoard : boards)
3742
go boards lastBoard Nothing [] =

0 commit comments

Comments
 (0)