module Game.LambdaHack.Action
(
ActionFun, Action, handlerToIO, rndToAction
, ActionFrame, returnNoFrame, whenFrame, inFrame
, Session(..), getCOps, getBinding
, abort, abortWith, abortIfWith, neverMind
, tryWith, tryWithFrame, tryRepeatedlyWith, tryIgnore, tryIgnoreFrame
, getDiary, msgAdd, recordHistory
, getKeyCommand, getKeyChoice, getOverConfirm
, displayMore, displayYesNo, displayOverAbort
, displayOverlays, displayChoiceUI, displayFramePush, drawPrompt
, startClip, remember, rememberList
, getPerception, updateAnyActor, updatePlayerBody
, currentDate, saveGameBkp, dumpCfg, shutGame
, 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 qualified Data.List as L
import System.Time
import Data.Maybe
import Control.Concurrent
import Control.Exception (finally)
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Perception
import Game.LambdaHack.Display
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.Save as Save
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Random
import qualified Game.LambdaHack.Key as K
import Game.LambdaHack.Binding
import qualified Game.LambdaHack.HighScore as H
import qualified Game.LambdaHack.Config as Config
import qualified Game.LambdaHack.Color as Color
import Game.LambdaHack.Point
import Game.LambdaHack.Time
type ActionFun r a =
Session
-> DungeonPerception
-> (State -> Diary -> a -> IO r)
-> (Msg -> IO r)
-> State
-> Diary
-> IO r
newtype Action a = Action
{ runAction :: forall r . ActionFun r a
}
instance Show (Action a) where
show _ = "an action"
instance Monad Action where
return = returnAction
(>>=) = bindAction
instance Functor Action where
fmap f (Action g) = Action (\ s p k a st ms ->
let k' st' ms' = k st' ms' . f
in g s p k' a st ms)
instance MonadState State Action where
get = Action (\ _s _p k _a st ms -> k st ms st)
put nst = Action (\ _s _p k _a _st ms -> k nst ms ())
returnAction :: a -> Action a
returnAction x = Action (\ _s _p k _a st m -> k st m x)
bindAction :: Action a -> (a -> Action b) -> Action b
bindAction m f = Action (\ s p k a st ms ->
let next nst nm x =
runAction (f x) s p k a nst nm
in runAction m s p next a st ms)
liftIO :: IO a -> Action a
liftIO x = Action (\ _s _p k _a st ms -> x >>= k st ms)
handlerToIO :: Session -> State -> Diary -> Action () -> IO ()
handlerToIO sess@Session{scops} state diary h =
runAction h
sess
(dungeonPerception scops state)
(\ _ _ x -> return x)
(\ msg ->
ioError $ userError $ "unhandled abort " ++ msg)
state
diary
rndToAction :: Rnd a -> Action a
rndToAction r = do
g <- gets srandom
let (a, ng) = runState r g
modify (\ state -> state {srandom = ng})
return a
type ActionFrame a = Action (a, [Maybe Color.SingleFrame])
returnNoFrame :: a -> ActionFrame a
returnNoFrame a = return (a, [])
whenFrame :: Bool -> ActionFrame () -> ActionFrame ()
whenFrame True x = x
whenFrame False _ = returnNoFrame ()
inFrame :: Action () -> ActionFrame ()
inFrame act = act >> returnNoFrame ()
data Session = Session
{ sfs :: FrontendSession
, scops :: Kind.COps
, skeyb :: Binding (ActionFrame ())
}
getFrontendSession :: Action FrontendSession
getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs)
getCOps :: Action Kind.COps
getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops)
getBinding :: Action (Binding (ActionFrame ()))
getBinding = Action (\ Session{skeyb} _p k _a st ms -> k st ms skeyb)
abort :: Action a
abort = abortWith ""
abortWith :: Msg -> Action a
abortWith msg = Action (\ _s _p _k a _st _ms -> a msg)
abortIfWith :: Bool -> Msg -> Action a
abortIfWith True msg = abortWith msg
abortIfWith False _ = abortWith ""
neverMind :: Bool -> Action a
neverMind b = abortIfWith b "never mind"
tryWith :: (Msg -> Action a) -> Action a -> Action a
tryWith exc h = Action (\ s p k a st ms ->
let runA msg = runAction (exc msg) s p k a st ms
in runAction h s p k runA st ms)
tryWithFrame :: Action a -> ActionFrame a -> ActionFrame a
tryWithFrame exc h =
let msgToFrames "" = returnNoFrame ()
msgToFrames msg = do
msgReset ""
fr <- drawPrompt ColorFull msg
return ((), [Just fr])
excMsg msg = do
((), frames) <- msgToFrames msg
a <- exc
return (a, frames)
in tryWith excMsg h
tryRepeatedlyWith :: (Msg -> Action ()) -> Action () -> Action ()
tryRepeatedlyWith exc h =
tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h
tryIgnore :: Action () -> Action ()
tryIgnore =
tryWith (\ msg -> if null msg
then return ()
else assert `failure` (msg, "in tryIgnore"))
tryIgnoreFrame :: ActionFrame () -> ActionFrame ()
tryIgnoreFrame =
tryWith (\ msg -> if null msg
then returnNoFrame ()
else assert `failure` (msg, "in tryIgnoreFrame"))
getDiary :: Action Diary
getDiary = Action (\ _s _p k _a st diary -> k st diary diary)
msgAdd :: Msg -> Action ()
msgAdd nm = Action (\ _s _p k _a st ms ->
k st ms{sreport = addMsg (sreport ms) nm} ())
historyReset :: History -> Action ()
historyReset shistory = Action (\ _s _p k _a st Diary{sreport} ->
k st Diary{..} ())
msgReset :: Msg -> Action ()
msgReset nm = Action (\ _s _p k _a st ms ->
k st ms{sreport = singletonReport nm} ())
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)
getKeyChoice :: [(K.Key, K.Modifier)] -> Color.SingleFrame
-> Action (K.Key, K.Modifier)
getKeyChoice keys frame = do
fs <- getFrontendSession
liftIO $ promptGetKey fs keys frame
getConfirm :: Color.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 :: [Color.SingleFrame] -> Action Bool
getOverConfirm [] = return True
getOverConfirm (x:xs) = do
b <- getConfirm x
if b
then getOverConfirm xs
else return False
getYesNo :: Color.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
displayMore :: ColorMode -> Msg -> Action Bool
displayMore dm prompt = do
frame <- drawPrompt dm (prompt ++ moreMsg)
getConfirm frame
displayYesNo :: Msg -> Action Bool
displayYesNo prompt = do
frame <- drawPrompt ColorBW (prompt ++ yesnoMsg)
getYesNo frame
displayOverAbort :: Msg -> [Overlay] -> Action ()
displayOverAbort prompt xs = do
let f x = drawOverlay ColorFull prompt (x ++ [moreMsg])
frames <- mapM f xs
b <- getOverConfirm frames
when (not b) abort
displayOverlays :: Msg -> [Overlay] -> ActionFrame ()
displayOverlays _ [] = returnNoFrame ()
displayOverlays prompt [x] = do
frame <- drawOverlay ColorFull prompt x
return $ ((), [Just frame])
displayOverlays prompt (x:xs) = do
frame <- drawOverlay ColorFull prompt (x ++ [moreMsg])
b <- getConfirm frame
if b
then displayOverlays prompt 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)
frame <- drawOverlay ColorFull (prompt ++ spc ++ ", ESC]") (over ++ more)
(key, modifier) <- getKeyChoice ((K.Esc, K.NoModifier) : keysS) frame
case key of
K.Esc -> neverMind True
K.Space | not (null rest) -> displayChoiceUI prompt rest keys
_ -> return (key, modifier)
displayFramePush :: Maybe Color.SingleFrame -> Action ()
displayFramePush mframe = do
fs <- getFrontendSession
liftIO $ displayFrame fs False mframe
drawPrompt :: ColorMode -> Msg -> Action Color.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 Color.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
lvl <- gets slevel
let rememberTile = [(loc, lvl `at` loc) | loc <- vis]
modify (updateLevel (updateLRMap (Kind.// rememberTile)))
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)))
withPerception :: Action () -> Action ()
withPerception h =
Action (\ sess@Session{scops} _ k a st ms ->
runAction h sess (dungeonPerception scops st) k a st ms)
getPerception :: Action Perception
getPerception = Action (\ _s per k _a s ms ->
k s ms (fromJust $ L.lookup (slid s) per))
updateAnyActor :: ActorId -> (Actor -> Actor) -> Action ()
updateAnyActor actor f = modify (updateAnyActorBody actor f)
updatePlayerBody :: (Actor -> Actor) -> Action ()
updatePlayerBody f = do
pl <- gets splayer
updateAnyActor pl f
currentDate :: Action ClockTime
currentDate = liftIO getClockTime
saveGameBkp :: State -> Diary -> Action ()
saveGameBkp state diary = liftIO $ Save.saveGameBkp state diary
dumpCfg :: FilePath -> Config.CP -> Action ()
dumpCfg fn config = liftIO $ Config.dump fn config
handleScores :: Bool -> H.Status -> Int -> Action ()
handleScores write status total =
when (total /= 0) $ do
config <- gets sconfig
time <- gets stime
curDate <- currentDate
let points = case status of
H.Killed _ -> (total + 1) `div` 2
_ -> total
let score = H.ScoreRecord points (timeNegate time) curDate status
(placeMsg, slideshow) <- liftIO $ H.register config write score
displayOverAbort placeMsg slideshow
shutGame :: (Bool, H.Status) -> Action ()
shutGame (showEndingScreens, status) = do
Kind.COps{coitem} <- getCOps
s <- get
diary <- getDiary
let (_, total) = calculateTotal coitem s
case status of
H.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
H.Killed _ | showEndingScreens -> do
Diary{sreport} <- getDiary
unless (nullReport sreport) $ do
void $ displayMore ColorFull "Who would have thought?"
recordHistory
tryIgnore $ do
handleScores True status total
void $ displayMore ColorFull
"Let's hope another party can save the day!"
H.Victor | showEndingScreens -> do
Diary{sreport} <- getDiary
unless (nullReport sreport) $ do
void $ displayMore ColorFull "Brilliant, wasn't it?"
recordHistory
tryIgnore $ do
handleScores True status total
void $ displayMore ColorFull "Can it be done better, though?"
_ -> return ()
fs <- getFrontendSession
liftIO $ do
Save.rmBkpSaveDiary s diary
shutdown fs
debug :: String -> Action ()
debug _x = return ()