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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | The implementation of our custom game client monads. Just as any other
-- component of the library, this implementation can be substituted.
module Implementation.MonadClientImplementation
( executorCli
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, CliState(..), CliImplementation(..)
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Concurrent
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Trans.State.Strict hiding (State)
import Game.LambdaHack.Atomic (MonadStateWrite (..))
import Game.LambdaHack.Client
import qualified Game.LambdaHack.Client.BfsM as BfsM
import Game.LambdaHack.Client.HandleAtomicM
import Game.LambdaHack.Client.HandleResponseM
import Game.LambdaHack.Client.LoopM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.MonadStateRead
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Server (ChanServer (..))
data CliState = CliState
{ cliState :: State -- ^ current global state
, cliClient :: StateClient -- ^ current client state
, cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients
, cliDict :: ChanServer -- ^ this client connection information
, cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI)
-- ^ connection to the save thread
}
-- | Client state transformation monad.
newtype CliImplementation a = CliImplementation
{ runCliImplementation :: StateT CliState IO a }
deriving (Monad, Functor, Applicative)
instance MonadStateRead CliImplementation where
{-# INLINE getsState #-}
getsState f = CliImplementation $ gets $ f . cliState
instance MonadStateWrite CliImplementation where
{-# INLINE modifyState #-}
modifyState f = CliImplementation $ state $ \cliS ->
let !newCliS = cliS {cliState = f $ cliState cliS}
in ((), newCliS)
{-# INLINE putState #-}
putState newCliState = CliImplementation $ state $ \cliS ->
let !newCliS = cliS {cliState = newCliState}
in ((), newCliS)
instance MonadClientRead CliImplementation where
{-# INLINE getsClient #-}
getsClient f = CliImplementation $ gets $ f . cliClient
liftIO = CliImplementation . IO.liftIO
instance MonadClient CliImplementation where
{-# INLINE modifyClient #-}
modifyClient f = CliImplementation $ state $ \cliS ->
let !newCliS = cliS {cliClient = f $ cliClient cliS}
in ((), newCliS)
instance MonadClientSetup CliImplementation where
saveClient = CliImplementation $ do
toSave <- gets cliToSave
cli <- gets cliClient
msess <- gets cliSession
IO.liftIO $ Save.saveToChan toSave (cli, msess)
instance MonadClientUI CliImplementation where
{-# INLINE getsSession #-}
getsSession f = CliImplementation $ gets $ f . fromJust . cliSession
{-# INLINE modifySession #-}
modifySession f = CliImplementation $ state $ \cliS ->
let !newCliSession = f $ fromJust $ cliSession cliS
!newCliS = cliS {cliSession = Just newCliSession}
in ((), newCliS)
updateClientLeader aid = do
s <- getState
modifyClient $ updateLeader aid s
getCacheBfs = BfsM.getCacheBfs
getCachePath = BfsM.getCachePath
instance MonadClientReadResponse CliImplementation where
receiveResponse = CliImplementation $ do
ChanServer{responseS} <- gets cliDict
IO.liftIO $ takeMVar responseS
instance MonadClientWriteRequest CliImplementation where
sendRequestAI scmd = CliImplementation $ do
ChanServer{requestAIS} <- gets cliDict
IO.liftIO $ putMVar requestAIS scmd
sendRequestUI scmd = CliImplementation $ do
ChanServer{requestUIS} <- gets cliDict
IO.liftIO $ putMVar (fromJust requestUIS) scmd
clientHasUI = CliImplementation $ do
mSession <- gets cliSession
return $! isJust mSession
instance MonadClientAtomic CliImplementation where
{-# INLINE execUpdAtomic #-}
execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources
-- Don't catch anything; assume exceptions impossible.
{-# INLINE execPutState #-}
execPutState = putState
-- | Run the main client loop, with the given arguments and empty
-- initial states, in the @IO@ monad.
executorCli :: CCUI -> UIOptions -> ClientOptions -> Bool
-> COps
-> FactionId
-> ChanServer
-> IO ()
executorCli ccui sUIOptions clientOptions startsNewGame
cops@COps{corule} fid cliDict =
let cliSession | isJust (requestUIS cliDict) =
Just $ emptySessionUI sUIOptions
| otherwise = Nothing
stateToFileName (cli, _) =
ssavePrefixCli (soptions cli) <> Save.saveNameCli corule (sside cli)
totalState cliToSave = CliState
{ cliState = updateCOpsAndCachedData (const cops) emptyState
-- state is empty, so the cached data is left empty and untouched
, cliClient = emptyStateClient fid
, cliDict
, cliToSave
, cliSession
}
m = loopCli ccui sUIOptions clientOptions startsNewGame
exe = evalStateT (runCliImplementation m) . totalState
in Save.wrapInSaves cops stateToFileName exe
|
