module Game.LambdaHack.Client.Action
(
MonadClient( getClient, getsClient, putClient, modifyClient )
, MonadClientUI
, MonadConnClient( getConn )
, MonadClientAbort( abortWith, tryWith )
, SessionUI(..), ConnFrontend(..), connFrontend
, ConnServer(..), connServer
, abort, abortIfWith, neverMind
, tryRepeatedlyWith, tryIgnore, tryWithSlide
, mkConfigUI
, askBinding, getPerFid
, msgAdd, msgReset, recordHistory
, getKeyOverlayCommand, getInitConfirms
, displayFrames, displayMore, displayYesNo, displayChoiceUI
, promptToSlideshow, overlayToSlideshow
, drawOverlay, animate
, clientGameSave, restoreGame, displayPush, scoreToSlideshow
, rndToAction, getArenaUI, getLeaderUI
, targetToPos, partAidLeader, partActorLeader
, debugPrint
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import qualified Control.Monad.State as St
import Control.Monad.Writer.Strict (WriterT, lift, tell)
import qualified Data.EnumMap.Strict as EM
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Monoid as Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified NLP.Miniutter.English as MU
import System.IO (hFlush, stderr)
import qualified System.Random as R
import System.Time
import Game.LambdaHack.Client.Action.ActionClass
import Game.LambdaHack.Client.Action.ConfigIO
import qualified Game.LambdaHack.Client.Action.Save as Save
import Game.LambdaHack.Client.Binding
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Animation
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.HighScore as HighScore
import qualified Game.LambdaHack.Common.Key as K
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Frontend as Frontend
import Game.LambdaHack.Utils.Assert
debugPrint :: MonadClient m => Text -> m ()
debugPrint t = do
debug <- getsClient sdebugCli
when debug $ liftIO $ do
delay <- R.randomRIO (0, 1000000)
threadDelay delay
T.hPutStrLn stderr t
hFlush stderr
connFrontend :: FactionId -> Frontend.ChanFrontend -> ConnFrontend
connFrontend fid fromF = ConnFrontend
{ readConnFrontend =
liftIO $ atomically $ readTQueue fromF
, writeConnFrontend = \efr -> do
let toF = Frontend.toMulti Frontend.connMulti
liftIO $ atomically $ writeTQueue toF (fid, efr)
}
connServer :: ChanServer c -> ConnServer c
connServer ChanServer{..} = ConnServer
{ readConnServer = liftIO . atomically . readTQueue $ fromServer
, writeConnServer = liftIO . atomically . writeTQueue toServer
}
abort :: MonadClientAbort m => m a
abort = abortWith ""
abortIfWith :: MonadClientAbort m => Bool -> Msg -> m a
abortIfWith True msg = abortWith msg
abortIfWith False _ = abortWith ""
neverMind :: MonadClientAbort m => Bool -> m a
neverMind b = abortIfWith b "never mind"
tryRepeatedlyWith :: MonadClientAbort m => (Msg -> m ()) -> m () -> m ()
tryRepeatedlyWith exc m =
tryWith (\msg -> exc msg >> tryRepeatedlyWith exc m) m
tryIgnore :: MonadClientAbort m => m () -> m ()
tryIgnore =
tryWith (\msg -> unless (T.null msg)
$ assert `failure` msg <+> "in tryIgnore")
tryWithSlide :: (MonadClientAbort m, MonadClientUI m)
=> m a -> WriterT Slideshow m a -> WriterT Slideshow m a
tryWithSlide exc h =
let excMsg msg = do
msgReset ""
slides <- promptToSlideshow msg
tell slides
lift exc
in tryWith excMsg h
displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m ()
displayFrame isRunning mf = do
ConnFrontend{writeConnFrontend} <- getsSession sfconn
let frame = case mf of
Nothing -> AcDelay
Just fr | isRunning -> AcRunning fr
Just fr -> AcNormal fr
writeConnFrontend $ Frontend.FrontFrame frame
promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM
promptGetKey frontKM frontFr = do
ConnFrontend{..} <- getsSession sfconn
writeConnFrontend Frontend.FrontKey {..}
readConnFrontend
getInitConfirms :: MonadClientUI m => [K.KM] -> Slideshow -> m Bool
getInitConfirms frontClear slides = do
ConnFrontend{..} <- getsSession sfconn
frontSlides <- mapM (drawOverlay ColorFull) $ runSlideshow slides
case frontSlides of
[] -> return True
[x] -> do
displayFrame False $ Just x
return True
_ -> do
writeConnFrontend Frontend.FrontSlides{..}
km <- readConnFrontend
return $! km /= K.KM {key=K.Esc, modifier=K.NoModifier}
getLeaderUI :: MonadClientUI m => m ActorId
getLeaderUI = do
cli <- getClient
case _sleader cli of
Nothing -> assert `failure` cli
Just leader -> return leader
getArenaUI :: MonadClientUI m => m LevelId
getArenaUI = do
mleader <- getsClient _sleader
case mleader of
Just leader -> getsState $ blid . getActorBody leader
Nothing -> do
dungeon <- getsState sdungeon
case EM.minViewWithKey dungeon of
Just ((s, _), _) -> return s
Nothing -> assert `failure` dungeon
targetToPos :: MonadClientUI m => m (Maybe Point)
targetToPos = do
mleader <- getsClient _sleader
case mleader of
Nothing -> return Nothing
Just leader -> do
scursor <- getsClient scursor
lid <- getsState $ blid . getActorBody leader
target <- getsClient $ getTarget leader
case target of
Just (TPos pos) -> return $ Just pos
Just (TEnemy a _ll) -> do
mem <- getsState $ memActor a lid
if mem then do
pos <- getsState $ bpos . getActorBody a
return $ Just pos
else return Nothing
Nothing -> return scursor
askBinding :: MonadClientUI m => m Binding
askBinding = getsSession sbinding
msgAdd :: MonadClientUI m => Msg -> m ()
msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}
msgReset :: MonadClient m => Msg -> m ()
msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}
recordHistory :: MonadClient m => m ()
recordHistory = do
StateClient{sreport, shistory} <- getClient
unless (nullReport sreport) $ do
ConfigUI{configHistoryMax} <- getsClient sconfigUI
msgReset ""
let nhistory = takeHistory configHistoryMax $! addReport sreport shistory
modifyClient $ \cli -> cli {shistory = nhistory}
getPerFid :: MonadClient m => LevelId -> m Perception
getPerFid lid = do
fper <- getsClient sfper
return $! fromMaybe (assert `failure` lid) $ EM.lookup lid fper
getKeyOverlayCommand :: MonadClientUI m => Overlay -> m K.KM
getKeyOverlayCommand overlay = do
frame <- drawOverlay ColorFull overlay
keyb <- askBinding
liftIO $ threadDelay 1000
km <- promptGetKey [] frame
return $! fromMaybe km $ M.lookup km $ kmacro keyb
getConfirm :: MonadClientUI m => [K.KM] -> SingleFrame -> m Bool
getConfirm = Frontend.getConfirmGeneric promptGetKey
displayFrames :: MonadClientUI m => Frames -> m ()
displayFrames = mapM_ (displayFrame False)
getYesNo :: MonadClientUI m => SingleFrame -> m Bool
getYesNo frame = do
let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier}
, K.KM {key=K.Char 'n', modifier=K.NoModifier}
, K.KM {key=K.Esc, modifier=K.NoModifier}
]
K.KM {key} <- promptGetKey keys frame
case key of
K.Char 'y' -> return True
_ -> return False
displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayMore dm prompt = do
sli <- promptToSlideshow $ prompt <+> moreMsg
frame <- drawOverlay dm $ head $ runSlideshow sli
getConfirm [] frame
displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayYesNo dm prompt = do
sli <- promptToSlideshow $ prompt <+> yesnoMsg
frame <- drawOverlay dm $ head $ runSlideshow sli
getYesNo frame
displayChoiceUI :: (MonadClientAbort m, MonadClientUI m)
=> Msg -> Overlay -> [K.KM] -> m K.KM
displayChoiceUI prompt ov keys = do
slides <- fmap runSlideshow $ overlayToSlideshow (prompt <> ", ESC]") ov
let legalKeys =
[ K.KM {key=K.Space, modifier=K.NoModifier}
, K.KM {key=K.Esc, modifier=K.NoModifier} ]
++ keys
loop [] = neverMind True
loop (x : xs) = do
frame <- drawOverlay ColorFull x
km@K.KM {..} <- promptGetKey legalKeys frame
case key of
K.Esc -> neverMind True
K.Space -> loop xs
_ -> return km
loop slides
promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow
promptToSlideshow prompt = overlayToSlideshow prompt []
overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow
overlayToSlideshow prompt overlay = do
lid <- getArenaUI
lysize <- getsLevel lid lysize
sreport <- getsClient sreport
let msg = splitReport (addMsg sreport prompt)
return $! splitOverlay lysize msg overlay
drawOverlay :: MonadClientUI m => ColorMode -> Overlay -> m SingleFrame
drawOverlay dm over = do
cops <- getsState scops
stgtMode <- getsClient stgtMode
arena <- getArenaUI
let lid = maybe arena tgtLevelId stgtMode
mleader <- getsClient _sleader
s <- getState
cli <- getClient
per <- getPerFid lid
return $! draw dm cops per lid mleader cli s over
displayPush :: MonadClientUI m => m ()
displayPush = do
sls <- promptToSlideshow ""
let slide = head $ runSlideshow sls
frame <- drawOverlay ColorFull slide
srunning <- getsClient srunning
displayFrame (isJust srunning) $ Just frame
scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow
scoreToSlideshow total status = do
table <- getsState shigh
time <- getsState stime
date <- liftIO getClockTime
let showScore (ntable, pos) = HighScore.slideshow ntable pos status
return $! maybe Monoid.mempty showScore
$ HighScore.register table total time status date
saveName :: FactionId -> Bool -> String
saveName side isAI =
let n = fromEnum side
in (if n > 0
then "human_" ++ show n
else "computer_" ++ show (n))
++ if isAI then ".ai.sav" else ".ui.sav"
clientGameSave :: MonadClient m => Bool -> m ()
clientGameSave toBkp = do
s <- getState
cli <- getClient
configUI <- getsClient sconfigUI
side <- getsClient sside
isAI <- getsClient sisAI
liftIO $ Save.saveGameCli (saveName side isAI) toBkp configUI s cli
restoreGame :: MonadClient m => m (Either (State, StateClient, Msg) Msg)
restoreGame = do
Kind.COps{corule} <- getsState scops
configUI <- getsClient sconfigUI
let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
title = rtitle $ Kind.stdRuleset corule
side <- getsClient sside
isAI <- getsClient sisAI
let sName = saveName side isAI
liftIO $ Save.restoreGameCli sName configUI pathsDataFile title
rndToAction :: MonadClient m => Rnd a -> m a
rndToAction r = do
g <- getsClient srandom
let (a, ng) = St.runState r g
modifyClient $ \cli -> cli {srandom = ng}
return a
animate :: MonadClientUI m => LevelId -> Animation -> m Frames
animate arena anim = do
cops <- getsState scops
sreport <- getsClient sreport
mleader <- getsClient _sleader
Level{lxsize, lysize} <- getsLevel arena id
cli <- getClient
s <- getState
per <- getPerFid arena
let over = renderReport sreport
topLineOnly = truncateMsg lxsize over
basicFrame = draw ColorFull cops per arena mleader cli s [topLineOnly]
return $ renderAnim lxsize lysize basicFrame anim
partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part
partActorLeader aid b = do
Kind.COps{coactor} <- getsState scops
mleader <- getsClient _sleader
return $! case mleader of
Just leader | aid == leader -> "you"
_ -> partActor coactor b
partAidLeader :: MonadClient m => ActorId -> m MU.Part
partAidLeader aid = do
b <- getsState $ getActorBody aid
partActorLeader aid b