module Game.LambdaHack.Action
(
Action, getPerception, getCOps, getBinding
, 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 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 qualified Game.LambdaHack.Config as 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
config <- gets sconfig
let historyMax = Config.get config "ui" "historyMax"
msgReset ""
historyReset $ takeHistory historyMax $ 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 "" 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
liftIO $ Save.saveGameBkp state diary
dumpCfg :: FilePath -> Config.CP -> Action ()
dumpCfg fn config = liftIO $ ConfigIO.dump fn config
handleScores :: Bool -> Status -> Int -> Action ()
handleScores write status total =
when (total /= 0) $ do
config <- gets sconfig
time <- gets stime
curDate <- liftIO getClockTime
let score = register config 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
let (_, total) = calculateTotal coitem s
case squit of
Nothing -> handleTurn
Just (_, status@Camping) -> do
mv <- liftIO newEmptyMVar
liftIO $ void $ forkIO (Save.saveGameFile 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 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
config <- getOrigConfig
cops <- getCOps
state <- gameResetAction config cops
modify $ const state
saveGameBkp
handleTurn
gameReset :: Config.CP -> Kind.COps -> IO State
gameReset config1 cops@Kind.COps{ coitem
, cofact=Kind.Ops{opick}} = do
(g2, config2) <- ConfigIO.getSetGen config1 "dungeonRandomGenerator"
let (DungeonState.FreshDungeon{..}, ag) =
runState (DungeonState.generate cops config2) g2
(sflavour, ag2) = runState (dungeonFlavourMap coitem) ag
factionName = Config.getOption config2 "heroes" "faction"
sfaction =
evalState
(opick (fromMaybe "playable" factionName) (const True)) ag2
(g3, config3) <- ConfigIO.getSetGen config2 "startingRandomGenerator"
let state =
defaultState
config3 sfaction sflavour freshDungeon entryLevel entryLoc g3
hstate = initialHeroes cops entryLoc state
return hstate
gameResetAction :: Config.CP -> Kind.COps -> Action State
gameResetAction config cops = liftIO $ gameReset config cops
startFrontend :: Kind.COps -> (Config.CP -> Binding (ActionFrame ()))
-> Action () -> IO ()
startFrontend !scops@Kind.COps{corule} stdBinding handleTurn = do
let configDefault = rconfigDefault $ Kind.stdRuleset corule
sconfig <- ConfigIO.mkConfig configDefault
let !sbinding = stdBinding sconfig
!sorigConfig = sconfig
configFont = fromMaybe "" $ Config.getOption sconfig "ui" "font"
handleGame = do
handleTurn
diary <- getDiary
liftIO $ Save.rmBkpSaveDiary sconfig diary
loop sfs = start sconfig Session{..} handleGame
startup configFont 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 :: Config.CP -> Session -> Action () -> IO ()
start config slowSess handleGame = do
let sess@Session{scops = cops@Kind.COps{ corule }} = speedupCops slowSess
title = rtitle $ Kind.stdRuleset corule
pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule
restored <- Save.restoreGame pathsDataFile config title
case restored of
Right (diary, msg) -> do
state <- gameReset config cops
handlerToIO sess state
diary{sreport = singletonReport msg}
handleGame
Left (state, diary, msg) ->
handlerToIO sess state
diary{sreport = singletonReport msg}
handleGame
debug :: String -> Action ()
debug _x = return ()