module Game.LambdaHack.Action
(
Action, getPerception, getCOps, getBinding, getConfigUI
, ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame, tryWithFrame
, abort, abortWith, abortIfWith, neverMind
, tryWith, tryRepeatedlyWith, tryIgnore
, getDiary, msgAdd, recordHistory
, getKeyCommand, getKeyFrameCommand, getOverConfirm
, displayMore, displayYesNo, displayOverAbort
, displayOverlays, displayChoiceUI, displayFramePush, drawPrompt
, startClip, remember, rememberList
, saveGameBkp, dumpCfg, endOrLoop, frontendName, startFrontend
, debug
) where
import Control.Monad
import Control.Monad.State hiding (State, state, liftIO)
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Map as M
import System.Time
import Data.Maybe
import Control.Concurrent
import Control.Exception (finally)
import Data.Text (Text)
import qualified Data.Text as T
import Game.LambdaHack.Action.ActionLift
import Game.LambdaHack.Perception
import Game.LambdaHack.Action.Frontend
import Game.LambdaHack.Draw
import Game.LambdaHack.Msg
import Game.LambdaHack.State
import Game.LambdaHack.Level
import Game.LambdaHack.Actor
import Game.LambdaHack.ActorState
import qualified Game.LambdaHack.Action.Save as Save
import qualified Game.LambdaHack.Kind as Kind
import qualified Game.LambdaHack.Key as K
import Game.LambdaHack.Binding
import Game.LambdaHack.Action.HighScore (register)
import Game.LambdaHack.Config
import qualified Game.LambdaHack.Action.ConfigIO as ConfigIO
import Game.LambdaHack.Animation (SingleFrame(..))
import Game.LambdaHack.Point
import qualified Game.LambdaHack.DungeonState as DungeonState
import Game.LambdaHack.Item
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Tile as Tile
tryWithFrame :: Action a -> ActionFrame a -> ActionFrame a
tryWithFrame exc h =
let msgToFrames "" = returnNoFrame ()
msgToFrames msg = do
msgReset ""
fr <- drawPrompt ColorFull msg
returnFrame fr
excMsg msg = do
((), frames) <- msgToFrames msg
a <- exc
return (a, frames)
in tryWith excMsg h
recordHistory :: Action ()
recordHistory = do
Diary{sreport, shistory} <- getDiary
unless (nullReport sreport) $ do
ConfigUI{configHistoryMax} <- getConfigUI
msgReset ""
historyReset $ takeHistory configHistoryMax $ addReport sreport shistory
getKeyCommand :: Maybe Bool -> Action (K.Key, K.Modifier)
getKeyCommand doPush = do
fs <- getFrontendSession
keyb <- getBinding
(nc, modifier) <- liftIO $ nextEvent fs doPush
return $ case modifier of
K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)
_ -> (nc, modifier)
getKeyFrameCommand :: SingleFrame -> Action (K.Key, K.Modifier)
getKeyFrameCommand frame = do
fs <- getFrontendSession
keyb <- getBinding
(nc, modifier) <- liftIO $ promptGetKey fs [] frame
return $ case modifier of
K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)
_ -> (nc, modifier)
getConfirm :: SingleFrame -> Action Bool
getConfirm frame = do
fs <- getFrontendSession
let keys = [ (K.Space, K.NoModifier), (K.Esc, K.NoModifier)]
(k, _) <- liftIO $ promptGetKey fs keys frame
case k of
K.Space -> return True
_ -> return False
getOverConfirm :: [SingleFrame] -> Action Bool
getOverConfirm [] = return True
getOverConfirm (x:xs) = do
b <- getConfirm x
if b
then getOverConfirm xs
else return False
getYesNo :: SingleFrame -> Action Bool
getYesNo frame = do
fs <- getFrontendSession
let keys = [ (K.Char 'y', K.NoModifier)
, (K.Char 'n', K.NoModifier)
, (K.Esc, K.NoModifier)
]
(k, _) <- liftIO $ promptGetKey fs keys frame
case k of
K.Char 'y' -> return True
_ -> return False
promptAdd :: Msg -> Msg -> Msg
promptAdd prompt msg = prompt <+> msg
displayMore :: ColorMode -> Msg -> Action Bool
displayMore dm prompt = do
let newPrompt = promptAdd prompt moreMsg
frame <- drawPrompt dm newPrompt
getConfirm frame
displayYesNo :: Msg -> Action Bool
displayYesNo prompt = do
frame <- drawPrompt ColorBW (promptAdd prompt yesnoMsg)
getYesNo frame
displayOverAbort :: Msg -> [Overlay] -> Action ()
displayOverAbort prompt xs = do
let newPrompt = promptAdd prompt ""
let f x = drawOverlay ColorFull newPrompt (x ++ [moreMsg])
frames <- mapM f xs
go <- getOverConfirm frames
when (not go) abort
displayOverlays :: Msg -> Msg -> [Overlay] -> ActionFrame ()
displayOverlays _ _ [] = returnNoFrame ()
displayOverlays prompt _ [x] = do
frame <- drawOverlay ColorFull prompt x
returnFrame frame
displayOverlays prompt pressKeys (x:xs) = do
frame <- drawOverlay ColorFull (promptAdd prompt pressKeys) (x ++ [moreMsg])
b <- getConfirm frame
if b
then displayOverlays prompt pressKeys xs
else returnNoFrame ()
displayChoiceUI :: Msg -> [Overlay] -> [(K.Key, K.Modifier)]
-> Action (K.Key, K.Modifier)
displayChoiceUI prompt ovs keys = do
let (over, rest, spc, more, keysS) = case ovs of
[] -> ([], [], "", [], keys)
[x] -> (x, [], "", [], keys)
x:xs -> (x, xs, ", SPACE", [moreMsg], (K.Space, K.NoModifier) : keys)
legalKeys = (K.Esc, K.NoModifier) : keysS
frame <- drawOverlay ColorFull (prompt <> spc <> ", ESC]") (over ++ more)
fs <- getFrontendSession
(key, modifier) <- liftIO $ promptGetKey fs legalKeys frame
case key of
K.Esc -> neverMind True
K.Space | not (null rest) -> displayChoiceUI prompt rest keys
_ -> return (key, modifier)
displayFramePush :: Maybe SingleFrame -> Action ()
displayFramePush mframe = do
fs <- getFrontendSession
liftIO $ displayFrame fs False mframe
drawPrompt :: ColorMode -> Msg -> Action SingleFrame
drawPrompt dm prompt = do
cops <- getCOps
per <- getPerception
s <- get
Diary{sreport} <- getDiary
let over = splitReport $ addMsg sreport prompt
return $ draw dm cops per s over
drawOverlay :: ColorMode -> Msg -> Overlay -> Action SingleFrame
drawOverlay dm prompt overlay = do
cops <- getCOps
per <- getPerception
s <- get
Diary{sreport} <- getDiary
let xsize = lxsize $ slevel s
msgPrompt = renderReport $ addMsg sreport prompt
over = padMsg xsize msgPrompt : overlay
return $ draw dm cops per s over
startClip :: Action () -> Action ()
startClip action =
withPerception $ do
remember
displayPush
action
displayPush :: Action ()
displayPush = do
fs <- getFrontendSession
s <- get
pl <- gets splayer
frame <- drawPrompt ColorFull ""
let (_, Actor{bdir}, _) = findActorAnyLevel pl s
isRunning = isJust bdir
liftIO $ displayFrame fs isRunning $ Just frame
remember :: Action ()
remember = do
per <- getPerception
let vis = IS.toList (totalVisible per)
rememberList vis
rememberList :: [Point] -> Action ()
rememberList vis = do
Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getCOps
lvl <- gets slevel
let rememberTile = [(loc, lvl `at` loc) | loc <- vis]
unknownId = ouniqGroup "unknown space"
newClear (loc, tk) = lvl `rememberAt` loc == unknownId
&& Tile.isExplorable cotile tk
clearN = length $ filter newClear rememberTile
modify (updateLevel (updateLRMap (Kind.// rememberTile)))
modify (updateLevel (\ l@Level{lseen} -> l {lseen = lseen + clearN}))
let alt Nothing = Nothing
alt (Just ([], _)) = Nothing
alt (Just (t, _)) = Just (t, t)
rememberItem = IM.alter alt
modify (updateLevel (updateIMap (\ m -> foldr rememberItem m vis)))
saveGameBkp :: Action ()
saveGameBkp = do
state <- get
diary <- getDiary
configUI <- getConfigUI
liftIO $ Save.saveGameBkp configUI state diary
dumpCfg :: FilePath -> Action ()
dumpCfg fn = do
config <- gets sconfig
liftIO $ ConfigIO.dump config fn
handleScores :: Bool -> Status -> Int -> Action ()
handleScores write status total =
when (total /= 0) $ do
configUI <- getConfigUI
time <- gets stime
curDate <- liftIO getClockTime
let score = register configUI write total time curDate status
(placeMsg, slideshow) <- liftIO score
displayOverAbort placeMsg slideshow
endOrLoop :: Action () -> Action ()
endOrLoop handleTurn = do
squit <- gets squit
Kind.COps{coitem} <- getCOps
s <- get
configUI <- getConfigUI
let (_, total) = calculateTotal coitem s
case squit of
Nothing -> handleTurn
Just (_, status@Camping) -> do
mv <- liftIO newEmptyMVar
liftIO $ void $ forkIO (Save.saveGameFile configUI s
`finally` putMVar mv ())
tryIgnore $ do
handleScores False status total
void $ displayMore ColorFull "See you soon, stronger and braver!"
liftIO $ takeMVar mv
Just (showScreens, status@Killed{}) -> do
Diary{sreport} <- getDiary
unless (nullReport sreport) $ do
void $ displayMore ColorBW "Who would have thought?"
recordHistory
tryWith
(\ finalMsg ->
let highScoreMsg = "Let's hope another party can save the day!"
msg = if T.null finalMsg then highScoreMsg else finalMsg
in void $ displayMore ColorBW msg
)
(do
when showScreens $ handleScores True status total
go <- displayMore ColorBW "Next time will be different."
when (not go) $ abortWith "You could really win this time."
restartGame handleTurn
)
Just (showScreens, status@Victor) -> do
Diary{sreport} <- getDiary
unless (nullReport sreport) $ do
void $ displayMore ColorFull "Brilliant, wasn't it?"
recordHistory
when showScreens $ do
tryIgnore $ handleScores True status total
void $ displayMore ColorFull "Can it be done better, though?"
restartGame handleTurn
Just (_, Restart) -> do
void $ displayMore ColorBW "This time for real."
restartGame handleTurn
restartGame :: Action () -> Action ()
restartGame handleTurn = do
configUI <- getConfigUI
cops <- getCOps
state <- gameResetAction configUI cops
modify $ const state
saveGameBkp
handleTurn
gameReset :: ConfigUI -> Kind.COps -> IO State
gameReset configUI cops@Kind.COps{ coitem
, corule
, cofact=Kind.Ops{opick}} = do
(configRules, dungeonGen, startingGen) <- ConfigIO.mkConfigRules corule
let (DungeonState.FreshDungeon{..}, gen2) =
runState (DungeonState.generate cops configRules) dungeonGen
(sflavour, gen3) = runState (dungeonFlavourMap coitem) gen2
factionName = configFaction configRules
sfaction = evalState (opick factionName (const True)) gen3
let state = defaultState configRules sfaction sflavour freshDungeon
entryLevel entryLoc startingGen
hstate = initialHeroes cops entryLoc configUI state
return hstate
gameResetAction :: ConfigUI -> Kind.COps -> Action State
gameResetAction configUI cops = liftIO $ gameReset configUI cops
startFrontend :: Kind.COps -> (ConfigUI -> Binding (ActionFrame ()))
-> Action () -> IO ()
startFrontend !scops@Kind.COps{corule} stdBinding handleTurn = do
sconfigUI <- ConfigIO.mkConfigUI corule
let !sbinding = stdBinding sconfigUI
font = configFont sconfigUI
handleGame = do
handleTurn
diary <- getDiary
liftIO $ Save.rmBkpSaveDiary sconfigUI diary
loop sfs = start Session{..} handleGame
startup font loop
speedupCops :: Session -> Session
speedupCops sess@Session{scops = cops@Kind.COps{cotile=tile}} =
let ospeedup = Tile.speedup tile
cotile = tile {Kind.ospeedup}
scops = cops {Kind.cotile}
in sess {scops}
start :: Session -> Action () -> IO ()
start slowSess handleGame = do
let sess@Session{scops = cops@Kind.COps{corule}, sconfigUI} =
speedupCops slowSess
title = rtitle $ Kind.stdRuleset corule
pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
restored <- Save.restoreGame sconfigUI pathsDataFile title
case restored of
Right (diary, msg) -> do
state <- gameReset sconfigUI cops
handlerToIO sess state
diary{sreport = singletonReport msg}
handleGame
Left (state, diary, msg) ->
handlerToIO sess state
diary{sreport = singletonReport msg}
handleGame
debug :: Text -> Action ()
debug _x = return ()