a classic game implemented using Happstack+Fay+Acid-State

root / MasterMind / Server / Acid.hs

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
  ])