module Game.LambdaHack.Client
( cmdClientAISem, cmdClientUISem, exeFrontend
, MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer
) where
import Control.Exception.Assert.Sugar
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.Content.RuleKind
import Game.LambdaHack.Frontend
storeUndo :: MonadClient m => Atomic -> m ()
storeUndo _atomic =
maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})
$ Nothing
cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdTakeTimeSer m)
=> CmdClientAI -> m ()
cmdClientAISem cmd = case cmd of
CmdAtomicAI cmdA -> do
cmds <- cmdAtomicFilterCli cmdA
mapM_ (\c -> cmdAtomicSemCli c
>> execCmdAtomic c) cmds
mapM_ (storeUndo . CmdAtomic) cmds
CmdQueryAI aid -> do
cmdC <- queryAI aid
writeServer cmdC
CmdPingAI ->
writeServer $ WaitSer $ toEnum (1)
cmdClientUISem :: ( MonadAtomic m, MonadClientUI m
, MonadClientWriteServer CmdSer m )
=> CmdClientUI -> m ()
cmdClientUISem cmd = case cmd of
CmdAtomicUI cmdA -> do
cmds <- cmdAtomicFilterCli cmdA
mapM_ (\c -> cmdAtomicSemCli c
>> execCmdAtomic c
>> drawCmdAtomicUI False c) 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 $ CmdTakeTimeSer $ WaitSer $ toEnum (1)
exeFrontend :: ( MonadAtomic m, MonadClientUI m
, MonadClientReadServer CmdClientUI m
, MonadClientWriteServer CmdSer m
, MonadAtomic n
, MonadClientReadServer CmdClientAI n
, MonadClientWriteServer CmdTakeTimeSer n )
=> (m () -> SessionUI -> State -> StateClient
-> ChanServer CmdClientUI CmdSer
-> IO ())
-> (n () -> SessionUI -> State -> StateClient
-> ChanServer CmdClientAI CmdTakeTimeSer
-> IO ())
-> Kind.COps -> DebugModeCli
-> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer
-> IO ())
-> IO ())
-> IO ()
exeFrontend executorUI executorAI
cops@Kind.COps{corule} sdebugCli exeServer = do
sconfigUI <- mkConfigUI corule
let stdRuleset = Kind.stdRuleset corule
!sbinding = stdBinding corule 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 (rsavePrefix stdRuleset)})
$ 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