1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
| {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, TemplateHaskell, TypeFamilies, RecordWildCards #-}
module MasterMind.Server.Acid where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State
import Data.Acid
import Data.Data
import Data.SafeCopy
import Data.Map (Map)
import qualified Data.Map as Map
import MasterMind.Shared.Core
import MasterMind.Server.Play
$(deriveSafeCopy 0 'base ''Color)
$(deriveSafeCopy 0 'base ''Guess)
$(deriveSafeCopy 0 'base ''ScorePeg)
$(deriveSafeCopy 0 'base ''Score)
$(deriveSafeCopy 0 'base ''Row)
$(deriveSafeCopy 0 'base ''GameId)
$(deriveSafeCopy 0 'base ''Game)
$(deriveSafeCopy 0 'base ''Board)
$(deriveSafeCopy 0 'base ''Status)
deriving instance Ord GameId
data Games = Games
{ games :: Map GameId Game
, nextGameId :: GameId
}
deriving (Data, Typeable)
$(deriveSafeCopy 0 'base ''Games)
initialGames :: Games
initialGames = Games
{ games = Map.empty
, nextGameId = GameId 1
}
addGuess :: GameId
-> Guess
-> Update Games (Maybe Row)
addGuess gid userGuess =
do g@Games{..} <-get
case Map.lookup gid games of
Nothing -> return Nothing
(Just game@Game{..}) ->
do let row = Row userGuess (scoreGuess correctGuess userGuess)
put $ g { games = Map.insert gid (game { board = Board (row : (rows board)) }) games }
return (Just row)
newGame :: Guess -- ^ correct guess for this game
-> Update Games GameId
newGame correctGuess =
do g@Games{..} <- get
let game = Game { correctGuess = correctGuess
, status = Undecided
, board = Board []
}
put $ g { games = Map.insert nextGameId game games
, nextGameId = GameId $ (unGameId nextGameId) + 1
}
return nextGameId
getSolution :: GameId
-> Query Games (Maybe Guess)
getSolution gid =
do g@Games{..} <- ask
return $ correctGuess <$> Map.lookup gid games
{-
addGuess :: GameId
-> Guess
-> Update Games (Maybe Row)
addGuess gid guess =
do g@Games{..} <- get
case Map.lookup gid games of
Nothing -> return Nothing
(Just game) ->
do let row = Row guess (scoreGuess solution guess)
put $ g { games = Map.insert gid (game { board = row : board }) }
-}
getBoard :: GameId
-> Query Games (Maybe Board)
getBoard bid =
do g@Games{..} <- ask
return $ board <$> (Map.lookup bid games)
$(makeAcidic ''Games
[ 'addGuess
, 'newGame
, 'getSolution
, 'getBoard
])
|