module Game.LambdaHack.Client.Action
(
MonadClient( getClient, getsClient, putClient, modifyClient, saveClient )
, MonadClientUI
, MonadClientReadServer(..), MonadClientWriteServer(..)
, MonadClientAbort( abortWith, tryWith )
, SessionUI(..), ConnFrontend(..), connFrontend
, abort, abortIfWith, neverMind
, tryRepeatedlyWith, tryIgnore, tryWithSlide
, mkConfigUI
, askBinding, getPerFid
, msgAdd, msgReset, recordHistory
, getKeyOverlayCommand, getInitConfirms
, displayFrames, displayMore, displayYesNo, displayChoiceUI
, promptToSlideshow, overlayToSlideshow
, drawOverlay, animate
, restoreGame, removeServerSave, displayPush, scoreToSlideshow
, rndToAction, getArenaUI, getLeaderUI
, targetToPos, partAidLeader, partActorLeader
, debugPrint
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception.Assert.Sugar
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 NLP.Miniutter.English as MU
import System.Directory
import System.FilePath
import System.Time
import Game.LambdaHack.Client.Action.ActionClass
import Game.LambdaHack.Client.Binding
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.HumanCmd
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 qualified Game.LambdaHack.Common.ConfigIO as ConfigIO
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 qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Frontend as Frontend
debugPrint :: MonadClient m => Text -> m ()
debugPrint t = do
sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli
when sdbgMsgCli $ liftIO $ Save.delayPrint t
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)
}
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` "can't catch failure with message"
`twith` msg)
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
=> ColorMode -> [K.KM] -> Slideshow -> m Bool
getInitConfirms dm frontClear slides = do
ConnFrontend{..} <- getsSession sfconn
frontSlides <- mapM (drawOverlay dm) $ runSlideshow slides
case frontSlides of
[] -> return True
[x] -> do
displayFrame False $ Just x
return True
_ -> do
writeConnFrontend Frontend.FrontSlides{..}
km <- readConnFrontend
return $! km /= K.escKey
getLeaderUI :: MonadClientUI m => m ActorId
getLeaderUI = do
cli <- getClient
case _sleader cli of
Nothing -> assert `failure` "leader expected but not found" `twith` 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
side <- getsClient sside
factionD <- getsState sfactionD
let fact = factionD EM.! side
case gquit fact of
Just Status{stDepth} -> return $ toEnum stDepth
Nothing -> do
dungeon <- getsState sdungeon
let (minD, maxD) =
case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "empty dungeon" `twith` dungeon
return $ max minD $ min maxD $ playerEntry $ gplayer fact
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` "no perception at given level"
`twith` (lid, fper))
$ 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
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.escKey
]
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
slides <- promptToSlideshow $ prompt <+> moreMsg
getInitConfirms dm [] $ slides Monoid.<> toSlideshow [[]]
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.escKey ]
++ 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
Level{lysize} <- getLevel lid
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
restoreGame :: MonadClient m => m (Maybe (State, StateClient))
restoreGame = do
Kind.COps{corule} <- getsState scops
let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
side <- getsClient sside
isAI <- getsClient sisAI
prefix <- getsClient $ ssavePrefixCli . sdebugCli
ConfigUI{ configAppDataDir
, configUICfgFile } <- getsClient sconfigUI
let copies = [(configUICfgFile <.> ".default", configUICfgFile <.> ".ini")]
name = fromMaybe "save" prefix <.> saveName side isAI
liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile
removeServerSave :: MonadClient m => m ()
removeServerSave = do
prefix <- getsClient $ ssavePrefixCli . sdebugCli
ConfigUI{configAppDataDir} <- getsClient sconfigUI
let serverSaveFile = configAppDataDir
</> fromMaybe "save" prefix
<.> serverSaveName
liftIO $ renameFile serverSaveFile (serverSaveFile ++ ".bkp")
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} <- getLevel arena
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]
snoAnim <- getsClient $ snoAnim . sdebugCli
return $ if fromMaybe False snoAnim
then [Just basicFrame]
else renderAnim lxsize lysize basicFrame anim
partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part
partActorLeader aid b = do
mleader <- getsClient _sleader
return $! case mleader of
Just leader | aid == leader -> "you"
_ -> partActor b
partAidLeader :: MonadClient m => ActorId -> m MU.Part
partAidLeader aid = do
b <- getsState $ getActorBody aid
partActorLeader aid b
parseConfigUI :: FilePath -> ConfigIO.CP -> ConfigUI
parseConfigUI dataDir cp =
let mkKey s =
case K.keyTranslate s of
K.Unknown _ ->
assert `failure` "unknown config file key" `twith` (s, cp)
key -> key
mkKM ('C':'T':'R':'L':'-':s) = K.KM {key=mkKey s, modifier=K.Control}
mkKM s = K.KM {key=mkKey s, modifier=K.NoModifier}
configCommands =
let mkCommand (key, def) = (mkKM key, read def :: HumanCmd)
section = ConfigIO.getItems cp "commands"
in map mkCommand section
configAppDataDir = dataDir
configUICfgFile = "config.ui"
configSavePrefix = ConfigIO.get cp "file" "savePrefix"
configMacros =
let trMacro (from, to) =
let fromTr = mkKM from
toTr = mkKM to
in if fromTr == toTr
then assert `failure` "degenerate alias" `twith` toTr
else (fromTr, toTr)
section = ConfigIO.getItems cp "macros"
in map trMacro section
configFont = ConfigIO.get cp "ui" "font"
configHistoryMax = ConfigIO.get cp "ui" "historyMax"
configMaxFps = ConfigIO.get cp "ui" "maxFps"
configNoAnim = ConfigIO.get cp "ui" "noAnim"
in ConfigUI{..}
mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI
mkConfigUI corule = do
let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule
dataDir <- ConfigIO.appDataDir
cpUI <- ConfigIO.mkConfig cpUIDefault $ dataDir </> "config.ui.ini"
let conf = parseConfigUI dataDir cpUI
return $! deepseq conf conf