module Game.LambdaHack.Client
( cmdClientAISem, cmdClientUISem
, loopAI, loopUI, exeFrontend
, MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer
) where
import Control.Monad
import Data.Maybe
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.AtomicSemCli
import Game.LambdaHack.Client.Binding
import Game.LambdaHack.Client.ClientSem
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.LoopAction
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Animation (DebugModeCli (..))
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import Game.LambdaHack.Frontend
import Control.Exception.Assert.Sugar
storeUndo :: MonadClient m => Atomic -> m ()
storeUndo _atomic =
maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})
$ Nothing
cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdSerTakeTime m)
=> CmdClientAI -> m ()
cmdClientAISem cmd = case cmd of
CmdAtomicAI cmdA -> do
cmds <- cmdAtomicFilterCli cmdA
mapM_ cmdAtomicSemCli cmds
mapM_ execCmdAtomic cmds
mapM_ (storeUndo . CmdAtomic) cmds
CmdQueryAI aid -> do
cmdC <- queryAI aid
writeServer cmdC
CmdPingAI ->
writeServer $ WaitSer $ toEnum (1)
cmdClientUISem :: ( MonadAtomic m, MonadClientAbort m
, MonadClientUI m, MonadClientWriteServer CmdSer m )
=> CmdClientUI -> m ()
cmdClientUISem cmd = case cmd of
CmdAtomicUI cmdA -> do
cmds <- cmdAtomicFilterCli cmdA
mapM_ cmdAtomicSemCli cmds
mapM_ execCmdAtomic cmds
mapM_ (drawCmdAtomicUI False) cmds
mapM_ (storeUndo . CmdAtomic) cmds
SfxAtomicUI sfx -> do
drawSfxAtomicUI False sfx
storeUndo $ SfxAtomic sfx
CmdQueryUI aid -> do
mleader <- getsClient _sleader
assert (isJust mleader `blame` "query without leader" `twith` cmd) skip
cmdH <- queryUI aid
writeServer cmdH
CmdPingUI -> do
snoMore <- getsClient $ snoMore . sdebugCli
when snoMore $ void $ displayMore ColorFull "Flushing frames."
writeServer $ TakeTimeSer $ WaitSer $ toEnum (1)
exeFrontend :: ( MonadAtomic m, MonadClientAbort m, MonadClientUI m
, MonadClientReadServer CmdClientUI m
, MonadClientWriteServer CmdSer m
, MonadAtomic n
, MonadClientReadServer CmdClientAI n
, MonadClientWriteServer CmdSerTakeTime n )
=> (m () -> SessionUI -> State -> StateClient
-> ChanServer CmdClientUI CmdSer
-> IO ())
-> (n () -> SessionUI -> State -> StateClient
-> ChanServer CmdClientAI CmdSerTakeTime
-> IO ())
-> Kind.COps -> DebugModeCli
-> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime
-> IO ())
-> IO ())
-> IO ()
exeFrontend executorUI executorAI
cops@Kind.COps{corule} sdebugCli exeServer = do
sconfigUI <- mkConfigUI corule
let !sbinding = stdBinding sconfigUI
sdebugMode =
(\dbg -> dbg {sfont =
sfont dbg `mplus` Just (configFont sconfigUI)}) .
(\dbg -> dbg {smaxFps =
smaxFps dbg `mplus` Just (configMaxFps sconfigUI)}) .
(\dbg -> dbg {snoAnim =
snoAnim dbg `mplus` Just (configNoAnim sconfigUI)}) .
(\dbg -> dbg {ssavePrefixCli =
ssavePrefixCli dbg `mplus` Just (configSavePrefix sconfigUI)})
$ sdebugCli
defHist <- defHistory
let exeClientUI = executorUI $ loopUI sdebugMode cmdClientUISem
exeClientAI = executorAI $ loopAI sdebugMode cmdClientAISem
cli = defStateClient defHist sconfigUI
s = updateCOps (const cops) emptyState
eClientAI fid =
let noSession = assert `failure` "AI client needs no UI session"
`twith` fid
in exeClientAI noSession s (cli fid True)
eClientUI fid fromF =
let sfconn = connFrontend fid fromF
in exeClientUI SessionUI{..} s (cli fid False)
startupF sdebugMode $ exeServer eClientUI eClientAI