diff --git a/Game/LambdaHack/Action.hs b/Game/LambdaHack/Action.hs --- a/Game/LambdaHack/Action.hs +++ b/Game/LambdaHack/Action.hs @@ -1,46 +1,73 @@ --- TODO: Add an export list, with sections, after the file is rewritten --- according to #17. Perhaps make some types abstract. -- | Game action monad and basic building blocks -- for player and monster actions. {-# LANGUAGE MultiParamTypeClasses, RankNTypes #-} -module Game.LambdaHack.Action where +module Game.LambdaHack.Action + ( -- * Actions and basic operations + ActionFun, Action, handlerToIO, rndToAction + -- * Actions returning frames + , ActionFrame, returnNoFrame, whenFrame, inFrame + -- * Game session and its accessors + , Session(..), getCOps, getBinding + -- * Various ways to abort action + , abort, abortWith, abortIfWith, neverMind + -- * Abort exception handlers + , tryWith, tryWithFrame, tryRepeatedlyWith, tryIgnore, tryIgnoreFrame + -- * Diary and report + , getDiary, msgAdd, recordHistory + -- * Key input + , getKeyCommand, getKeyChoice, getOverConfirm + -- * Display each frame and confirm + , displayMore, displayYesNo, displayOverAbort + -- * Assorted frame operations + , displayOverlays, displayChoiceUI, displayFramePush, drawPrompt + -- * Clip init operations + , startClip, remember, rememberList + -- * Assorted operations + , getPerception, updateAnyActor, updatePlayerBody + -- * Assorted primitives + , currentDate, saveGameBkp, dumpCfg, shutGame + , debug + ) where import Control.Monad -import Control.Monad.State hiding (State, state) +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 System.IO (hPutStrLn, stderr) -- just for debugging +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 Game.LambdaHack.Content.ActorKind 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 - --- | The constant session information, not saved to the game save file. -data Session = Session - { sfs :: FrontendSession -- ^ frontend session information - , scops :: Kind.COps -- ^ game content - , skeyb :: Binding (Action ()) -- ^ binding of keys to commands - } +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 -- | The type of the function inside any action. -- (Separated from the @Action@ type to document each argument with haddock.) type ActionFun r a = Session -- ^ session setup data - -> (State -> Diary -> IO r) -- ^ shutdown continuation - -> Perception -- ^ cached perception + -> DungeonPerception -- ^ cached perception -> (State -> Diary -> a -> IO r) -- ^ continuation - -> IO r -- ^ failure/reset continuation + -> (Msg -> IO r) -- ^ failure/reset continuation -> State -- ^ current state -> Diary -- ^ current diary -> IO r @@ -60,39 +87,41 @@ (>>=) = bindAction instance Functor Action where - fmap f (Action g) = Action (\ s e p k a st ms -> + fmap f (Action g) = Action (\ s p k a st ms -> let k' st' ms' = k st' ms' . f - in g s e p k' a st ms) + 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 ()) + -- | Invokes the action continuation on the provided argument. returnAction :: a -> Action a -returnAction x = Action (\ _s _e _p k _a st m -> k st m x) +returnAction x = Action (\ _s _p k _a st m -> k st m x) -- | Distributes the session and shutdown continuation, -- threads the state and diary. bindAction :: Action a -> (a -> Action b) -> Action b -bindAction m f = Action (\ s e p k a st ms -> +bindAction m f = Action (\ s p k a st ms -> let next nst nm x = - runAction (f x) s e p k a nst nm - in runAction m s e p next a st ms) - -instance MonadIO Action where - liftIO x = Action (\ _s _e _p k _a st ms -> x >>= k st ms) + runAction (f x) s p k a nst nm + in runAction m s p next a st ms) -instance MonadState State Action where - get = Action (\ _s _e _p k _a st ms -> k st ms st) - put nst = Action (\ _s _e _p k _a _st ms -> k nst ms ()) +-- Instance commented out and action hiden, so that outside of this module +-- nobody can subvert Action by invoking arbitrary IO. +-- instance MonadIO Action where +liftIO :: IO a -> Action a +liftIO x = Action (\ _s _p k _a st ms -> x >>= k st ms) -- | Run an action, with a given session, state and diary, in the @IO@ monad. handlerToIO :: Session -> State -> Diary -> Action () -> IO () -handlerToIO sess@Session{sfs, scops} state diary h = +handlerToIO sess@Session{scops} state diary h = runAction h sess - (\ ns ndiary -> Save.rmBkpSaveDiary ns ndiary - >> shutdown sfs) -- get out of the game - (perception scops state) -- create and cache perception + (dungeonPerception scops state) -- create and cache perception (\ _ _ x -> return x) -- final continuation returns result - (ioError $ userError "unhandled abort") + (\ msg -> + ioError $ userError $ "unhandled abort " ++ msg) -- e.g., in AI code state diary @@ -104,203 +133,321 @@ modify (\ state -> state {srandom = ng}) return a --- | Invoke a session command. -session :: (Session -> Action a) -> Action a -session f = Action (\ sess e p k a st ms -> - runAction (f sess) sess e p k a st ms) - --- | Invoke a session @IO@ command. -sessionIO :: (Session -> IO a) -> Action a -sessionIO f = Action (\ sess _e _p k _a st ms -> f sess >>= k st ms) - --- | Display the current level with modified current msg. -displayGeneric :: ColorMode -> (Msg -> Msg) -> Action Bool -displayGeneric dm f = - Action (\ Session{sfs, scops} _e p k _a st ms -> - displayLevel dm sfs scops p st (f (smsg ms)) Nothing - >>= k st ms) - --- | Display the current level, with the current msg and color. -displayAll :: Action Bool -displayAll = displayGeneric ColorFull id - --- | Display an overlay on top of the current screen. -overlay :: String -> Action Bool -overlay txt = - Action (\ Session{sfs, scops} _e p k _a st ms -> - displayLevel ColorFull sfs scops p st (smsg ms) (Just txt) - >>= k st ms) - --- | Get the current diary. -currentDiary :: Action Diary -currentDiary = Action (\ _s _e _p k _a st diary -> k st diary diary) +-- | Actions and screen frames, including delays, resulting +-- from performing the actions. +type ActionFrame a = Action (a, [Maybe Color.SingleFrame]) --- | Wipe out and set a new value for the current diary. -diaryReset :: Diary -> Action () -diaryReset ndiary = Action (\ _s _e _p k _a st _diary -> k st ndiary ()) +-- | Return the value with an empty set of screen frames. +returnNoFrame :: a -> ActionFrame a +returnNoFrame a = return (a, []) --- | Get the current msg. -currentMsg :: Action Msg -currentMsg = Action (\ _s _e _p k _a st ms -> k st ms (smsg ms)) +-- | As the @when@ monad operation, but on type @ActionFrame ()@. +whenFrame :: Bool -> ActionFrame () -> ActionFrame () +whenFrame True x = x +whenFrame False _ = returnNoFrame () --- | Wipe out and set a new value for the current msg. -msgReset :: Msg -> Action () -msgReset nm = Action (\ _s _e _p k _a st ms -> k st ms{smsg = nm} ()) +-- | Inject action into actions with screen frames. +inFrame :: Action () -> ActionFrame () +inFrame act = act >> returnNoFrame () --- | Add to the current msg. -msgAdd :: Msg -> Action () -msgAdd nm = Action (\ _s _e _p k _a st ms -> - k st ms{smsg = addMsg (smsg ms) nm} ()) +-- | The constant session information, not saved to the game save file. +data Session = Session + { sfs :: FrontendSession -- ^ frontend session information + , scops :: Kind.COps -- ^ game content + , skeyb :: Binding (ActionFrame ()) -- ^ binding of keys to commands + } --- | Clear the current msg. -msgClear :: Action () -msgClear = Action (\ _s _e _p k _a st ms -> k st ms{smsg = ""} ()) +-- | Get the frontend session. +getFrontendSession :: Action FrontendSession +getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs) -- | Get the content operations. -contentOps :: Action Kind.COps -contentOps = Action (\ Session{scops} _e _p k _a st ms -> k st ms scops) - --- | Get the content operations modified by a function (usually a selector). -contentf :: (Kind.COps -> a) -> Action a -contentf f = Action (\ Session{scops} _e _p k _a st ms -> k st ms (f scops)) +getCOps :: Action Kind.COps +getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops) --- | End the game, i.e., invoke the shutdown continuation. -end :: Action () -end = Action (\ _s e _p _k _a s diary -> e s diary) +-- | Get the key binding. +getBinding :: Action (Binding (ActionFrame ())) +getBinding = Action (\ Session{skeyb} _p k _a st ms -> k st ms skeyb) -- | Reset the state and resume from the last backup point, i.e., invoke -- the failure continuation. abort :: Action a -abort = Action (\ _s _e _p _k a _st _ms -> a) +abort = abortWith "" +-- | Abort with the given message. +abortWith :: Msg -> Action a +abortWith msg = Action (\ _s _p _k a _st _ms -> a msg) + +-- | Abort and print the given msg if the condition is true. +abortIfWith :: Bool -> Msg -> Action a +abortIfWith True msg = abortWith msg +abortIfWith False _ = abortWith "" + +-- | Abort and conditionally print the fixed message. +neverMind :: Bool -> Action a +neverMind b = abortIfWith b "never mind" + -- | Set the current exception handler. First argument is the handler, -- second is the computation the handler scopes over. -tryWith :: Action () -> Action () -> Action () -tryWith exc h = Action (\ s e p k a st ms -> - let runA = runAction exc s e p k a st ms - in runAction h s e p k runA st ms) +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) +-- | Set the current exception handler. Apart of executing it, +-- draw and pass along a frame with the abort message, if any. +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 + -- | Take a handler and a computation. If the computation fails, the -- handler is invoked and then the computation is retried. -tryRepeatedlyWith :: Action () -> Action () -> Action () -tryRepeatedlyWith exc h = tryWith (exc >> tryRepeatedlyWith exc h) h +tryRepeatedlyWith :: (Msg -> Action ()) -> Action () -> Action () +tryRepeatedlyWith exc h = + tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h -- | Try the given computation and silently catch failure. -try :: Action () -> Action () -try = tryWith (return ()) +tryIgnore :: Action () -> Action () +tryIgnore = + tryWith (\ msg -> if null msg + then return () + else assert `failure` (msg, "in tryIgnore")) --- | Try the given computation until it succeeds without failure. -tryRepeatedly :: Action () -> Action () -tryRepeatedly = tryRepeatedlyWith (return ()) +-- | Try the given computation and silently catch failure, +-- returning empty set of screen frames. +tryIgnoreFrame :: ActionFrame () -> ActionFrame () +tryIgnoreFrame = + tryWith (\ msg -> if null msg + then returnNoFrame () + else assert `failure` (msg, "in tryIgnoreFrame")) --- | Debugging. -debug :: String -> Action () -debug _x = return () -- liftIO $ hPutStrLn stderr _x +-- | Get the current diary. +getDiary :: Action Diary +getDiary = Action (\ _s _p k _a st diary -> k st diary diary) --- | Print the given msg, then abort. -abortWith :: Msg -> Action a -abortWith msg = do - msgReset msg - displayAll - abort +-- | Add a message to the current report. +msgAdd :: Msg -> Action () +msgAdd nm = Action (\ _s _p k _a st ms -> + k st ms{sreport = addMsg (sreport ms) nm} ()) --- | Abort, and print the given msg if the condition is true. -abortIfWith :: Bool -> Msg -> Action a -abortIfWith True msg = abortWith msg -abortIfWith False _ = abortWith "" +-- | Wipe out and set a new value for the history. +historyReset :: History -> Action () +historyReset shistory = Action (\ _s _p k _a st Diary{sreport} -> + k st Diary{..} ()) --- | Abort conditionally, with a fixed message. -neverMind :: Bool -> Action a -neverMind b = abortIfWith b "never mind" +-- | Wipe out and set a new value for the current report. +msgReset :: Msg -> Action () +msgReset nm = Action (\ _s _p k _a st ms -> + k st ms{sreport = singletonReport nm} ()) +-- | Store current report in the history and reset report. +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 + +-- | Wait for a player command. +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) + -- | Wait for a player keypress. -nextCommand :: Session -> Action K.Key -nextCommand Session{sfs, skeyb} = do - nc <- liftIO $ nextEvent sfs - return $ fromMaybe nc $ M.lookup nc $ kmacro skeyb +getKeyChoice :: [(K.Key, K.Modifier)] -> Color.SingleFrame + -> Action (K.Key, K.Modifier) +getKeyChoice keys frame = do + fs <- getFrontendSession + liftIO $ promptGetKey fs keys frame +-- | Ignore unexpected kestrokes until a SPACE or ESC is pressed. +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 + +-- | A series of confirmations for all overlays. +getOverConfirm :: [Color.SingleFrame] -> Action Bool +getOverConfirm [] = return True +getOverConfirm (x:xs) = do + b <- getConfirm x + if b + then getOverConfirm xs + else return False + -- | A yes-no confirmation. -getYesNo :: Session -> Action Bool -getYesNo sess@Session{sfs} = do - e <- liftIO $ nextEvent sfs - case e of +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 - K.Char 'n' -> return False - K.Esc -> return False - _ -> getYesNo sess + _ -> return False --- | Waits for a SPACE or ESC. Passes along any other key, including RET, --- to an argument function. -getOptionalConfirm :: (Bool -> Action a) - -> (K.Key -> Action a) - -> Session - -> Action a -getOptionalConfirm h k Session{sfs} = do - e <- liftIO $ nextEvent sfs - case e of - K.Space -> h True - K.Esc -> h False - _ -> k e +-- | Display a msg with a @more@ prompt. Return value indicates if the player +-- tried to cancel/escape. +displayMore :: ColorMode -> Msg -> Action Bool +displayMore dm prompt = do + frame <- drawPrompt dm (prompt ++ moreMsg) + getConfirm frame --- | Ignore unexpected kestrokes until a SPACE or ESC is pressed. -getConfirm :: Session -> Action Bool -getConfirm Session{sfs} = liftIO $ getConfirmD sfs +-- | Print a yes/no question and return the player's answer. Use black +-- and white colours to turn player's attention to the choice. +displayYesNo :: Msg -> Action Bool +displayYesNo prompt = do + frame <- drawPrompt ColorBW (prompt ++ yesnoMsg) + getYesNo frame --- | Print msg, await confirmation. Return value indicates --- if the player tried to abort/escape. -msgMoreConfirm :: ColorMode -> Msg -> Action Bool -msgMoreConfirm dm msg = do - msgAdd (msg ++ more) - displayGeneric dm id - session getConfirm +-- | Print a msg and several overlays, one per page. +-- All frames require confirmations. Raise @abort@ if the players presses ESC. +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 --- | Print msg, await confirmation, ignore confirmation. -msgMore :: Msg -> Action () -msgMore msg = msgClear >> msgMoreConfirm ColorFull msg >> return () +-- | Print a msg and several overlays, one per page. +-- The last frame does not expect a confirmation. +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 () --- | Print a yes/no question and return the player's answer. -msgYesNo :: Msg -> Action Bool -msgYesNo msg = do - msgReset (msg ++ yesno) - displayGeneric ColorBW id -- turn player's attention to the choice - session getYesNo +-- | Print a prompt and an overlay and wait for a player keypress. +-- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls +-- (in some menus @?@ cycles views, so the user can restart from the top). +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) --- | Clear message and overlay. -clearDisplay :: Action Bool -clearDisplay = do - msgClear - displayAll - return False +-- | Push a frame or a single frame's worth of delay to the frame queue. +displayFramePush :: Maybe Color.SingleFrame -> Action () +displayFramePush mframe = do + fs <- getFrontendSession + liftIO $ displayFrame fs False mframe --- | Print a msg and several overlays, one per page, and await confirmation. --- The return value indicates if the player tried to abort/escape. -msgOverlaysConfirm :: Msg -> [String] -> Action Bool -msgOverlaysConfirm _msg [] = return True -msgOverlaysConfirm msg [x] = do - msgReset msg - b0 <- overlay (x ++ msgEnd) - if b0 - then return True - else clearDisplay -msgOverlaysConfirm msg (x:xs) = do - msgReset msg - b0 <- overlay (x ++ more) - if b0 - then do - b <- session getConfirm - if b - then msgOverlaysConfirm msg xs - else clearDisplay - else clearDisplay +-- | Draw the current level. The prompt is displayed, but not added +-- to history. The prompt is appended to the current message +-- and only the first screenful of the resulting overlay is displayed. +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 +-- | Draw the current level. The prompt and the overlay are displayed, +-- but not added to history. The prompt is appended to the current message +-- and only the first line of the result is displayed. +-- The overlay starts on the second line. +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 + +-- | Initialize perception, etc., display level and run the action. +startClip :: Action () -> Action () +startClip action = + -- Determine perception before running player command, in case monsters + -- have opened doors, etc. + withPerception $ do + remember -- heroes notice their surroundings, before they get displayed + displayPush -- draw the current surroundings + action -- let the actor act + +-- | Push the frame depicting the current level to the frame queue. +-- Only one screenful of the report is shown, the rest is ignored. +displayPush :: Action () +displayPush = do + fs <- getFrontendSession + s <- get + pl <- gets splayer + frame <- drawPrompt ColorFull "" + -- Visually speed up (by remving all empty frames) the show of the sequence + -- of the move frames if the player is running. + let (_, Actor{bdir}, _) = findActorAnyLevel pl s + isRunning = isJust bdir + liftIO $ displayFrame fs isRunning $ Just frame + +-- | Update player memory. +remember :: Action () +remember = do + per <- getPerception + let vis = IS.toList (totalVisible per) + rememberList vis + +-- | Update player at the given list of locations.. +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))) + -- | Update the cached perception for the given computation. withPerception :: Action () -> Action () -withPerception h = Action (\ sess@Session{scops} e _ k a st ms -> - runAction h sess e (perception scops st) k a st ms) +withPerception h = + Action (\ sess@Session{scops} _ k a st ms -> + runAction h sess (dungeonPerception scops st) k a st ms) -- | Get the current perception. -currentPerception :: Action Perception -currentPerception = Action (\ _s _e p k _a st ms -> k st ms p) +getPerception :: Action Perception +getPerception = Action (\ _s per k _a s ms -> + k s ms (fromJust $ L.lookup (slid s) per)) -- | Update actor stats. Works for actors on other levels, too. updateAnyActor :: ActorId -> (Actor -> Actor) -> Action () @@ -312,33 +459,84 @@ pl <- gets splayer updateAnyActor pl f --- | Advance the move time for the given actor. -advanceTime :: ActorId -> Action () -advanceTime actor = do - Kind.Ops{okind} <- contentf Kind.coactor - time <- gets stime - let upd m = m { btime = time + aspeed (okind (bkind m)) } - -- A hack to synchronize the whole party: - pl <- gets splayer - if actor == pl || isAHero actor - then do - modify (updateLevel (updateHeroes (IM.map upd))) - unless (isAHero pl) $ updatePlayerBody upd - else do - s <- get - -- If actor dead or not on current level, don't bother. - when (memActor actor s) $ updateAnyActor actor upd +-- | Obtains the current date and time. +currentDate :: Action ClockTime +currentDate = liftIO getClockTime --- | Add a turn to the player time counter. -playerAdvanceTime :: Action () -playerAdvanceTime = do - pl <- gets splayer - advanceTime pl +-- | Save the diary and a backup of the save game file, in case of crashes. +-- +-- See 'Save.saveGameBkp'. +saveGameBkp :: State -> Diary -> Action () +saveGameBkp state diary = liftIO $ Save.saveGameBkp state diary --- | Display command help. -displayHelp :: Action () -displayHelp = do - let disp Session{skeyb} = - msgOverlaysConfirm "Basic keys. [press SPACE or ESC]" $ keyHelp skeyb - session disp - abort +-- | Dumps the current configuration to a file. +-- +-- See 'Config.dump'. +dumpCfg :: FilePath -> Config.CP -> Action () +dumpCfg fn config = liftIO $ Config.dump fn config + +-- | Handle current score and display it with the high scores. +-- False if display of the scores was void or interrupted by the user. +-- +-- Warning: scores are shown during the game, +-- so we should be careful not to leak secret information through them +-- (e.g., the nature of the items through the total worth of inventory). +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 + +-- | End the game, shutting down the frontend. The boolean argument +-- tells if ending screens should be shown, the other arguments describes +-- the cause of shutdown. +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 + -- Save an display in parallel. + 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 -- wait until saved + H.Killed _ | showEndingScreens -> do + Diary{sreport} <- getDiary + unless (nullReport sreport) $ do + -- Sisplay any leftover report. Suggest it could be the cause of death. + void $ displayMore ColorFull "Who would have thought?" + recordHistory -- prevent repeating the report + 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 + -- Sisplay any leftover report. Suggest it could be the master move. + void $ displayMore ColorFull "Brilliant, wasn't it?" + recordHistory -- prevent repeating the report + tryIgnore $ do + handleScores True status total + void $ displayMore ColorFull "Can it be done better, though?" + _ -> return () + fs <- getFrontendSession + liftIO $ do + Save.rmBkpSaveDiary s diary -- save the diary often in case of crashes + shutdown fs + +-- | Debugging. +debug :: String -> Action () +debug _x = return () -- liftIO $ hPutStrLn stderr _x diff --git a/Game/LambdaHack/Actions.hs b/Game/LambdaHack/Actions.hs --- a/Game/LambdaHack/Actions.hs +++ b/Game/LambdaHack/Actions.hs @@ -24,8 +24,6 @@ import Game.LambdaHack.ActorState import Game.LambdaHack.Perception import Game.LambdaHack.State -import qualified Game.LambdaHack.Config as Config -import qualified Game.LambdaHack.Save as Save import qualified Game.LambdaHack.Effect as Effect import Game.LambdaHack.EffectAction import qualified Game.LambdaHack.Tile as Tile @@ -36,45 +34,29 @@ import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Random - -displayHistory :: Action () -displayHistory = do - diary <- currentDiary - msgOverlaysConfirm "History:" [unlines $ shistory diary] - abort - -dumpConfig :: Action () -dumpConfig = do - config <- gets sconfig - let fn = "config.dump" - liftIO $ Config.dump fn config - abortWith $ "Current configuration dumped to file " ++ fn ++ "." +import Game.LambdaHack.Msg +import Game.LambdaHack.Binding +import Game.LambdaHack.Time +import qualified Game.LambdaHack.Color as Color +import Game.LambdaHack.Draw saveGame :: Action () saveGame = do - b <- msgYesNo "Really save?" + b <- displayYesNo "Really save?" if b - then do - -- Save the game state - cops <- contentf Kind.coitem - state <- get - diary <- currentDiary - liftIO $ Save.saveGame state diary - let total = calculateTotal cops state - status = H.Camping - go <- handleScores False status total - when go $ msgMore "See you soon, stronger and braver!" - end + then modify (\ s -> s {squit = Just (True, H.Camping)}) else abortWith "Game resumed." quitGame :: Action () quitGame = do - b <- msgYesNo "Really quit?" + b <- displayYesNo "Really quit?" if b - then end -- no highscore display for quitters + then let status = H.Killed $ Dungeon.levelDefault 0 + -- No highscore display for quitters. + in modify (\ s -> s {squit = Just (False, status)}) else abortWith "Game resumed." -moveCursor :: Vector -> Int -> Action () +moveCursor :: Vector -> Int -> ActionFrame () moveCursor dir n = do lxsize <- gets (lxsize . slevel) lysize <- gets (lysize . slevel) @@ -89,11 +71,18 @@ -- TODO: Think about doing the mode dispatch elsewhere, especially if over -- time more and more commands need to do the dispatch inside their code -- (currently only a couple do). -move :: Vector -> Action () +move :: Vector -> ActionFrame () move dir = do pl <- gets splayer targeting <- gets (ctargeting . scursor) - if targeting /= TgtOff then moveCursor dir 1 else moveOrAttack True pl dir + if targeting /= TgtOff + then do + frs <- moveCursor dir 1 + -- Mark that unexpectedly it does not take time. + modify (\ s -> s {snoTime = True}) + return frs + else + inFrame $ moveOrAttack True pl dir ifRunning :: ((Vector, Int) -> Action a) -> Action a -> Action a ifRunning t e = do @@ -123,43 +112,41 @@ -- | Player tries to trigger a tile using a feature. bumpTile :: Point -> F.Feature -> Action () bumpTile dloc feat = do - cotile <- contentf Kind.cotile + Kind.COps{cotile} <- getCOps lvl <- gets slevel let t = lvl `at` dloc if Tile.hasFeature cotile feat t then triggerTile dloc else guessBump cotile feat t - playerAdvanceTime -- | Perform the action specified for the tile in case it's triggered. triggerTile :: Point -> Action () triggerTile dloc = do - Kind.Ops{okind, opick} <- contentf Kind.cotile + Kind.COps{cotile=Kind.Ops{okind, opick}} <- getCOps lvl <- gets slevel let f (F.Cause effect) = do pl <- gets splayer - (_b, _msg) <- effectToAction effect 0 pl pl 0 + void $ effectToAction effect 0 pl pl 0 return () f (F.ChangeTo group) = do - state <- get - let hms = levelHeroList state ++ levelMonsterList state + Level{lactor} <- gets slevel case lvl `atI` dloc of - [] -> if unoccupied hms dloc + [] -> if unoccupied (IM.elems lactor) dloc then do newTileId <- rndToAction $ opick group (const True) let adj = (Kind.// [(dloc, newTileId)]) modify (updateLevel (updateLMap adj)) +-- TODO: take care of AI using this function (aborts, etc.). else abortWith "blocked" -- by monsters or heroes _ : _ -> abortWith "jammed" -- by items f _ = return () mapM_ f $ TileKind.tfeature $ okind $ lvl `at` dloc -- | Ask for a direction and trigger a tile, if possible. -playerTriggerDir :: F.Feature -> Action () -playerTriggerDir feat = do - msgReset "direction?" - displayAll - e <- session nextCommand +playerTriggerDir :: F.Feature -> Verb -> Action () +playerTriggerDir feat verb = do + let keys = zip K.dirAllMoveKey $ repeat K.NoModifier + e <- displayChoiceUI ("What to " ++ verb ++ "? [movement key") [] keys lxsize <- gets (lxsize . slevel) K.handleDir lxsize e (playerBumpDir feat) (neverMind True) @@ -177,13 +164,13 @@ ploc <- gets (bloc . getPlayerBody) bumpTile ploc feat --- | An actor opens a door. Player (hero or controlled monster) or enemy. +-- | An actor opens a door: player (hero or controlled monster) or enemy. actorOpenDoor :: ActorId -> Vector -> Action () actorOpenDoor actor dir = do Kind.COps{ cotile , coitem , coactor=Kind.Ops{okind} - } <- contentOps + } <- getCOps lvl <- gets slevel pl <- gets splayer body <- gets (getActor actor) @@ -193,9 +180,9 @@ isPlayer = actor == pl isVerbose = isPlayer -- don't report, unless it's player-controlled iq = aiq $ okind $ bkind body - openPower = Tile.SecretStrength $ + openPower = timeScale timeTurn $ if isPlayer - then 1 -- player can't open hidden doors + then 0 -- player can't open hidden doors else case strongestSearch coitem bitems of Just i -> iq + jpower i Nothing -> iq @@ -207,13 +194,12 @@ Tile.hasFeature cotile F.Hidden t) then neverMind isVerbose -- not doors at all else triggerTile dloc - advanceTime actor -- | Change the displayed level in targeting mode to (at most) -- k levels shallower. Enters targeting mode, if not already in one. -tgtAscend :: Int -> Action () +tgtAscend :: Int -> ActionFrame () tgtAscend k = do - cotile <- contentf Kind.cotile + Kind.COps{cotile} <- getCOps cursor <- gets scursor targeting <- gets (ctargeting . scursor) slid <- gets slid @@ -231,7 +217,11 @@ abortWith "no more levels in this direction" Just (nln, nloc) -> assert (nln /= slid `blame` (nln, "stairs looped")) $ do - modify (\ state -> state {slid = nln}) + -- We only look at the level, but we have to keep current + -- time somewhere, e.g., for when we change the player + -- to a hero on this level and then end targeting. + -- If that's too slow, we could keep current time in the @Cursor@. + switchLevel nln -- do not freely reveal the other end of the stairs lvl2 <- gets slevel let upd cur = @@ -246,7 +236,7 @@ depth = Dungeon.depth dungeon nln = Dungeon.levelDefault $ min depth $ max 1 $ n - k when (nln == slid) $ abortWith "no more levels in this direction" - modify (\ state -> state {slid = nln}) + switchLevel nln -- see comment above let upd cur = cur {clocLn = nln} modify (updateCursor upd) when (targeting == TgtOff) $ do @@ -255,36 +245,40 @@ doLook -- | Switches current hero to the next hero on the level, if any, wrapping. +-- We cycle through at most 10 heroes (\@, 0--9). cycleHero :: Action () cycleHero = do pl <- gets splayer - hs <- gets (lheroes . slevel) - let i = case pl of AHero n -> n ; _ -> -1 - (lt, gt) = IM.split i hs - case IM.keys gt ++ IM.keys lt of + s <- get + let hs = map (tryFindHeroK s) [0..9] + i = fromMaybe (-1) $ L.findIndex (== Just pl) hs + (lt, gt) = (take i hs, drop (i + 1) hs) + case L.filter (flip memActor s) $ catMaybes gt ++ catMaybes lt of [] -> abortWith "Cannot select any other hero on this level." - ni : _ -> selectPlayer (AHero ni) - >>= assert `trueM` (pl, ni, "hero duplicated") + ni : _ -> selectPlayer ni + >>= assert `trueM` (pl, ni, "hero duplicated") -- | Search for hidden doors. search :: Action () search = do - Kind.COps{coitem, cotile} <- contentOps + Kind.COps{coitem, cotile} <- getCOps lvl <- gets slevel le <- gets (lsecret . slevel) lxsize <- gets (lxsize . slevel) ploc <- gets (bloc . getPlayerBody) pitems <- gets getPlayerItem - let delta = case strongestSearch coitem pitems of - Just i -> 1 + jpower i - Nothing -> 1 + let delta = timeScale timeTurn $ + case strongestSearch coitem pitems of + Just i -> 1 + jpower i + Nothing -> 1 searchTile sle mv = let loc = shift ploc mv t = lvl `at` loc - k = Tile.secretStrength (le IM.! loc) - delta + -- TODO: assert or cope elsewhere with the IM.! below + k = timeAdd (le IM.! loc) $ timeNegate delta in if Tile.hasFeature cotile F.Hidden t - then if k > 0 - then IM.insert loc (Tile.SecretStrength k) sle + then if k > timeZero + then IM.insert loc k sle else IM.delete loc sle else sle leNew = L.foldl' searchTile le (moves lxsize) @@ -296,7 +290,6 @@ when (Tile.hasFeature cotile F.Hidden t && IM.notMember dloc leNew) $ triggerTile dloc mapM_ triggerHidden (moves lxsize) - playerAdvanceTime -- | This function performs a move (or attack) by any actor, -- i.e., it can handle monsters, heroes and both. @@ -306,7 +299,7 @@ -> Action () moveOrAttack allowAttacks actor dir = do -- We start by looking at the target position. - cops@Kind.COps{cotile = cotile@Kind.Ops{okind}} <- contentOps + cops@Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getCOps state <- get pl <- gets splayer lvl <- gets slevel @@ -321,22 +314,22 @@ actorAttackActor actor target | accessible cops lvl sloc tloc -> do -- Switching positions requires full access. - actorRunActor actor target when (actor == pl) $ msgAdd $ lookAt cops False True state lvl tloc "" - | otherwise -> abortWith "" + actorRunActor actor target + | otherwise -> abortWith "blocked" Nothing | accessible cops lvl sloc tloc -> do - -- perform the move + -- Perform the move. updateAnyActor actor $ \ body -> body {bloc = tloc} when (actor == pl) $ msgAdd $ lookAt cops False True state lvl tloc "" - advanceTime actor | allowAttacks && actor == pl && Tile.canBeHidden cotile (okind $ lvl `rememberAt` tloc) -> do msgAdd "You search your surroundings." -- TODO: proper msg search - | otherwise -> actorOpenDoor actor dir -- try to open a door, TODO: playerBumpDir instead: TriggerDir { verb = "open", object = "door", feature = Openable } + | otherwise -> + actorOpenDoor actor dir -- try to open a door, TODO: bumpTile tloc F.Openable -- | Resolves the result of an actor moving into another. Usually this -- involves melee attack, but with two heroes it just changes focus. @@ -346,60 +339,90 @@ -- This function is analogous to projectGroupItem, but for melee -- and not using up the weapon. actorAttackActor :: ActorId -> ActorId -> Action () -actorAttackActor source@(AHero _) target@(AHero _) = - -- Select adjacent hero by bumping into him. Takes no time. - selectPlayer target - >>= assert `trueM` (source, target, "player bumps into himself") actorAttackActor source target = do - Kind.COps{coactor, coitem=coitem@Kind.Ops{opick, okind}} <- contentOps - state <- get - sm <- gets (getActor source) - tm <- gets (getActor target) - per <- currentPerception - bitems <- gets (getActorItem source) - let h2hGroup = if isAHero source then "unarmed" else "monstrous" - h2hKind <- rndToAction $ opick h2hGroup (const True) - let sloc = bloc sm - -- The picked bodily "weapon". - h2h = Item h2hKind 0 Nothing 1 - str = strongestSword coitem bitems - stack = fromMaybe h2h str - single = stack { jcount = 1 } - verb = iverbApply $ okind $ jkind single - -- The msg describes the source part of the action. - -- TODO: right now it also describes the victim and weapon; - -- perhaps, when a weapon is equipped, just say "you hit" or "you miss" - -- and then "nose dies" or "nose yells in pain". - msg = actorVerbActorExtra coactor sm verb tm $ - if isJust str - then " with " ++ objectItem coitem state single - else "" - visible = sloc `IS.member` totalVisible per - when visible $ msgAdd msg - -- Msgs inside itemEffectAction describe the target part. - itemEffectAction 0 source target single - advanceTime source + sm <- gets (getActor source) + tm <- gets (getActor target) + if bparty sm == heroParty && bparty tm == heroParty + then do + -- Select adjacent hero by bumping into him. Takes no time, so rewind. + selectPlayer target + >>= assert `trueM` (source, target, "player bumps into himself") + -- Mark that unexpectedly it does not take time. + modify (\ s -> s {snoTime = True}) + else do + cops@Kind.COps{coactor, coitem=coitem@Kind.Ops{opick, okind}} <- getCOps + state <- get + per <- getPerception + bitems <- gets (getActorItem source) + let h2hGroup = if isAHero state source then "unarmed" else "monstrous" + h2hKind <- rndToAction $ opick h2hGroup (const True) + let h2hItem = Item h2hKind 0 Nothing 1 + sloc = bloc sm + (stack, tell, verbosity, verb) = + if bparty sm `elem` allProjectiles + then assert (length bitems == 1) $ + (head bitems, False, 10, "hit") -- projectile + else case strongestSword cops bitems of + Nothing -> (h2hItem, False, 0, + iverbApply $ okind $ h2hKind) -- hand-to-hand + Just w -> (w, True, 0, + iverbApply $ okind $ jkind w) -- weapon + single = stack { jcount = 1 } + -- The msg describes the source part of the action. + -- TODO: right now it also describes the victim and weapon; + -- perhaps, when a weapon is equipped, just say "you hit" + -- or "you miss" and then "nose dies" or "nose yells in pain". + msg = actorVerbActor coactor sm verb tm $ + if tell + then "with " ++ objectItem coitem state single + else "" + visible = sloc `IS.member` totalVisible per + when visible $ msgAdd msg + -- Msgs inside itemEffectAction describe the target part. + itemEffectAction verbosity source target single -- | Resolves the result of an actor running (not walking) into another. -- This involves switching positions of the two actors. actorRunActor :: ActorId -> ActorId -> Action () actorRunActor source target = do - pl <- gets splayer - sloc <- gets (bloc . getActor source) -- source location - tloc <- gets (bloc . getActor target) -- target location + pl <- gets splayer + sm <- gets (getActor source) + tm <- gets (getActor target) + let sloc = bloc sm + tloc = bloc tm updateAnyActor source $ \ m -> m { bloc = tloc } updateAnyActor target $ \ m -> m { bloc = sloc } + cops@Kind.COps{coactor} <- getCOps + per <- getPerception + let visible = sloc `IS.member` totalVisible per || + tloc `IS.member` totalVisible per + msg = actorVerbActor coactor sm "displace" tm "" + when visible $ msgAdd msg + diary <- getDiary -- here diary possibly contains the new msg + s <- get + let locs = [tloc, sloc] + anim = map (IM.fromList . zip locs) + [ [Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) '.', + Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'o'] + , [Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) 'd', + Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'p'] + , [Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'p', + Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) 'd'] + , [Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'o'] + , [] + ] + animFrs = animate s diary cops per anim + when visible $ mapM_ displayFramePush $ Nothing : animFrs if source == pl - then stopRunning -- do not switch positions repeatedly - else when (isAMonster source) $ focusIfAHero target - advanceTime source + then stopRunning -- do not switch positions repeatedly + else void $ focusIfOurs target -- | Create a new monster in the level, at a random position. rollMonster :: Kind.COps -> Perception -> State -> Rnd State rollMonster Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} per state = do - let lvl = slevel state - hs = levelHeroList state - ms = levelMonsterList state + let lvl@Level{lactor} = slevel state + ms = hostileList state + hs = heroList state isLit = Tile.isLit cotile rc <- monsterGenChance (Dungeon.levelNumber $ slid state) (L.length ms) if not rc @@ -417,7 +440,7 @@ , \ l _ -> not $ l `IS.member` totalVisible per , distantAtLeast 5 , \ l t -> Tile.hasFeature cotile F.Walkable t - && l `notElem` L.map bloc (hs ++ ms) + && unoccupied (IM.elems lactor) l ] mk <- opick "monster" (const True) hp <- rollDice $ ahp $ okind mk @@ -426,9 +449,9 @@ -- | Generate a monster, possibly. generateMonster :: Action () generateMonster = do - cops <- contentOps + cops <- getCOps state <- get - per <- currentPerception + per <- getPerception nstate <- rndToAction $ rollMonster cops per state srandom <- gets srandom put $ nstate {srandom} @@ -438,17 +461,17 @@ regenerateLevelHP = do Kind.COps{ coitem , coactor=coactor@Kind.Ops{okind} - } <- contentOps + } <- getCOps time <- gets stime let upd itemIM a m = let ak = okind $ bkind m bitems = fromMaybe [] $ IM.lookup a itemIM - regen = max 10 $ + regen = max 1 $ aregen ak `div` case strongestRegen coitem bitems of Just i -> 5 * jpower i Nothing -> 1 - in if time `mod` regen /= 0 + in if (time `timeFit` timeTurn) `mod` regen /= 0 then m else addHp coactor 1 m -- We really want hero selection to be a purely UI distinction, @@ -456,7 +479,43 @@ -- Only the heroes on the current level regenerate (others are frozen -- in time together with their level). This prevents cheating -- via sending one hero to a safe level and waiting there. - hi <- gets (lheroItem . slevel) - modify (updateLevel (updateHeroes (IM.mapWithKey (upd hi)))) - mi <- gets (lmonItem . slevel) - modify (updateLevel (updateMonsters (IM.mapWithKey (upd mi)))) + hi <- gets (linv . slevel) + modify (updateLevel (updateActorDict (IM.mapWithKey (upd hi)))) + +-- | Display command help. +displayHelp :: ActionFrame () +displayHelp = do + keyb <- getBinding + displayOverlays "Basic keys. [press SPACE or ESC]" $ keyHelp keyb + +displayHistory :: ActionFrame () +displayHistory = do + Diary{shistory} <- getDiary + time <- gets stime + lysize <- gets (lysize . slevel) + let turn = show $ time `timeFit` timeTurn + msg = "Your adventuring lasts " ++ turn + ++ " half-second turns. Past messages:" + displayOverlays msg $ splitOverlay lysize $ renderHistory shistory + +dumpConfig :: Action () +dumpConfig = do + config <- gets sconfig + let fn = "config.dump" + msg = "Current configuration dumped to file " ++ fn ++ "." + dumpCfg fn config + abortWith msg + +redraw :: Action () +redraw = return () + +-- | Add new smell traces to the level. Only humans leave a strong scent. +addSmell :: Action () +addSmell = do + s <- get + pl <- gets splayer + let time = stime s + ploc = bloc (getPlayerBody s) + upd = IM.insert ploc $ timeAdd time $ smellTimeout s + when (isAHero s pl) $ + modify $ updateLevel $ updateSmell upd diff --git a/Game/LambdaHack/Actor.hs b/Game/LambdaHack/Actor.hs --- a/Game/LambdaHack/Actor.hs +++ b/Game/LambdaHack/Actor.hs @@ -2,10 +2,13 @@ -- involves the 'State' or 'Action' type. module Game.LambdaHack.Actor ( -- * Actor identifiers and related operations - ActorId(..), isAHero, isAMonster, invalidActorId - , findHeroName, monsterGenChance + ActorId, findHeroName, monsterGenChance + -- * Party identifiers + , PartyId, heroParty, enemyParty, animalParty + , heroProjectiles, enemyProjectiles, animalProjectiles, allProjectiles -- * The@ Acto@r type , Actor(..), template, addHp, unoccupied, heroKindId + , projectileKindId, actorSpeed -- * Type of na actor target , Target(..) ) where @@ -16,14 +19,39 @@ import Data.Ratio import Game.LambdaHack.Utils.Assert -import Game.LambdaHack.Misc import Game.LambdaHack.Vector import Game.LambdaHack.Point import Game.LambdaHack.Content.ActorKind import qualified Game.LambdaHack.Kind as Kind import Game.LambdaHack.Random import qualified Game.LambdaHack.Config as Config +import Game.LambdaHack.Time +import qualified Game.LambdaHack.Color as Color +-- | The type of party identifiers. +newtype PartyId = PartyId Int + deriving (Show, Eq, Ord) + +-- | All supported party identifiers. Animals and projectiles move every turn. +-- Projectiles don't recognize friends and foes, animals turn friedly +-- or hostile, depending on various factors. +heroParty, enemyParty, animalParty, + heroProjectiles, enemyProjectiles, animalProjectiles :: PartyId +heroParty = PartyId 0 +enemyParty = PartyId 1 +animalParty = PartyId 2 +heroProjectiles = PartyId 3 +enemyProjectiles = PartyId 4 +animalProjectiles = PartyId 5 + +-- | The list of parties that represent projectiles. +allProjectiles :: [PartyId] +allProjectiles = [heroProjectiles, enemyProjectiles, animalProjectiles] + +instance Binary PartyId where + put (PartyId n) = put n + get = fmap PartyId get + -- | Actor properties that are changing throughout the game. -- If they are dublets of properties from @ActorKind@, -- they are usually modified temporarily, but tend to return @@ -32,67 +60,51 @@ { bkind :: !(Kind.Id ActorKind) -- ^ the kind of the actor , bsymbol :: !(Maybe Char) -- ^ individual map symbol , bname :: !(Maybe String) -- ^ individual name + , bcolor :: !(Maybe Color.Color) -- ^ individual map color + , bspeed :: !(Maybe Speed) -- ^ individual speed , bhp :: !Int -- ^ current hit points , bdir :: !(Maybe (Vector, Int)) -- ^ direction and distance of running , btarget :: Target -- ^ target for ranged attacks and AI , bloc :: !Point -- ^ current location , bletter :: !Char -- ^ next inventory letter - , btime :: !Time -- ^ time of next action + , btime :: !Time -- ^ absolute time of next action + , bparty :: !PartyId -- ^ to which party the actor belongs } deriving Show instance Binary Actor where - put (Actor ak an as ah ad at al ale ati) = do - put ak - put an - put as - put ah - put ad - put at - put al - put ale - put ati + put Actor{..} = do + put bkind + put bsymbol + put bname + put bcolor + put bspeed + put bhp + put bdir + put btarget + put bloc + put bletter + put btime + put bparty get = do - ak <- get - an <- get - as <- get - ah <- get - ad <- get - at <- get - al <- get - ale <- get - ati <- get - return (Actor ak an as ah ad at al ale ati) + bkind <- get + bsymbol <- get + bname <- get + bcolor <- get + bspeed <- get + bhp <- get + bdir <- get + btarget <- get + bloc <- get + bletter <- get + btime <- get + bparty <- get + return Actor{..} -- ActorId operations -- | A unique identifier of an actor in a dungeon. -data ActorId = AHero !Int -- ^ hero index (on the lheroes intmap) - | AMonster !Int -- ^ monster index (on the lmonsters intmap) - deriving (Show, Eq, Ord) - -instance Binary ActorId where - put (AHero n) = putWord8 0 >> put n - put (AMonster n) = putWord8 1 >> put n - get = do - tag <- getWord8 - case tag of - 0 -> liftM AHero get - 1 -> liftM AMonster get - _ -> fail "no parse (ActorId)" - --- | Checks whether an actor identifier represents a hero. -isAHero :: ActorId -> Bool -isAHero (AHero _) = True -isAHero (AMonster _) = False - --- | Checks whether an actor identifier represents a monster. -isAMonster :: ActorId -> Bool -isAMonster = not . isAHero - --- | An actor that is not on any level. -invalidActorId :: ActorId -invalidActorId = AMonster (-1) +type ActorId = Int -- | Find a hero name in the config file, or create a stock name. findHeroName :: Config.CP -> Int -> String @@ -107,8 +119,8 @@ -- which monster is generated. How many and which monsters are generated -- will also depend on the cave kind used to build the level. monsterGenChance :: Int -> Int -> Rnd Bool -monsterGenChance d numMonsters = - chance $ 1%(fromIntegral (250 + 200 * (numMonsters - d)) `max` 50) +monsterGenChance depth numMonsters = + chance $ 1%(fromIntegral (25 + 20 * (numMonsters - depth)) `max` 5) -- Actor operations @@ -119,10 +131,14 @@ -- | A template for a new actor. The initial target is invalid -- to force a reset ASAP. template :: Kind.Id ActorKind -> Maybe Char -> Maybe String -> Int -> Point - -> Actor -template mk mc ms hp loc = - let invalidTarget = TEnemy invalidActorId loc - in Actor mk mc ms hp Nothing invalidTarget loc 'a' 0 + -> Time -> PartyId -> Actor +template bkind bsymbol bname bhp bloc btime bparty = + let bcolor = Nothing + bspeed = Nothing + btarget = invalidTarget + bdir = Nothing + bletter = 'a' + in Actor{..} -- | Increment current hit points of an actor. addHp :: Kind.Ops ActorKind -> Int -> Actor -> Actor @@ -144,23 +160,42 @@ heroKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind heroKindId Kind.Ops{ouniqGroup} = ouniqGroup "hero" +-- | The unique kind of projectiles. +projectileKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind +projectileKindId Kind.Ops{ouniqGroup} = ouniqGroup "projectile" + +-- | Access actor speed, individual or, otherwise, stock. +actorSpeed :: Kind.Ops ActorKind -> Actor -> Speed +actorSpeed Kind.Ops{okind} m = + let stockSpeed = aspeed $ okind $ bkind m + in fromMaybe stockSpeed $ bspeed m + -- Target -- | The type of na actor target. data Target = TEnemy ActorId Point -- ^ target an actor with its last seen location | TLoc Point -- ^ target a given location + | TPath [Vector] -- ^ target the list of locations one after another | TCursor -- ^ target current position of the cursor; default deriving (Show, Eq) +-- | An invalid target, with an actor that is not on any level. +invalidTarget :: Target +invalidTarget = + let invalidActorId = -1 + in TEnemy invalidActorId origin + instance Binary Target where put (TEnemy a ll) = putWord8 0 >> put a >> put ll put (TLoc loc) = putWord8 1 >> put loc - put TCursor = putWord8 2 + put (TPath ls) = putWord8 2 >> put ls + put TCursor = putWord8 3 get = do tag <- getWord8 case tag of 0 -> liftM2 TEnemy get get 1 -> liftM TLoc get - 2 -> return TCursor + 2 -> liftM TPath get + 3 -> return TCursor _ -> fail "no parse (Target)" diff --git a/Game/LambdaHack/ActorState.hs b/Game/LambdaHack/ActorState.hs --- a/Game/LambdaHack/ActorState.hs +++ b/Game/LambdaHack/ActorState.hs @@ -12,10 +12,12 @@ import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Point +import Game.LambdaHack.Vector import Game.LambdaHack.Actor import Game.LambdaHack.Level import Game.LambdaHack.Dungeon import Game.LambdaHack.State +import Game.LambdaHack.Grammar import Game.LambdaHack.Item import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.TileKind @@ -24,31 +26,51 @@ import qualified Game.LambdaHack.Tile as Tile import qualified Game.LambdaHack.Kind as Kind import qualified Game.LambdaHack.Feature as F +import Game.LambdaHack.Time --- The operations with "Any", and those that use them, consider all the dungeon. +-- TODO: currently it's false for player-controlled monsters. +-- When it's no longer, rewrite the places where it matters. +-- | Checks whether an actor identifier represents a hero. +isAHero :: State -> ActorId -> Bool +isAHero s a = + let (_, actor, _) = findActorAnyLevel a s + in bparty actor == heroParty + +-- | Checks whether an actor identifier represents a monster. +isAMonster :: State -> ActorId -> Bool +isAMonster s a = + let (_, actor, _) = findActorAnyLevel a s + in bparty actor == enemyParty + +-- TODO: move to TileState if ever created. +-- | How long until an actor's smell vanishes from a tile. +smellTimeout :: State -> Time +smellTimeout s = + let smellTurns = Config.get (sconfig s) "monsters" "smellTimeout" + in timeScale timeTurn smellTurns + +-- The operations with "Any", and those that use them, +-- consider all the dungeon. -- All the other actor and level operations only consider the current level. -- | Finds an actor body on any level. Fails if not found. findActorAnyLevel :: ActorId -> State -> (LevelId, Actor, [Item]) -findActorAnyLevel actor state@State{slid, sdungeon} = - assert (not (absentHero actor state) `blame` actor) $ +findActorAnyLevel actor State{slid, sdungeon} = let chk (ln, lvl) = - let (m, mi) = case actor of - AHero n -> (IM.lookup n (lheroes lvl), - IM.lookup n (lheroItem lvl)) - AMonster n -> (IM.lookup n (lmonsters lvl), - IM.lookup n (lmonItem lvl)) + let (m, mi) = (IM.lookup actor (lactor lvl), + IM.lookup actor (linv lvl)) in fmap (\ a -> (ln, a, fromMaybe [] mi)) m in case mapMaybe chk (currentFirst slid sdungeon) of [] -> assert `failure` actor res : _ -> res -- checking if res is unique would break laziness --- | Checks whether an actor is a hero, but not a member of the party. -absentHero :: ActorId -> State -> Bool -absentHero a State{sparty} = - case a of - AHero n -> IS.notMember n sparty - AMonster _ -> False +-- | Tries to finds an actor body satisfying a predicate on any level. +tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor) +tryFindActor State{slid, sdungeon} p = + let chk (_ln, lvl) = L.find (p . snd) $ IM.assocs $ lactor lvl + in case mapMaybe chk (currentFirst slid sdungeon) of + [] -> Nothing + res : _ -> Just res getPlayerBody :: State -> Actor getPlayerBody s@State{splayer} = @@ -61,27 +83,22 @@ in items -- | The list of actors and their levels for all heroes in the dungeon. -allHeroesAnyLevel :: State -> [(ActorId, LevelId)] +allHeroesAnyLevel :: State -> [ActorId] allHeroesAnyLevel State{slid, sdungeon} = - let one (ln, Level{lheroes}) = - L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs lheroes) + let one (_, lvl) = L.map fst (heroAssocs lvl) in L.concatMap one (currentFirst slid sdungeon) updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State updateAnyActorBody actor f state = let (ln, _, _) = findActorAnyLevel actor state - in case actor of - AHero n -> updateAnyLevel (updateHeroes $ IM.adjust f n) ln state - AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state + in updateAnyLevel (updateActorDict $ IM.adjust f actor) ln state updateAnyActorItem :: ActorId -> ([Item] -> [Item]) -> State -> State updateAnyActorItem actor f state = let (ln, _, _) = findActorAnyLevel actor state g Nothing = Just $ f [] g (Just is) = Just $ f is - in case actor of - AHero n -> updateAnyLevel (updateHeroItem $ IM.alter g n) ln state - AMonster n -> updateAnyLevel (updateMonItem $ IM.alter g n) ln state + in updateAnyLevel (updateInv $ IM.alter g actor) ln state updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State updateAnyLevel f ln s@State{slid, sdungeon} @@ -89,11 +106,13 @@ | otherwise = updateDungeon (const $ adjust f ln sdungeon) s -- | Calculate the location of player's target. -targetToLoc :: IS.IntSet -> State -> Maybe Point -targetToLoc visible s@State{slid, scursor} = +targetToLoc :: IS.IntSet -> State -> Point -> Maybe Point +targetToLoc visible s@State{slid, scursor} aloc = case btarget (getPlayerBody s) of TLoc loc -> Just loc - TCursor -> + TPath [] -> Nothing + TPath (dir:_) -> Just $ shift aloc dir + TCursor -> if slid == clocLn scursor then Just $ clocation scursor else Nothing -- cursor invalid: set at a different level @@ -106,55 +125,70 @@ -- The operations below disregard levels other than the current. -- | Checks if the actor is present on the current level. +-- The order of argument here and in other functions is set to allow +-- +-- > b <- gets (memActor a) memActor :: ActorId -> State -> Bool -memActor a state = - case a of - AHero n -> IM.member n (lheroes (slevel state)) - AMonster n -> IM.member n (lmonsters (slevel state)) +memActor a state = IM.member a (lactor (slevel state)) -- | Gets actor body from the current level. Error if not found. getActor :: ActorId -> State -> Actor -getActor a state = - case a of - AHero n -> lheroes (slevel state) IM.! n - AMonster n -> lmonsters (slevel state) IM.! n +getActor a state = lactor (slevel state) IM.! a -- | Gets actor's items from the current level. Empty list, if not found. getActorItem :: ActorId -> State -> [Item] -getActorItem a state = - fromMaybe [] $ - case a of - AHero n -> IM.lookup n (lheroItem (slevel state)) - AMonster n -> IM.lookup n (lmonItem (slevel state)) +getActorItem a state = fromMaybe [] $ IM.lookup a (linv (slevel state)) -- | Removes the actor, if present, from the current level. deleteActor :: ActorId -> State -> State deleteActor a = - case a of - AHero n -> - updateLevel (updateHeroes (IM.delete n) . updateHeroItem (IM.delete n)) - AMonster n -> - updateLevel (updateMonsters (IM.delete n) . updateMonItem (IM.delete n)) + updateLevel (updateActorDict (IM.delete a) . updateInv (IM.delete a)) -- | Add actor to the current level. insertActor :: ActorId -> Actor -> State -> State -insertActor a m = - case a of - AHero n -> updateLevel (updateHeroes (IM.insert n m)) - AMonster n -> updateLevel (updateMonsters (IM.insert n m)) +insertActor a m = updateLevel (updateActorDict (IM.insert a m)) --- | Removes a player from the current level and party list. +-- | Removes a player from the current level. deletePlayer :: State -> State -deletePlayer s@State{splayer, sparty} = - let s2 = deleteActor splayer s - in case splayer of - AHero n -> s2{sparty = IS.delete n sparty} - AMonster _ -> s2 +deletePlayer s@State{splayer} = deleteActor splayer s -levelHeroList, levelMonsterList :: State -> [Actor] -levelHeroList state = IM.elems $ lheroes $ slevel state -levelMonsterList state = IM.elems $ lmonsters $ slevel state +-- TODO: unify +heroAssocs, hostileAssocs, dangerousAssocs, friendlyAssocs, allButHeroesAssocs + :: Level -> [(ActorId, Actor)] +heroAssocs lvl = + filter (\ (_, m) -> bparty m == heroParty) $ IM.toList $ lactor lvl +hostileAssocs lvl = + filter (\ (_, m) -> bparty m `elem` [enemyParty, animalParty]) $ + IM.toList $ lactor lvl +dangerousAssocs lvl = + filter (\ (_, m) -> bparty m `elem` + [enemyParty, animalParty, + enemyProjectiles, animalProjectiles]) $ + IM.toList $ lactor lvl +friendlyAssocs lvl = + filter (\ (_, m) -> bparty m `elem` [heroParty, heroProjectiles]) $ + IM.toList $ lactor lvl +allButHeroesAssocs lvl = + filter (\ (_, m) -> bparty m `elem` + [heroProjectiles, enemyParty, animalParty, + enemyProjectiles, animalProjectiles]) $ + IM.toList $ lactor lvl +heroList, hostileList, dangerousList, friendlyList :: State -> [Actor] +heroList state = + filter (\ m -> bparty m == heroParty) $ IM.elems $ lactor $ slevel state +hostileList state = + filter (\ m -> bparty m `elem` [enemyParty, animalParty]) $ + IM.elems $ lactor $ slevel state +dangerousList state = + filter (\ m -> bparty m `elem` + [enemyParty, animalParty, + enemyProjectiles, animalProjectiles]) $ + IM.elems $ lactor $ slevel state +friendlyList state = + filter (\ m -> bparty m `elem` [heroParty, heroProjectiles]) $ + IM.elems $ lactor $ slevel state + -- | Finds an actor at a location on the current level. Perception irrelevant. locToActor :: Point -> State -> Maybe ActorId locToActor loc state = @@ -164,39 +198,50 @@ locToActors :: Point -> State -> [ActorId] locToActors loc state = - getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero) - where - getIndex (projection, injection) = - let l = IM.assocs $ projection $ slevel state + let l = IM.assocs $ lactor $ slevel state im = L.filter (\ (_i, m) -> bloc m == loc) l - in fmap (injection . fst) im + in fmap fst im nearbyFreeLoc :: Kind.Ops TileKind -> Point -> State -> Point nearbyFreeLoc cotile start state = - let lvl@Level{lxsize, lysize} = slevel state - hs = levelHeroList state - ms = levelMonsterList state + let lvl@Level{lxsize, lysize, lactor} = slevel state locs = start : L.nub (concatMap (vicinity lxsize lysize) locs) good loc = Tile.hasFeature cotile F.Walkable (lvl `at` loc) - && loc `notElem` L.map bloc (hs ++ ms) + && unoccupied (IM.elems lactor) loc in fromMaybe (assert `failure` "too crowded map") $ L.find good locs +-- | Calculate loot's worth for heroes on the current level. +calculateTotal :: Kind.Ops ItemKind -> State -> ([Item], Int) +calculateTotal coitem s = + let ha = heroAssocs $ slevel s + heroInv = L.concat $ catMaybes $ + L.map ( \ (k, _) -> IM.lookup k $ linv $ slevel s) ha + in (heroInv, L.sum $ L.map (itemPrice coitem) heroInv) + -- Adding heroes +tryFindHeroK :: State -> Int -> Maybe ActorId +tryFindHeroK s k = + let c | k == 0 = '@' + | k > 0 && k < 10 = Char.intToDigit k + | otherwise = assert `failure` k + in fmap fst $ tryFindActor s ((== Just c) . bsymbol) + -- | Create a new hero on the current level, close to the given location. addHero :: Kind.COps -> Point -> State -> State -addHero Kind.COps{coactor, cotile} ploc state = +addHero Kind.COps{coactor, cotile} ploc state@State{scounter} = let config = sconfig state bHP = Config.get config "heroes" "baseHP" loc = nearbyFreeLoc cotile ploc state - n = fst (scounter state) - symbol = if n < 1 || n > 9 then Nothing else Just $ Char.intToDigit n + freeHeroK = L.elemIndex Nothing $ map (tryFindHeroK state) [0..9] + n = fromMaybe 10 freeHeroK + symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n name = findHeroName config n - startHP = bHP `div` min 10 (n + 1) - m = template (heroKindId coactor) symbol (Just name) startHP loc - state' = state { scounter = (n + 1, snd (scounter state)) - , sparty = IS.insert n (sparty state) } - in updateLevel (updateHeroes (IM.insert n m)) state' + startHP = bHP `div` min 5 (n + 1) + m = template (heroKindId coactor) (Just symbol) (Just name) + startHP loc (stime state) heroParty + cstate = state { scounter = scounter + 1 } + in updateLevel (updateActorDict (IM.insert scounter m)) cstate -- | Create a set of initial heroes on the current level, at location ploc. initialHeroes :: Kind.COps -> Point -> State -> State @@ -210,13 +255,40 @@ -- and with a given actor kind and HP. addMonster :: Kind.Ops TileKind -> Kind.Id ActorKind -> Int -> Point -> State -> State -addMonster cotile mk hp ploc state@State{scounter = (heroC, monsterC)} = do +addMonster cotile mk hp ploc state@State{scounter} = do let loc = nearbyFreeLoc cotile ploc state - m = template mk Nothing Nothing hp loc - state' = state { scounter = (heroC, monsterC + 1) } - updateLevel (updateMonsters (IM.insert monsterC m)) state' + m = template mk Nothing Nothing hp loc (stime state) enemyParty + cstate = state {scounter = scounter + 1} + updateLevel (updateActorDict (IM.insert scounter m)) cstate --- | Calculate loot's worth for heroes on the current level. -calculateTotal :: Kind.Ops ItemKind -> State -> Int -calculateTotal coitem s = - L.sum $ L.map (itemPrice coitem) $ L.concat $ IM.elems $ lheroItem $ slevel s +-- Adding projectiles + +-- | Create a projectile actor containing the given missile. +addProjectile :: Kind.COps -> Item -> Point -> PartyId -> [Point] -> Time + -> State -> State +addProjectile Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}} + item loc bparty path btime state@State{scounter} = + let ik = okind (jkind item) + object = objectItem coitem state item + name = "a flying " ++ unwords (tail (words object)) + speed = speedFromWeight (iweight ik) (itoThrow ik) + range = rangeFromSpeed speed + dirPath = take range $ displacePath path + m = Actor + { bkind = projectileKindId coactor + , bsymbol = Nothing + , bname = Just name + , bcolor = Nothing + , bspeed = Just speed + , bhp = 0 + , bdir = Nothing + , btarget = TPath dirPath + , bloc = loc + , bletter = 'a' + , btime + , bparty + } + cstate = state { scounter = scounter + 1 } + upd = updateActorDict (IM.insert scounter m) + . updateInv (IM.insert scounter [item]) + in updateLevel upd cstate diff --git a/Game/LambdaHack/Binding.hs b/Game/LambdaHack/Binding.hs --- a/Game/LambdaHack/Binding.hs +++ b/Game/LambdaHack/Binding.hs @@ -11,13 +11,15 @@ import Game.LambdaHack.Utils.Assert import qualified Game.LambdaHack.Key as K +import Game.LambdaHack.Msg -- | Bindings and other information about player commands. data Binding a = Binding - { kcmd :: M.Map K.Key (String, a) -- ^ binding keys to commands - , kmacro :: M.Map K.Key K.Key -- ^ macro map - , kmajor :: [K.Key] -- ^ major, most often used, commands - , ktimed :: [K.Key] -- ^ commands that take time, except movement + { kcmd :: M.Map (K.Key, K.Modifier) (String, Bool, a) + -- ^ binding keys to commands + , kmacro :: M.Map K.Key K.Key -- ^ macro map + , kmajor :: [K.Key] -- ^ major, most often used, commands + , kdir :: [(K.Key, K.Modifier)] -- ^ direction keys for moving and running } -- | Produce the macro map from a macro association list @@ -43,8 +45,8 @@ else k : [ from | (from, to) <- M.assocs kmacro, to == k ] -- | Produce a set of help screens from the key bindings. -keyHelp :: Binding a -> [String] -keyHelp Binding{kcmd, kmacro, kmajor, ktimed} = +keyHelp :: Binding a -> [Overlay] +keyHelp Binding{kcmd, kmacro, kmajor} = let movBlurb = [ "Move throughout the level with numerical keypad or" @@ -56,14 +58,13 @@ , " /|\\ /|\\" , " 1 2 3 b j n" , "" - , "Run ahead until anything disturbs you, with SHIFT and a key." + ,"Run ahead until anything disturbs you, with SHIFT (or CTRL) and a key." , "Press keypad '5' or '.' to skip a turn." , "In targeting mode the same keys move the targeting cursor." , "" , "Search, open and attack, by bumping into walls, doors and monsters." , "" , "Press SPACE to see the next page, with the list of major commands." - , "" ] majorBlurb = [ "" @@ -76,19 +77,20 @@ , "Press SPACE to clear the messages and go back to the game." ] fmt k h = replicate 16 ' ' ++ k ++ replicate ((15 - length k) `max` 1) ' ' - ++ h ++ replicate ((40 - length h) `max` 1) ' ' - fmts s = replicate 1 ' ' ++ s ++ replicate ((70 - length s) `max` 1) ' ' + ++ h ++ replicate ((41 - length h) `max` 1) ' ' + fmts s = replicate 1 ' ' ++ s ++ replicate ((71 - length s) `max` 1) ' ' blank = fmt "" "" mov = map fmts movBlurb major = map fmts majorBlurb minor = map fmts minorBlurb keyCaption = fmt "keys" "command" disp k = L.concatMap show $ coImage kmacro k - ti k = if k `elem` ktimed then "*" else "" - keys l = [ fmt (disp k) (h ++ ti k) | (k, (h, _)) <- l, h /= "" ] - (kcMajor, kcMinor) = L.partition ((`elem` kmajor) . fst) (M.toAscList kcmd) + keys l = [ fmt (disp k) (h ++ if timed then "*" else "") + | ((k, _), (h, timed, _)) <- l, h /= "" ] + (kcMajor, kcMinor) = + L.partition ((`elem` kmajor) . fst . fst) (M.toAscList kcmd) in - L.map unlines [ [blank] ++ mov - , [blank] ++ [keyCaption] ++ keys kcMajor ++ major - , [blank] ++ [keyCaption] ++ keys kcMinor ++ minor - ] + [ [blank] ++ mov + , [blank] ++ [keyCaption] ++ keys kcMajor ++ major + , [blank] ++ [keyCaption] ++ keys kcMinor ++ minor + ] diff --git a/Game/LambdaHack/BindingAction.hs b/Game/LambdaHack/BindingAction.hs --- a/Game/LambdaHack/BindingAction.hs +++ b/Game/LambdaHack/BindingAction.hs @@ -18,7 +18,7 @@ import Game.LambdaHack.EffectAction import Game.LambdaHack.Binding import qualified Game.LambdaHack.Key as K -import Game.LambdaHack.Actor +import Game.LambdaHack.ActorState import Game.LambdaHack.Command configCmd :: Config.CP -> [(K.Key, Cmd)] @@ -33,21 +33,21 @@ in L.map mkCommand section semanticsCmd :: [(K.Key, Cmd)] - -> (Cmd -> Action ()) + -> (Cmd -> ActionFrame ()) -> (Cmd -> String) - -> [(K.Key, (String, Action ()))] + -> [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))] semanticsCmd cmdList cmdS cmdD = let mkDescribed cmd = let semantics = if timedCmd cmd then checkCursor $ cmdS cmd else cmdS cmd - in (cmdD cmd, semantics) - mkCommand (key, def) = (key, mkDescribed def) + in (cmdD cmd, timedCmd cmd, semantics) + mkCommand (key, def) = ((key, K.NoModifier), mkDescribed def) in L.map mkCommand cmdList -- | If in targeting mode, check if the current level is the same -- as player level and refuse performing the action otherwise. -checkCursor :: Action () -> Action () +checkCursor :: ActionFrame () -> ActionFrame () checkCursor h = do cursor <- gets scursor slid <- gets slid @@ -55,18 +55,24 @@ then h else abortWith "this command does not work on remote levels" -heroSelection :: [(K.Key, (String, Action ()))] +heroSelection :: [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))] heroSelection = - let heroSelect k = (K.Char (Char.intToDigit k), - ("", void $ selectPlayer $ AHero k)) + let select k = do + s <- get + case tryFindHeroK s k of + Nothing -> abortWith "No such member of the party." + Just aid -> selectPlayer aid >> returnNoFrame () + heroSelect k = ( (K.Char (Char.intToDigit k), K.NoModifier) + , ("", False, select k) + ) in fmap heroSelect [0..9] -- | Binding of keys to movement and other standard commands, -- as well as commands defined in the config file. -stdBinding :: Config.CP -- ^ game config - -> (Cmd -> Action ()) -- ^ semantics of abstract commands - -> (Cmd -> String) -- ^ description of abstract commands - -> Binding (Action ()) -- ^ concrete binding +stdBinding :: Config.CP -- ^ game config + -> (Cmd -> ActionFrame ()) -- ^ semantics of abstract commands + -> (Cmd -> String) -- ^ description of abstract commands + -> Binding (ActionFrame ()) -- ^ concrete binding stdBinding config cmdS cmdD = let section = Config.getItems config "macros" !kmacro = macroKey section @@ -78,17 +84,23 @@ runWidth f = do lxsize <- gets (lxsize . slevel) run (f lxsize, 0) + -- Targeting cursor movement and others are wrongly marked as timed; + -- fixed in their definitions by rewinding time. + cmdDir = K.moveBinding moveWidth runWidth in Binding { kcmd = M.fromList $ - K.moveBinding moveWidth runWidth ++ + cmdDir ++ heroSelection ++ semList ++ - [ -- debug commands, TODO:access them from a common menu or prefix - (K.Char 'R', ("", modify cycleMarkVision)), - (K.Char 'O', ("", modify toggleOmniscient)), - (K.Char 'I', ("", gets (lmeta . slevel) >>= abortWith)) + [ -- Debug commands. + ((K.Char 'r', K.Control), ("", False, modify cycleMarkVision + >> returnNoFrame ())), + ((K.Char 'o', K.Control), ("", False, modify toggleOmniscient + >> returnNoFrame ())), + ((K.Char 'i', K.Control), ("", False, gets (lmeta . slevel) + >>= abortWith)) ] , kmacro , kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList - , ktimed = L.map fst $ L.filter (timedCmd . snd) cmdList + , kdir = L.map fst cmdDir } diff --git a/Game/LambdaHack/Cave.hs b/Game/LambdaHack/Cave.hs --- a/Game/LambdaHack/Cave.hs +++ b/Game/LambdaHack/Cave.hs @@ -6,7 +6,9 @@ import Control.Monad import qualified Data.Map as M import qualified Data.List as L +import Data.Maybe +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.PointXY import Game.LambdaHack.Area import Game.LambdaHack.AreaRnd @@ -20,15 +22,16 @@ import Game.LambdaHack.Place hiding (TileMapXY) import qualified Game.LambdaHack.Place as Place import Game.LambdaHack.Misc +import Game.LambdaHack.Time -- | The map of tile kinds in a cave. -- The map is sparse. The default tile that eventually fills the empty spaces --- is specified in the cave kind specification with @cdefTile@. +-- is specified in the cave kind specification with @cdefaultTile@. type TileMapXY = Place.TileMapXY -- | The map of starting secrecy strength of tiles in a cave. -- The map is sparse. Unspecified tiles have secrecy strength of 0. -type SecretMapXY = M.Map PointXY Tile.SecretStrength +type SecretMapXY = M.Map PointXY Tile.SecretTime -- | The map of starting items in tiles of a cave. The map is sparse. -- Unspecified tiles have no starting items. @@ -76,8 +79,8 @@ -> Rnd Cave buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{okind=tokind, opick} , cocave=Kind.Ops{okind} } - lvl depth ci = do - let CaveKind{..} = okind ci + ln depth ci = do + let kc@CaveKind{..} = okind ci lgrid@(gx, gy) <- rollDiceXY cgrid lminplace <- rollDiceXY cminPlaceSize let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1) @@ -103,18 +106,17 @@ let r0 = places M.! p0 r1 = places M.! p1 connectPlaces r0 r1) allConnects - wallId <- opick "fillerWall" (const True) + wallId <- opick cfillerTile (const True) let fenceBounds = (1, 1, cxsize - 2, cysize - 2) fence = buildFence wallId fenceBounds - pickedCorTile <- opick ccorTile (const True) + pickedCorTile <- opick ccorridorTile (const True) let addPl (m, pls) (_, (x0, _, x1, _)) | x0 == x1 = return (m, pls) addPl (m, pls) (_, r) = do - (tmap, place) <- - buildPlace cops wallId pickedCorTile cdarkChance lvl depth r + (tmap, place) <- buildPlace cops kc pickedCorTile ln depth r return (M.union tmap m, place : pls) (lplaces, dplaces) <- foldM addPl (fence, []) places0 let lcorridors = M.unions (L.map (digCorridors pickedCorTile) cs) - hiddenMap <- mapToHidden cotile + hiddenMap <- mapToHidden cotile chiddenTile let lm = M.unionWith (mergeCorridor cotile hiddenMap) lcorridors lplaces -- Convert openings into doors, possibly. (dmap, secretMap) <- @@ -152,14 +154,14 @@ } return cave -rollSecret :: TileKind -> Rnd Tile.SecretStrength +rollSecret :: TileKind -> Rnd Tile.SecretTime rollSecret t = do let getDice (F.Secret dice) _ = dice getDice _ acc = acc defaultDice = RollDice 5 2 d = foldr getDice defaultDice (tfeature t) - secret <- rollDice d - return $ Tile.SecretStrength secret + secretTurns <- rollDice d + return $ timeScale timeTurn secretTurns trigger :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) trigger Kind.Ops{okind, opick} t = @@ -180,14 +182,14 @@ passable :: [F.Feature] passable = [F.Walkable, F.Openable, F.Hidden] -mapToHidden :: Kind.Ops TileKind +mapToHidden :: Kind.Ops TileKind -> String -> Rnd (M.Map (Kind.Id TileKind) (Kind.Id TileKind)) -mapToHidden cotile@Kind.Ops{ofoldrWithKey, opick} = +mapToHidden cotile@Kind.Ops{ofoldrWithKey, opick} chiddenTile = let getHidden ti tk acc = if Tile.canBeHidden cotile tk then do - ti2 <- opick "hidden" $ \ k -> Tile.kindHasFeature F.Hidden k - && Tile.similar k tk + ti2 <- opick chiddenTile $ \ k -> Tile.kindHasFeature F.Hidden k + && Tile.similar k tk fmap (M.insert ti ti2) acc else acc in ofoldrWithKey getHidden (return M.empty) @@ -197,4 +199,6 @@ -> Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind mergeCorridor cotile _ _ t | L.any (\ f -> Tile.hasFeature cotile f t) passable = t -mergeCorridor _ hiddenMap _ t = hiddenMap M.! t +mergeCorridor _ hiddenMap u t = + fromMaybe (assert `failure` (u, hiddenMap, t)) $ + M.lookup t hiddenMap diff --git a/Game/LambdaHack/Color.hs b/Game/LambdaHack/Color.hs --- a/Game/LambdaHack/Color.hs +++ b/Game/LambdaHack/Color.hs @@ -2,11 +2,12 @@ module Game.LambdaHack.Color ( -- * Colours Color(..), defBG, defFG, isBright, legalBG, colorToRGB - -- * Text attributes - , Attr(..), defaultAttr + -- * Text attributes and the screen + , Attr(..), defaultAttr, AttrChar(..), SingleFrame(..), Animation ) where -import qualified Data.Binary as Binary +import Data.Binary +import qualified Data.IntMap as IM -- TODO: since this type may be essential to speed, consider implementing -- it as an Int, with color numbered as they are on terminals, see @@ -33,9 +34,9 @@ | BrWhite deriving (Show, Eq, Ord, Enum, Bounded) -instance Binary.Binary Color where - put = Binary.putWord8 . toEnum . fromEnum - get = fmap (toEnum . fromEnum) Binary.getWord8 +instance Binary Color where + put = putWord8 . toEnum . fromEnum + get = fmap (toEnum . fromEnum) getWord8 -- | The default colours, to optimize attribute setting. defBG, defFG :: Color @@ -49,9 +50,45 @@ } deriving (Show, Eq, Ord) +instance Binary Attr where + put Attr{..} = do + put fg + put bg + get = do + fg <- get + bg <- get + return Attr{..} + -- | The default attribute, to optimize attribute setting. defaultAttr :: Attr defaultAttr = Attr defFG defBG + +data AttrChar = AttrChar + { acAttr :: !Attr + , acChar :: !Char + } + deriving (Show, Eq) + +instance Binary AttrChar where + put AttrChar{..} = do + put acAttr + put acChar + get = do + acAttr <- get + acChar <- get + return AttrChar{..} + +-- | The data sufficent to draw a single game screen frame. +data SingleFrame = SingleFrame + { sfLevel :: ![[AttrChar]] -- ^ content of the screen, line by line + , sfTop :: String -- ^ an extra line to show at the top + , sfBottom :: String -- ^ an extra line to show at the bottom + } + deriving Eq + +-- | Animation is a list of frame modifications to play one by one, +-- where each modification if a map from locations to level map symbols. +type Animation = [IM.IntMap AttrChar] -- | A helper for the terminal frontends that display bright via bold. isBright :: Color -> Bool diff --git a/Game/LambdaHack/Command.hs b/Game/LambdaHack/Command.hs --- a/Game/LambdaHack/Command.hs +++ b/Game/LambdaHack/Command.hs @@ -14,16 +14,20 @@ -- | Abstract syntax of player commands. The type is abstract, but the values -- are created outside this module via the Read class (from config file) . data Cmd = + -- These take time: Apply { verb :: Verb, object :: Object, syms :: [Char] } | Project { verb :: Verb, object :: Object, syms :: [Char] } | TriggerDir { verb :: Verb, object :: Object, feature :: F.Feature } | TriggerTile { verb :: Verb, object :: Object, feature :: F.Feature } | Pickup | Drop + | Wait + -- These do not take time: | Inventory | TgtFloor | TgtEnemy | TgtAscend Int + | EpsIncr Bool | GameSave | GameQuit | Cancel @@ -33,7 +37,6 @@ | HeroCycle | Version | Help - | Wait | Redraw deriving (Show, Read) @@ -52,9 +55,6 @@ Help -> True _ -> False --- TODO: Advance time automatically for these, but somehow advance --- time for monsters, too. Perhaps wait until monsters use commands, too --- (or rather the micro-commands to be added in the future). -- | Time cosuming commands are marked as such in help and cannot be -- invoked in targeting mode on a remote level (level different than -- the level of the selected hero). @@ -66,33 +66,37 @@ TriggerTile{} -> True Pickup -> True Drop -> True + GameSave -> True + GameQuit -> True Wait -> True _ -> False -- | The semantics of player commands in terms of the @Action@ monad. -cmdSemantics :: Cmd -> Action () +cmdSemantics :: Cmd -> ActionFrame () cmdSemantics cmd = case cmd of - Apply{..} -> playerApplyGroupItem verb object syms + Apply{..} -> inFrame $ playerApplyGroupItem verb object syms Project{..} -> playerProjectGroupItem verb object syms - TriggerDir{..} -> playerTriggerDir feature - TriggerTile{..} -> playerTriggerTile feature - Pickup -> pickupItem - Drop -> dropItem + TriggerDir{..} -> inFrame $ playerTriggerDir feature verb + TriggerTile{..} -> inFrame $ playerTriggerTile feature + Pickup -> inFrame $ pickupItem + Drop -> inFrame $ dropItem + Wait -> inFrame $ return () + Inventory -> inventory TgtFloor -> targetFloor TgtExplicit TgtEnemy -> targetMonster TgtExplicit TgtAscend k -> tgtAscend k - GameSave -> saveGame - GameQuit -> quitGame - Cancel -> cancelCurrent + EpsIncr b -> inFrame $ epsIncr b + GameSave -> inFrame $ saveGame + GameQuit -> inFrame $ quitGame + Cancel -> inFrame $ cancelCurrent Accept -> acceptCurrent displayHelp History -> displayHistory - CfgDump -> dumpConfig - HeroCycle -> cycleHero - Version -> gameVersion + CfgDump -> inFrame $ dumpConfig + HeroCycle -> inFrame $ cycleHero + Version -> inFrame $ gameVersion Help -> displayHelp - Wait -> playerAdvanceTime - Redraw -> return () + Redraw -> inFrame $ redraw -- | Description of player commands. cmdDescription :: Cmd -> String @@ -103,6 +107,8 @@ TriggerTile{..} -> verb ++ " " ++ addIndefinite object Pickup -> "get an object" Drop -> "drop an object" + Wait -> "" + Inventory -> "display inventory" TgtFloor -> "target location" TgtEnemy -> "target monster" @@ -111,6 +117,8 @@ TgtAscend k | k == -1 -> "target next deeper level" TgtAscend k | k <= -2 -> "target " ++ show (-k) ++ " levels deeper" TgtAscend _ -> error "void level change in targeting mode in config file" + EpsIncr True -> "swerve targeting line" + EpsIncr False -> "unswerve targeting line" GameSave -> "save and exit the game" GameQuit -> "quit without saving" Cancel -> "cancel action" @@ -120,5 +128,4 @@ HeroCycle -> "cycle among heroes on level" Version -> "display game version" Help -> "display help" - Wait -> "" Redraw -> "clear messages" diff --git a/Game/LambdaHack/Content/ActorKind.hs b/Game/LambdaHack/Content/ActorKind.hs --- a/Game/LambdaHack/Content/ActorKind.hs +++ b/Game/LambdaHack/Content/ActorKind.hs @@ -9,19 +9,22 @@ import Game.LambdaHack.Color import qualified Game.LambdaHack.Random as Random import Game.LambdaHack.Misc +import Game.LambdaHack.Time +-- TODO: make all but a few fields optional in some way, so that, a.g., +-- a game content with no regeneration does not ever need to mention aregen. -- | Actor properties that are fixed for a given kind of actors. data ActorKind = ActorKind { asymbol :: !Char -- ^ map symbol , aname :: !String -- ^ short description , afreq :: !Freqs -- ^ frequency within groups , acolor :: !Color -- ^ map color - , aspeed :: !Time -- ^ natural speed + , aspeed :: !Speed -- ^ natural speed in m/s , ahp :: !Random.RollDice -- ^ encodes initial and maximal hp , asight :: !Bool -- ^ can it see? , asmell :: !Bool -- ^ can it smell? , aiq :: !Int -- ^ intelligence - , aregen :: !Int -- ^ regeneration interval + , aregen :: !Int -- ^ number of turns to regenerate 1 HP } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 diff --git a/Game/LambdaHack/Content/CaveKind.hs b/Game/LambdaHack/Content/CaveKind.hs --- a/Game/LambdaHack/Content/CaveKind.hs +++ b/Game/LambdaHack/Content/CaveKind.hs @@ -27,8 +27,12 @@ , copenChance :: Chance -- ^ if there's a door, is it open? , chiddenChance :: Chance -- ^ if not open, is it hidden? , citemNum :: RollDice -- ^ the number of items in the cave - , cdefTile :: String -- ^ the default cave tile group name - , ccorTile :: String -- ^ the cave corridor tile group name + , cdefaultTile :: String -- ^ the default cave tile group name + , ccorridorTile :: String -- ^ the cave corridor tile group name + , cfillerTile :: String -- ^ the filler wall group name + , cdarkLegendTile :: String -- ^ the dark place plan legend ground name + , clitLegendTile :: String -- ^ the lit place plan legend ground name + , chiddenTile :: String -- ^ the hidden tiles ground name } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 diff --git a/Game/LambdaHack/Content/ItemKind.hs b/Game/LambdaHack/Content/ItemKind.hs --- a/Game/LambdaHack/Content/ItemKind.hs +++ b/Game/LambdaHack/Content/ItemKind.hs @@ -27,6 +27,8 @@ , ipower :: !RollDeep -- ^ created with that power , iverbApply :: !String -- ^ the verb for applying and possibly combat , iverbProject :: !String -- ^ the verb for projecting + , iweight :: !Int -- ^ weight in grams + , itoThrow :: !Int -- ^ percentage bonus or malus to throw speed } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 diff --git a/Game/LambdaHack/Content/RuleKind.hs b/Game/LambdaHack/Content/RuleKind.hs --- a/Game/LambdaHack/Content/RuleKind.hs +++ b/Game/LambdaHack/Content/RuleKind.hs @@ -33,6 +33,8 @@ , rtitle :: String -- ^ the title of the game , rpathsDataFile :: FilePath -> IO FilePath -- ^ the path to data files , rpathsVersion :: Version -- ^ the version of the game + , ritemMelee :: [Char] -- ^ symbols of melee weapons + , ritemProject :: [Char] -- ^ symbols of items AI can project } -- | A dummy instance of the 'Show' class, to satisfy general requirments diff --git a/Game/LambdaHack/Display.hs b/Game/LambdaHack/Display.hs --- a/Game/LambdaHack/Display.hs +++ b/Game/LambdaHack/Display.hs @@ -3,9 +3,9 @@ {-# LANGUAGE CPP #-} module Game.LambdaHack.Display ( -- * Re-exported frontend - FrontendSession, startup, shutdown, frontendName, nextEvent + FrontendSession, startup, shutdown, frontendName, nextEvent, promptGetKey -- * Derived operations - , ColorMode(..), displayLevel, getConfirmD + , displayFrame ) where -- Wrapper for selected Display frontend. @@ -20,199 +20,8 @@ import Game.LambdaHack.Display.Gtk as D #endif -import qualified Data.Char as Char -import qualified Data.IntSet as IS -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.IntMap as IM -import Data.Maybe - -import Game.LambdaHack.Utils.Assert -import Game.LambdaHack.Misc -import Game.LambdaHack.Msg import qualified Game.LambdaHack.Color as Color -import Game.LambdaHack.State -import Game.LambdaHack.PointXY -import Game.LambdaHack.Point -import Game.LambdaHack.Level -import Game.LambdaHack.Effect -import Game.LambdaHack.Perception -import Game.LambdaHack.Tile -import Game.LambdaHack.Actor as Actor -import Game.LambdaHack.ActorState -import qualified Game.LambdaHack.Dungeon as Dungeon -import Game.LambdaHack.Content.ActorKind -import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Content.ItemKind -import qualified Game.LambdaHack.Item as Item -import qualified Game.LambdaHack.Key as K -import Game.LambdaHack.Random -import qualified Game.LambdaHack.Kind as Kind -import Game.LambdaHack.FOV --- | Waits for a SPACE or ESC. -getConfirmD :: FrontendSession -> IO Bool -getConfirmD fs = do - e <- nextEvent fs - case e of - K.Space -> return True - K.Esc -> return False - _ -> getConfirmD fs - -splitOverlay :: Int -> String -> [[String]] -splitOverlay s xs = splitOverlay' (lines xs) - where - splitOverlay' ls - | length ls <= s = [ls] -- everything fits on one screen - | otherwise = let (pre, post) = splitAt (s - 1) ls - in (pre ++ [more]) : splitOverlay' post - --- | Returns a function that looks up the characters in the --- string by location. Takes the height of the display plus --- the string. Returns also the number of screens required --- to display all of the string. -stringByLocation :: Y -> String -> (Int, (X, Y) -> Maybe Char) -stringByLocation lysize xs = - let ls = splitOverlay lysize xs - m = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls))) - k = length ls - in (k, \ (x, y) -> M.lookup y m >>= \ n -> M.lookup x n) - --- | Color mode for the display. -data ColorMode = - ColorFull -- ^ normal, with full colours - | ColorBW -- ^ black+white only - --- TODO: split up and generally rewrite. --- | Display the whole screen: level map, messages and status area --- and multi-page overlaid information, if any. -displayLevel :: ColorMode -> FrontendSession -> Kind.COps - -> Perception -> State - -> Msg -> Maybe String -> IO Bool -displayLevel dm fs cops per - s@State{scursor, stime, sflavour, slid, splayer, sdebug} - msg moverlay = - let Kind.COps{ coactor=Kind.Ops{okind} - , coitem=coitem@Kind.Ops{okind=iokind} - , cotile=Kind.Ops{okind=tokind} } = cops - DebugMode{smarkVision, somniscient} = sdebug - lvl@Level{lxsize, lysize, lsmell, ldesc} = slevel s - (_, Actor{bkind, bhp, bloc}, bitems) = findActorAnyLevel splayer s - ActorKind{ahp, asmell} = okind bkind - reachable = debugTotalReachable per - visible = totalVisible per - (msgs, (ns, over)) = - case moverlay of - Just overlay -> - ( splitMsg (fst normalLevelBound + 1) msg (length more) - , -- ns overlay screens needed - stringByLocation lysize overlay - ) - Nothing -> - case splitMsg (fst normalLevelBound + 1) msg 0 of - msgTop : mss -> - ( [msgTop] - , stringByLocation lysize $ unlines $ - L.map (padMsg (fst normalLevelBound + 1)) mss - ) - [] -> assert `failure` msg - (sSml, sVis) = case smarkVision of - Just Blind -> (True, True) - Just _ -> (False, True) - Nothing | asmell -> (True, False) - Nothing -> (False, False) - lAt = if somniscient then at else rememberAt - liAt = if somniscient then atI else rememberAtI - sVisBG = if sVis - then \ vis rea -> if vis - then Color.Blue - else if rea - then Color.Magenta - else Color.defBG - else \ _vis _rea -> Color.defBG - wealth = calculateTotal coitem s - damage = case Item.strongestSword coitem bitems of - Just sw -> case ieffect $ iokind $ Item.jkind sw of - Wound dice -> show dice ++ "+" ++ show (Item.jpower sw) - _ -> show (Item.jpower sw) - Nothing -> "3d1" -- TODO; use the item 'fist' - hs = levelHeroList s - ms = levelMonsterList s - dis offset p@(PointXY (x0, y0)) = - let loc0 = toPoint lxsize p - tile = lvl `lAt` loc0 - items = lvl `liAt` loc0 - sm = smelltime $ IM.findWithDefault (SmellTime 0) loc0 lsmell - sml = (sm - stime) `div` 100 - viewActor loc Actor{bkind = bkind2, bsymbol} - | loc == bloc && slid == creturnLn scursor = - (symbol, Color.defBG) -- highlight player - | otherwise = (symbol, acolor) - where - ActorKind{asymbol, acolor} = okind bkind2 - symbol = fromMaybe asymbol bsymbol - viewSmell :: Int -> Char - viewSmell k - | k > 9 = '*' - | k < 0 = '-' - | otherwise = Char.intToDigit k - rainbow loc = toEnum $ loc `rem` 14 + 1 - (char, fg0) = - case L.find (\ m -> loc0 == Actor.bloc m) (hs ++ ms) of - Just m | somniscient || vis -> viewActor loc0 m - _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc0) - | otherwise -> - case items of - [] -> let u = tokind tile - in (tsymbol u, if vis then tcolor u else tcolor2 u) - i : _ -> Item.viewItem coitem (Item.jkind i) sflavour - vis = IS.member loc0 visible - rea = IS.member loc0 reachable - bg0 = if ctargeting scursor /= TgtOff && loc0 == clocation scursor - then Color.defFG -- highlight target cursor - else sVisBG vis rea -- FOV debug - reverseVideo = Color.Attr{ fg = Color.bg Color.defaultAttr - , bg = Color.fg Color.defaultAttr - } - optVisually attr@Color.Attr{fg, bg} = - if (fg == Color.defBG) || (bg == Color.defFG && fg == Color.defFG) - then reverseVideo - else attr - a = case dm of - ColorBW -> Color.defaultAttr - ColorFull -> optVisually Color.Attr{fg = fg0, bg = bg0} - in case over (x0, y0 + offset) of - Just c -> (Color.defaultAttr, c) - _ -> (a, char) - status = - take 27 (ldesc ++ repeat ' ') ++ - take 7 ("L: " ++ show (Dungeon.levelNumber slid) ++ repeat ' ') ++ - take 10 ("T: " ++ show (stime `div` 10) ++ repeat ' ') ++ - take 9 ("$: " ++ show wealth ++ repeat ' ') ++ - take 12 ("Dmg: " ++ damage ++ repeat ' ') ++ - take 30 ("HP: " ++ show bhp ++ - " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ') - width = fst normalLevelBound + 1 - toWidth :: Int -> String -> String - toWidth n x = take n (x ++ repeat ' ') - disp n mesg = display (0, 0, lxsize-1, lysize-1) fs (dis (lysize * n)) - (toWidth width mesg) (toWidth width status) - -- Perform messages slideshow. - perf [] = perfOverlay 0 "" - perf [xs] = perfOverlay 0 xs - perf (x:xs) = do - disp ns (x ++ more) - b <- getConfirmD fs - if b then perf xs else return False - -- Perform overlay pages slideshow. - perfOverlay k xs = do - disp k xs - if k < ns - 1 - then do - b <- getConfirmD fs - if b - then perfOverlay (k + 1) xs - else return False - else - return True - in perf msgs +-- | Push a frame or a single frame's worth of delay to the frame queue. +displayFrame :: FrontendSession -> Bool -> Maybe Color.SingleFrame -> IO () +displayFrame fs isRunning = display fs True isRunning diff --git a/Game/LambdaHack/Display/Curses.hs b/Game/LambdaHack/Display/Curses.hs --- a/Game/LambdaHack/Display/Curses.hs +++ b/Game/LambdaHack/Display/Curses.hs @@ -3,7 +3,7 @@ ( -- * Session data type for the frontend FrontendSession -- * The output and input operations - , display, nextEvent + , display, nextEvent, promptGetKey -- * Frontend administration tools , frontendName, startup, shutdown ) where @@ -14,9 +14,7 @@ import qualified Data.Map as M import Control.Monad -import Game.LambdaHack.Area -import Game.LambdaHack.PointXY -import qualified Game.LambdaHack.Key as K (Key(..)) +import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..)) import qualified Game.LambdaHack.Color as Color -- | Session data maintained by the frontend. @@ -34,7 +32,8 @@ startup :: String -> (FrontendSession -> IO ()) -> IO () startup _ k = do C.start - C.cursSet C.CursorInvisible +-- C.keypad C.stdScr False -- TODO: may help to fix xterm keypad on Ubuntu + void $ C.cursSet C.CursorInvisible let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg)) | fg <- [minBound..maxBound], -- No more color combinations possible: 16*4, 64 is max. @@ -53,39 +52,50 @@ shutdown _ = C.end -- | Output to the screen via the frontend. -display :: Area -- ^ the size of the drawn area - -> FrontendSession -- ^ current session data - -> (PointXY -> (Color.Attr, Char)) - -- ^ the content of the screen - -> String -- ^ an extra line to show at the top - -> String -- ^ an extra line to show at the bottom +display :: FrontendSession -- ^ frontend session data + -> Bool + -> Bool + -> Maybe Color.SingleFrame -- ^ the screen frame to draw -> IO () -display (x0, y0, x1, y1) FrontendSession{..} f msg status = do +display _ _ _ Nothing = return () +display FrontendSession{..} _ _ (Just Color.SingleFrame{..}) = do -- let defaultStyle = C.defaultCursesStyle -- Terminals with white background require this: let defaultStyle = sstyles M.! Color.defaultAttr C.erase C.setStyle defaultStyle - C.mvWAddStr swin 0 0 msg - C.mvWAddStr swin (y1 + 2) 0 (L.init status) - -- TODO: we need to remove the last character from the status line, + C.mvWAddStr swin 0 0 sfTop + -- We need to remove the last character from the status line, -- because otherwise it would overflow a standard size xterm window, -- due to the curses historical limitations. - sequence_ [ C.setStyle (M.findWithDefault defaultStyle a sstyles) - >> C.mvWAddStr swin (y + 1) x [c] - | x <- [x0..x1], y <- [y0..y1], - let (a, c) = f (PointXY (x, y)) ] + C.mvWAddStr swin (L.length sfLevel + 1) 0 (L.init sfBottom) + let nm = L.zip [0..] $ L.map (L.zip [0..]) sfLevel + sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles) + >> C.mvWAddStr swin (y + 1) x [acChar] + | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ] C.refresh -- | Input key via the frontend. -nextEvent :: FrontendSession -> IO K.Key -nextEvent _sess = do +nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier) +nextEvent _sess _ = do e <- C.getKey C.refresh - return (keyTranslate e) --- case keyTranslate e of --- Unknown _ -> nextEvent sess --- k -> return k + return (keyTranslate e, K.NoModifier) +-- | Display a prompt, wait for any of the specified keys (for any key, +-- if the list is empty). Repeat if an unexpected key received. +promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> Color.SingleFrame + -> IO (K.Key, K.Modifier) +promptGetKey sess keys frame = do + display sess True True $ Just frame + km <- nextEvent sess Nothing + let loop km2 = + if null keys || km2 `elem` keys + then return km2 + else do + km3 <- nextEvent sess Nothing + loop km3 + loop km + keyTranslate :: C.Key -> K.Key keyTranslate e = case e of @@ -110,7 +120,10 @@ C.KeyB2 -> K.Begin C.KeyClear -> K.Begin -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10 - -- Movement keys are more important than hero selection, so preferring them: + -- TODO: try to get the Control modifier from the escape gibberish + -- and use Control-keypad for KP_ movement. + -- Movement keys are more important than hero selection, + -- so disabling the latter and interpreting the keypad numbers as movement: C.KeyChar c | c `elem` ['1'..'9'] -> K.KP c | otherwise -> K.Char c diff --git a/Game/LambdaHack/Display/Gtk.hs b/Game/LambdaHack/Display/Gtk.hs --- a/Game/LambdaHack/Display/Gtk.hs +++ b/Game/LambdaHack/Display/Gtk.hs @@ -1,46 +1,96 @@ -- | Text frontend based on Gtk. +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Game.LambdaHack.Display.Gtk ( -- * Session data type for the frontend FrontendSession -- * The output and input operations - , display, nextEvent + , display, nextEvent, promptGetKey -- * Frontend administration tools , frontendName, startup, shutdown ) where import Control.Monad +import Control.Monad.Reader import Control.Concurrent -import Graphics.UI.Gtk.Gdk.Events -- TODO: replace, deprecated +import Control.Exception (finally) +import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk hiding (Point) import qualified Data.List as L import Data.IORef +import Data.Maybe import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS +import System.Time -import Game.LambdaHack.Area -import Game.LambdaHack.PointXY -import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate) +import Game.LambdaHack.Utils.Assert +import Game.LambdaHack.Utils.LQueue +import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate, Modifier(..)) import qualified Game.LambdaHack.Color as Color +data FrameState = + FPushed -- frames stored in a queue, to be drawn in equal time intervals + { fpushed :: !(LQueue (Maybe GtkFrame)) -- ^ screen output channel + , fshown :: !GtkFrame -- ^ last full frame shown + } + | FSet -- a single frame stored, to be drawn when a keypress is requested + { fsetFrame :: !(Maybe GtkFrame) -- ^ frame to draw at input key + } + | FNone -- no frames stored + -- | Session data maintained by the frontend. data FrontendSession = FrontendSession - { sview :: TextView -- ^ the widget to draw to - , stags :: M.Map Color.Attr TextTag -- ^ text tags for fore/back colour pairs - , schan :: Chan String -- ^ the channel that carries input + { sview :: !TextView -- ^ the widget to draw to + , stags :: !(M.Map Color.Attr TextTag) -- ^ text color tags for fg/bg + , schanKey :: !(Chan (K.Key, K.Modifier)) -- ^ channel for keyboard input + , sframeState :: !(MVar FrameState) -- ^ state of the frame machine + , slastFull :: !(IORef (GtkFrame, Bool)) + -- ^ most recent full (not empty, not repeated) frame received + -- and if any empty frame followed it } +data GtkFrame = GtkFrame + { gfChar :: !BS.ByteString + , gfAttr :: ![[TextTag]] + } + deriving Eq + +dummyFrame :: GtkFrame +dummyFrame = GtkFrame BS.empty [] + +-- | Remove all but the last element of the frame queue. +-- The kept last element ensures that slastFull is not invalidated. +trimQueue :: FrontendSession -> IO () +trimQueue FrontendSession{sframeState} = do + fs <- takeMVar sframeState + case fs of + FPushed{..} -> + putMVar sframeState FPushed{fpushed = trimLQueue fpushed, ..} + _ -> + putMVar sframeState fs + -- | The name of the frontend. frontendName :: String frontendName = "gtk" --- | Starts the main program loop using the frontend input and output. +-- | Spawns the gtk input and output thread, which spawns all the other +-- required threads. We create a separate thread for gtk to minimize +-- communication with the heavy main thread. The other threads have to be +-- spawned after gtk is initialized, because they call @postGUIAsync@, +-- and need @sview@ and @stags@. startup :: String -> (FrontendSession -> IO ()) -> IO () startup configFont k = do - -- initGUI + mv <- newEmptyMVar + -- Fork the gtk input and output thread. + void $ forkIO (runGtk configFont k `finally` putMVar mv ()) + takeMVar mv + +-- | Sets up and starts the main GTK loop providing input and output. +runGtk :: String -> (FrontendSession -> IO ()) -> IO () +runGtk configFont k = do + -- Init GUI. unsafeInitGUIForThreadedRTS - w <- windowNew + -- Text attributes. ttt <- textTagTableNew - -- text attributes stags <- fmap M.fromList $ mapM (\ ak -> do tt <- textTagNew Nothing @@ -49,55 +99,74 @@ return (ak, tt)) [ Color.Attr{fg, bg} | fg <- [minBound..maxBound], bg <- Color.legalBG ] - -- text buffer + -- Text buffer. tb <- textBufferNew (Just ttt) - textBufferSetText tb (unlines (replicate 25 (replicate 80 ' '))) - -- create text view, TODO: use GtkLayout or DrawingArea instead of TextView? + -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView? sview <- textViewNewWithBuffer tb - containerAdd w sview textViewSetEditable sview False textViewSetCursorVisible sview False - -- font + -- Set up the channel for keyboard input. + schanKey <- newChan + -- Set up the frame state. + let frameState = FNone + -- Create the session record. + sframeState <- newMVar frameState + slastFull <- newIORef (dummyFrame, False) + let sess = FrontendSession{..} + -- Fork the game logic thread. + forkIO $ k sess + -- Fork the thread that periodically draws a frame from a queue, if any. + forkIO $ pollFrames sess Nothing + -- Fill the keyboard channel. + sview `on` keyPressEvent $ do + n <- eventKeyName + mods <- eventModifier + let !key = K.keyTranslate n + !modifier = modifierTranslate mods + liftIO $ do + unless (deadKey n) $ do + -- Drop all the old frames. Some more may be arriving at the same time. + trimQueue sess + -- Store the key in the channel. + writeChan schanKey (key, modifier) + return True + -- Set the font specified in config, if any. f <- fontDescriptionFromString configFont widgetModifyFont sview (Just f) + -- Prepare font chooser dialog. currentfont <- newIORef f - let buttonPressHandler e = case e of - Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } -> do - fsd <- fontSelectionDialogNew "Choose font" - cf <- readIORef currentfont -- TODO: "Terminus,Monospace" fails - fds <- fontDescriptionToString cf - fontSelectionDialogSetFontName fsd fds - fontSelectionDialogSetPreviewText fsd "eee...@.##+##" - resp <- dialogRun fsd - when (resp == ResponseOk) $ do - fn <- fontSelectionDialogGetFontName fsd - case fn of - Just fn' -> do - fd <- fontDescriptionFromString fn' - writeIORef currentfont fd - widgetModifyFont sview (Just fd) - Nothing -> return () - widgetDestroy fsd - return True - _ -> return False - onButtonPress sview buttonPressHandler - -- modify default colours + sview `on` buttonPressEvent $ do + but <- eventButton + liftIO $ case but of + RightButton -> do + fsd <- fontSelectionDialogNew "Choose font" + cf <- readIORef currentfont -- TODO: "Terminus,Monospace" fails + fds <- fontDescriptionToString cf + fontSelectionDialogSetFontName fsd fds + fontSelectionDialogSetPreviewText fsd "eee...@.##+##" + resp <- dialogRun fsd + when (resp == ResponseOk) $ do + fn <- fontSelectionDialogGetFontName fsd + case fn of + Just fn' -> do + fd <- fontDescriptionFromString fn' + writeIORef currentfont fd + widgetModifyFont sview (Just fd) + Nothing -> return () + widgetDestroy fsd + return True + _ -> return False + -- Modify default colours. let black = Color minBound minBound minBound -- Color.defBG == Color.Black white = Color 0xC500 0xBC00 0xB800 -- Color.defFG == Color.White widgetModifyBase sview StateNormal black widgetModifyText sview StateNormal white - -- set up the channel for communication - schan <- newChan - forkIO $ k FrontendSession{..} - -- fill the channel - onKeyPress sview - (\ e -> do - writeChan schan (Graphics.UI.Gtk.Gdk.Events.eventKeyName e) - return True) - -- set quit handler + -- Set up the main window. + w <- windowNew + containerAdd w sview onDestroy w mainQuit - -- start it up widgetShowAll w + -- Wait until the other thread draws something and show the window. yield mainGUI @@ -106,77 +175,290 @@ shutdown _ = mainQuit -- | Output to the screen via the frontend. -display :: Area -- ^ the size of the drawn area - -> FrontendSession -- ^ current session data - -> (PointXY -> (Color.Attr, Char)) - -- ^ the content of the screen - -> String -- ^ an extra line to show at the top - -> String -- ^ an extra line to show at the bottom - -> IO () -display (x0, y0, x1, y1) FrontendSession{sview, stags} f msg status = - postGUIAsync $ do - tb <- textViewGetBuffer sview - let fLine y = let (as, cs) = unzip [ f (PointXY (x, y)) - | x <- [x0..x1] ] - in ((y, as), BS.pack cs) - memo = L.map fLine [y0..y1] - attrs = L.map fst memo - chars = L.map snd memo - bs = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status] - textBufferSetByteString tb (BS.concat bs) - mapM_ (setTo tb stags x0) attrs +output :: FrontendSession -- ^ frontend session data + -> GtkFrame -- ^ the screen frame to draw + -> IO () +output FrontendSession{sview, stags} GtkFrame{..} = do -- new frame + tb <- textViewGetBuffer sview + let attrs = L.zip [0..] gfAttr + defaultAttr = stags M.! Color.defaultAttr + textBufferSetByteString tb gfChar + mapM_ (setTo tb defaultAttr 0) attrs -setTo :: TextBuffer -> M.Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) - -> IO () +setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO () setTo _ _ _ (_, []) = return () -setTo tb tts lx (ly, attr:attrs) = do +setTo tb defaultAttr lx (ly, attr:attrs) = do ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx ie <- textIterCopy ib - let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO () + let setIter :: TextTag -> Int -> [TextTag] -> IO () setIter previous repetitions [] = do textIterForwardChars ie repetitions - when (previous /= Color.defaultAttr) $ - textBufferApplyTag tb (tts M.! previous) ib ie + when (previous /= defaultAttr) $ + textBufferApplyTag tb previous ib ie setIter previous repetitions (a:as) | a == previous = setIter a (repetitions + 1) as | otherwise = do textIterForwardChars ie repetitions - when (previous /= Color.defaultAttr) $ - textBufferApplyTag tb (tts M.! previous) ib ie + when (previous /= defaultAttr) $ + textBufferApplyTag tb previous ib ie textIterForwardChars ib repetitions setIter a 1 as setIter attr 1 attrs --- | Input key via the frontend. -nextEvent :: FrontendSession -> IO K.Key -nextEvent sess = do - e <- readUndeadChan (schan sess) - return (K.keyTranslate e) +-- TODO: configure +-- | Maximal frames per second. +-- This is better low and fixed, to avoid jerkiness and delays +-- that tell the player there are many intelligent enemies on the level. +-- That's better than scaling AI sofistication down based on the FPS setting +-- and machine speed. +maxFps :: Int +maxFps = 15 --- | Reads until a non-dead key encountered. -readUndeadChan :: Chan String -> IO String -readUndeadChan ch = do - x <- readChan ch - if dead x then readUndeadChan ch else return x - where - dead x = case x of - "Shift_R" -> True - "Shift_L" -> True - "Control_L" -> True - "Control_R" -> True - "Super_L" -> True - "Super_R" -> True - "Menu" -> True - "Alt_L" -> True - "Alt_R" -> True - "ISO_Level2_Shift" -> True - "ISO_Level3_Shift" -> True - "ISO_Level2_Latch" -> True - "ISO_Level3_Latch" -> True - "Num_Lock" -> True - "Caps_Lock" -> True - _ -> False +-- | Maximal polls per second. +maxPolls :: Int +maxPolls = let maxP = 120 + in assert (maxP >= 2 * maxFps `blame` (maxP, maxFps)) $ + maxP + +-- | Add a given number of microseconds to time. +addTime :: ClockTime -> Int -> ClockTime +addTime (TOD s p) ms = TOD s (p + fromIntegral (ms * 1000000)) + +-- | The difference between the first and the second time, in microseconds. +diffTime :: ClockTime -> ClockTime -> Int +diffTime (TOD s1 p1) (TOD s2 p2) = + (fromIntegral $ s1 - s2) * 1000000 + + (fromIntegral $ p1 - p2) `div` 1000000 + +-- | Poll the frame queue often and draw frames at fixed intervals. +pollFrames :: FrontendSession -> Maybe ClockTime -> IO () +pollFrames sess (Just setTime) = do + -- Check if the time is up. + curTime <- getClockTime + let diffT = diffTime setTime curTime + if diffT > 1000000 `div` maxPolls + then do + -- Delay half of the time difference. + threadDelay $ diffTime curTime setTime `div` 2 + pollFrames sess $ Just setTime + else + -- Don't delay, because time is up! + pollFrames sess Nothing +pollFrames sess@FrontendSession{sframeState} Nothing = do + -- Time time is up, check if we actually wait for anyting. + fs <- takeMVar sframeState + case fs of + FPushed{..} -> + case tryReadLQueue fpushed of + Just (Just frame, queue) -> do + -- The frame has arrived so send it for drawing and update delay. + putMVar sframeState FPushed{fpushed = queue, fshown = frame} + postGUIAsync $ output sess frame + curTime <- getClockTime + threadDelay $ 1000000 `div` (maxFps * 2) + pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps + Just (Nothing, queue) -> do + -- Delay requested via an empty frame. + putMVar sframeState FPushed{fpushed = queue, ..} + curTime <- getClockTime + -- There is no problem if the delay is a bit delayed. + threadDelay $ 1000000 `div` maxFps + pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps + Nothing -> do + -- The queue is empty, the game logic thread lags. + putMVar sframeState fs + -- Time time is up, the game thread is going to send a frame, + -- (otherwise it would change the state), so poll often. + threadDelay $ 1000000 `div` maxPolls + pollFrames sess Nothing + _ -> do + putMVar sframeState fs + -- Not in the Push state, so poll lazily to catch the next state change. + -- The slow polling also gives the game logic a head start + -- in creating frames in case one of the further frames is slow + -- to generate and would normally cause a jerky delay in drawing. + threadDelay $ 1000000 `div` (maxFps * 2) + pollFrames sess Nothing + +-- | Add a frame to be drawn. +display :: FrontendSession -> Bool -> Bool -> Maybe Color.SingleFrame -> IO () +display sess True noDelay rawFrame = pushFrame sess noDelay rawFrame +display sess False _ (Just rawFrame) = setFrame sess rawFrame +display _ _ _ _ = assert `failure` "display: empty frame to be set" + +-- | Add a game screen frame to the frame drawing channel. +pushFrame :: FrontendSession -> Bool -> Maybe Color.SingleFrame -> IO () +pushFrame sess@FrontendSession{sframeState, slastFull} noDelay rawFrame = do + -- Full evaluation and comparison is done outside the mvar lock. + (lastFrame, anyFollowed) <- readIORef slastFull + let frame = maybe Nothing (Just . evalFrame sess) rawFrame + nextFrame = + if frame == Just lastFrame + then Nothing -- no sense repeating + else frame + -- Now we take the lock. + fs <- takeMVar sframeState + case fs of + FPushed{..} -> + if (isNothing nextFrame && anyFollowed) + then putMVar sframeState fs -- old news + else putMVar sframeState + FPushed{fpushed = writeLQueue fpushed nextFrame, ..} + FSet{} -> assert `failure` "pushFrame: FSet, expecting FPushed or FNone" + FNone -> + -- Never start playing with an empty frame. + let fpushed = if isJust nextFrame + then writeLQueue newLQueue nextFrame + else newLQueue + fshown = dummyFrame + in putMVar sframeState FPushed{..} + yield -- drawing has priority + case nextFrame of + Nothing -> writeIORef slastFull (lastFrame, True) + Just f -> writeIORef slastFull (f, noDelay) + +evalFrame :: FrontendSession -> Color.SingleFrame -> GtkFrame +evalFrame FrontendSession{stags} Color.SingleFrame{..} = + let levelChar = L.map (L.map Color.acChar) sfLevel + gfChar = BS.pack $ L.intercalate "\n" $ sfTop : levelChar ++ [sfBottom] + -- Strict version of @L.map (L.map ((stags M.!) . fst)) sfLevel@. + gfAttr = L.reverse $ L.foldl' ff [] sfLevel + ff ll l = (L.reverse $ L.foldl' f [] l) : ll + f l ac = let !tag = stags M.! Color.acAttr ac in tag : l + in GtkFrame{..} + +-- | Set the frame to be drawn at the next invocation of @nextEvent@. +-- Fail if there is already a frame pushed or set. +-- Don't show the frame if it's unchanged vs the previous. +setFrame :: FrontendSession -> Color.SingleFrame -> IO () +setFrame sess@FrontendSession{slastFull, sframeState} rawFrame = do + -- Full evaluation and comparison is done outside the mvar lock. + (lastFrame, _) <- readIORef slastFull + let frame = evalFrame sess rawFrame + fsetFrame = + if frame == lastFrame + then Nothing -- no sense repeating + else Just frame + -- Now we take the lock. + fs <- takeMVar sframeState + case fs of + FPushed{} -> assert `failure` "setFrame: FPushed, expecting FNone" + FSet{} -> assert `failure` "setFrame: FSet, expecting FNone" + FNone -> do + -- Update the last received frame with the processed frame. + -- There is no race condition, because we are on the same thread + -- as pushFrame. + maybe (return ()) (\ fr -> writeIORef slastFull (fr, False)) fsetFrame + -- Store the frame. Release the lock. + putMVar sframeState FSet{..} + +-- | Input key via the frontend. Fail if there is no frame to show +-- to the player as a prompt for the keypress. +nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier) +nextEvent FrontendSession{schanKey, sframeState} Nothing = do + -- Verify the state. + -- Assumption: no other thread changes the main constructor in sframeState. + fs <- readMVar sframeState + case fs of + FNone -> return () -- old frame requested, as expected + FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FNone" + FSet{} -> assert `failure` "nextEvent: FSet, expecting FNone" + -- Wait for a keypress. + km <- readChan schanKey + return km +nextEvent sess@FrontendSession{schanKey, sframeState} (Just False) = do + -- Take the lock to display the set frame. + fs <- takeMVar sframeState + case fs of + FSet{fsetFrame} -> do + -- If the frame not repeated, draw it. + maybe (return ()) (postGUIAsync . output sess) fsetFrame + FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FSet" + FNone -> assert `failure` "nextEvent: FNone, expecting FSet" + -- Clear the stored frame. Release the lock. + putMVar sframeState FNone + -- Wait for a keypress. + km <- readChan schanKey + return km +nextEvent sess@FrontendSession{schanKey, sframeState} (Just True) = do + -- Wait for a keypress. + km <- readChan schanKey + -- Trim the queue. + trimQueue sess + -- Take the lock to wipe out the frame queue, unless it's empty already. + fs <- takeMVar sframeState + case fs of + FPushed{..} -> do + -- Draw the last frame ASAP. + case tryReadLQueue fpushed of + Just (Just frame, queue) -> assert (nullLQueue queue) $ do + -- Comparison is done inside the mvar lock, this time, but it's OK. + let lastFrame = fshown + nextFrame = + if frame == lastFrame + then Nothing -- no sense repeating + else Just frame + maybe (return ()) (postGUIAsync . output sess) nextFrame + Just (Nothing, _) -> assert `failure` "nextEvent: trimmed queue" + Nothing -> return () + FSet{} -> assert `failure` "nextEvent: FSet, expecting FPushed" + FNone -> assert `failure` "nextEvent: FNone, expecting FPushed" + -- Wipe out the frame queue. No more frames will arrive, because we are + -- on the same thread as pushFrame. Release the lock. + putMVar sframeState FNone + return km + +-- | Display a prompt, wait for any of the specified keys (for any key, +-- if the list is empty). Repeat if an unexpected key received. +-- Starts in Push or None mode, stop in None mode. +-- Spends most time waiting for a key, so not performance critical, +-- so does not need optimization. +promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> Color.SingleFrame + -> IO (K.Key, K.Modifier) +promptGetKey sess@FrontendSession{sframeState} keys frame = do + -- Assumption: no other thread changes the main constructor in sframeState. + fs <- readMVar sframeState + yield -- drawing has priority + let doPush = case fs of + FPushed{} -> True + FSet{} -> + assert `failure` "promptGetKey: FSet, expecting FPushed or FNone" + FNone -> False + display sess doPush True $ Just frame + km <- nextEvent sess (Just doPush) + let loop km2 = + if null keys || km2 `elem` keys + then return km2 + else do + km3 <- nextEvent sess Nothing + loop km3 + loop km + +-- | Tells a dead key. +deadKey :: String -> Bool +deadKey x = case x of + "Shift_R" -> True + "Shift_L" -> True + "Control_L" -> True + "Control_R" -> True + "Super_L" -> True + "Super_R" -> True + "Menu" -> True + "Alt_L" -> True + "Alt_R" -> True + "ISO_Level2_Shift" -> True + "ISO_Level3_Shift" -> True + "ISO_Level2_Latch" -> True + "ISO_Level3_Latch" -> True + "Num_Lock" -> True + "Caps_Lock" -> True + _ -> False + +-- | Translates modifiers to our own encoding. +modifierTranslate :: [Modifier] -> K.Modifier +modifierTranslate mods = + if Control `elem` mods then K.Control else K.NoModifier doAttr :: TextTag -> Color.Attr -> IO () doAttr tt attr@Color.Attr{fg, bg} diff --git a/Game/LambdaHack/Display/Std.hs b/Game/LambdaHack/Display/Std.hs --- a/Game/LambdaHack/Display/Std.hs +++ b/Game/LambdaHack/Display/Std.hs @@ -3,7 +3,7 @@ ( -- * Session data type for the frontend FrontendSession -- * The output and input operations - , display, nextEvent + , display, nextEvent, promptGetKey -- * Frontend administration tools , frontendName, startup, shutdown ) where @@ -12,9 +12,7 @@ import qualified Data.ByteString.Char8 as BS import qualified System.IO as SIO -import Game.LambdaHack.Area -import Game.LambdaHack.PointXY -import qualified Game.LambdaHack.Key as K (Key(..)) +import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..)) import qualified Game.LambdaHack.Color as Color -- | No session data needs to be maintained by this frontend. @@ -33,31 +31,40 @@ shutdown _ = return () -- | Output to the screen via the frontend. -display :: Area -- ^ the size of the drawn area - -> FrontendSession -- ^ current session data - -> (PointXY -> (Color.Attr, Char)) - -- ^ the content of the screen - -> String -- ^ an extra line to show at the top - -> String -- ^ an extra line to show at the bottom +display :: FrontendSession -- ^ frontend session data + -> Bool + -> Bool + -> Maybe Color.SingleFrame -- ^ the screen frame to draw -> IO () -display (x0, y0, x1, y1) _sess f msg status = - let xsize = x1 - x0 + 1 - g y x = if x > x1 - then Nothing - else Just (snd (f (PointXY (x, y))), x + 1) - fl y = fst $ BS.unfoldrN xsize (g y) x0 - level = L.map fl [y0..y1] - screen = [BS.pack msg] ++ level ++ [BS.pack status, BS.empty] - in mapM_ BS.putStrLn screen +display _ _ _ Nothing = return () +display _ _ _ (Just Color.SingleFrame{..}) = + let chars = L.map (BS.pack . L.map Color.acChar) sfLevel + bs = [BS.pack sfTop, BS.empty] ++ chars ++ [BS.pack sfBottom, BS.empty] + in mapM_ BS.putStrLn bs -- | Input key via the frontend. -nextEvent :: FrontendSession -> IO K.Key -nextEvent sess = do +nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier) +nextEvent sess mb = do e <- BS.hGet SIO.stdin 1 let c = BS.head e if c == '\n' -- let \n mark the end of input, for human players - then nextEvent sess - else return $ keyTranslate c + then nextEvent sess mb + else return (keyTranslate c, K.NoModifier) + +-- | Display a prompt, wait for any of the specified keys (for any key, +-- if the list is empty). Repeat if an unexpected key received. +promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> Color.SingleFrame + -> IO (K.Key, K.Modifier) +promptGetKey sess keys frame = do + display sess True True $ Just frame + km <- nextEvent sess Nothing + let loop km2 = + if null keys || km2 `elem` keys + then return km2 + else do + km3 <- nextEvent sess Nothing + loop km3 + loop km -- HACK: Special translation that block commands the bots should not use -- and multiplies some other commands. diff --git a/Game/LambdaHack/Display/Vty.hs b/Game/LambdaHack/Display/Vty.hs --- a/Game/LambdaHack/Display/Vty.hs +++ b/Game/LambdaHack/Display/Vty.hs @@ -3,7 +3,7 @@ ( -- * Session data type for the frontend FrontendSession -- * The output and input operations - , display, nextEvent + , display, nextEvent, promptGetKey -- * Frontend administration tools , frontendName, startup, shutdown ) where @@ -13,9 +13,7 @@ import qualified Data.List as L import qualified Data.ByteString.Char8 as BS -import Game.LambdaHack.Area -import Game.LambdaHack.PointXY -import qualified Game.LambdaHack.Key as K (Key(..)) +import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..)) import qualified Game.LambdaHack.Color as Color -- | Session data maintained by the frontend. @@ -34,53 +32,73 @@ shutdown = Vty.shutdown -- | Output to the screen via the frontend. -display :: Area -- ^ the size of the drawn area - -> FrontendSession -- ^ current session data - -> (PointXY -> (Color.Attr, Char)) - -- ^ the content of the screen - -> String -- ^ an extra line to show at the top - -> String -- ^ an extra line to show at bottom +display :: FrontendSession -- ^ frontend session data + -> Bool + -> Bool + -> Maybe Color.SingleFrame -- ^ the screen frame to draw -> IO () -display (x0, y0, x1, y1) vty f msg status = - let img = (foldr (<->) empty_image . - L.map (foldr (<|>) empty_image . - L.map (\ (x, y) -> let (a, c) = f (PointXY (x, y)) - in char (setAttr a) c))) - [ [ (x, y) | x <- [x0..x1] ] | y <- [y0..y1] ] +display _ _ _ Nothing = return () +display vty _ _ (Just Color.SingleFrame{..}) = + let img = (foldr (<->) empty_image + . L.map (foldr (<|>) empty_image + . L.map (\ Color.AttrChar{..} -> + char (setAttr acAttr) acChar))) + sfLevel pic = pic_for_image $ - utf8_bytestring (setAttr Color.defaultAttr) (BS.pack msg) + utf8_bytestring (setAttr Color.defaultAttr) (BS.pack sfTop) <-> img <-> - utf8_bytestring (setAttr Color.defaultAttr) (BS.pack status) + utf8_bytestring (setAttr Color.defaultAttr) (BS.pack sfBottom) in update vty pic -- | Input key via the frontend. -nextEvent :: FrontendSession -> IO K.Key -nextEvent sess = do +nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier) +nextEvent sess mb = do e <- next_event sess - return (keyTranslate e) - -keyTranslate :: Event -> K.Key -keyTranslate e = case e of - EvKey KEsc [] -> K.Esc - EvKey KEnter [] -> K.Return - EvKey (KASCII ' ') [] -> K.Space - EvKey (KASCII '\t') [] -> K.Tab - EvKey KUp [] -> K.Up - EvKey KDown [] -> K.Down - EvKey KLeft [] -> K.Left - EvKey KRight [] -> K.Right - EvKey KHome [] -> K.Home - EvKey KPageUp [] -> K.PgUp - EvKey KEnd [] -> K.End - EvKey KPageDown [] -> K.PgDn - EvKey KBegin [] -> K.Begin - -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8 - -- For now, movement keys are more important than hero selection: - EvKey (KASCII c) [] - | c `elem` ['1'..'9'] -> K.KP c - | otherwise -> K.Char c - _ -> K.Unknown (show e) + EvKey n mods -> do + let key = keyTranslate n + modifier = modifierTranslate mods + return (key, modifier) + _ -> nextEvent sess mb + +-- | Display a prompt, wait for any of the specified keys (for any key, +-- if the list is empty). Repeat if an unexpected key received. +promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> Color.SingleFrame + -> IO (K.Key, K.Modifier) +promptGetKey sess keys frame = do + display sess True True $ Just frame + km <- nextEvent sess Nothing + let loop km2 = + if null keys || km2 `elem` keys + then return km2 + else do + km3 <- nextEvent sess Nothing + loop km3 + loop km + +keyTranslate :: Key -> K.Key +keyTranslate n = + case n of + KEsc -> K.Esc + KEnter -> K.Return + (KASCII ' ') -> K.Space + (KASCII '\t') -> K.Tab + KUp -> K.Up + KDown -> K.Down + KLeft -> K.Left + KRight -> K.Right + KHome -> K.Home + KPageUp -> K.PgUp + KEnd -> K.End + KPageDown -> K.PgDn + KBegin -> K.Begin + (KASCII c) -> K.Char c + _ -> K.Unknown (show n) + +-- | Translates modifiers to our own encoding. +modifierTranslate :: [Modifier] -> K.Modifier +modifierTranslate mods = + if MCtrl `elem` mods then K.Control else K.NoModifier -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not. diff --git a/Game/LambdaHack/Draw.hs b/Game/LambdaHack/Draw.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Draw.hs @@ -0,0 +1,177 @@ +-- | Display game data on the screen using one of the available frontends +-- (determined at compile time with cabal flags). +{-# LANGUAGE CPP #-} +module Game.LambdaHack.Draw + ( ColorMode(..), draw, animate + ) where + +import qualified Data.IntSet as IS +import qualified Data.List as L +import qualified Data.IntMap as IM +import Data.Maybe + +import Game.LambdaHack.Msg +import qualified Game.LambdaHack.Color as Color +import Game.LambdaHack.State +import Game.LambdaHack.PointXY +import Game.LambdaHack.Point +import Game.LambdaHack.Level +import Game.LambdaHack.Effect +import Game.LambdaHack.Perception +import Game.LambdaHack.Actor as Actor +import Game.LambdaHack.ActorState +import qualified Game.LambdaHack.Dungeon as Dungeon +import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Content.TileKind +import Game.LambdaHack.Content.ItemKind +import qualified Game.LambdaHack.Item as Item +import Game.LambdaHack.Random +import qualified Game.LambdaHack.Kind as Kind +import Game.LambdaHack.FOV +import qualified Game.LambdaHack.Feature as F +import Game.LambdaHack.Time + +-- | Color mode for the display. +data ColorMode = + ColorFull -- ^ normal, with full colours + | ColorBW -- ^ black+white only + +-- TODO: split up and generally rewrite. +-- | Draw the whole screen: level map, status area and, at most, +-- a single page overlay of text divided into lines. +draw :: ColorMode -> Kind.COps -> Perception -> State -> Overlay + -> Color.SingleFrame +draw dm cops per s@State{ scursor=Cursor{..} + , sflavour, slid, splayer, sdebug + } overlay = + let Kind.COps{ coactor=Kind.Ops{okind} + , coitem=coitem@Kind.Ops{okind=iokind} + , cotile=Kind.Ops{okind=tokind, ouniqGroup} } = cops + DebugMode{smarkVision, somniscient} = sdebug + lvl@Level{lxsize, lysize, lsmell, ldesc, lactor, ltime} = slevel s + (_, Actor{bkind, bhp, bloc}, bitems) = findActorAnyLevel splayer s + ActorKind{ahp, asmell} = okind bkind + reachable = debugTotalReachable per + visible = totalVisible per + (msgTop, over) = stringByLocation lxsize lysize overlay + (sSml, sVis) = case smarkVision of + Just Blind -> (True, True) + Just _ -> (False, True) + Nothing | asmell -> (True, False) + Nothing -> (False, False) + lAt = if somniscient then at else rememberAt + liAt = if somniscient then atI else rememberAtI + sVisBG = if sVis + then \ vis rea -> if vis + then Color.Blue + else if rea + then Color.Magenta + else Color.defBG + else \ _vis _rea -> Color.defBG + (_, wealth) = calculateTotal coitem s + damage = case Item.strongestSword cops bitems of + Just sw -> case ieffect $ iokind $ Item.jkind sw of + Wound dice -> show dice ++ "+" ++ show (Item.jpower sw) + _ -> show (Item.jpower sw) + Nothing -> "3d1" -- TODO; use the item 'fist' + bl = fromMaybe [] $ bla lxsize lysize ceps bloc clocation + dis pxy = + let loc0 = toPoint lxsize pxy + tile = lvl `lAt` loc0 + tk = tokind tile + items = lvl `liAt` loc0 + sm = IM.findWithDefault timeZero loc0 lsmell + sml = sm `timeAdd` timeNegate ltime + viewActor loc Actor{bkind = bkind2, bsymbol, bcolor} + | loc == bloc && slid == creturnLn = + (symbol, Color.defBG) -- highlight player + | otherwise = (symbol, color) + where + ActorKind{asymbol, acolor} = okind bkind2 + color = fromMaybe acolor bcolor + symbol = fromMaybe asymbol bsymbol + rainbow loc = toEnum $ loc `rem` 14 + 1 + (char, fg0) = + case L.find (\ m -> loc0 == Actor.bloc m) (IM.elems lactor) of + _ | ctargeting /= TgtOff + && slid == creturnLn + && L.elem loc0 bl -> + let unknownId = ouniqGroup "unknown space" + in ('*', case (vis, F.Walkable `elem` tfeature tk) of + _ | tile == unknownId -> Color.BrBlack + (True, True) -> Color.BrGreen + (True, False) -> Color.BrRed + (False, True) -> Color.Green + (False, False) -> Color.Red) + Just m | somniscient || vis -> viewActor loc0 m + _ | sSml && timeScale sml 10 >= smellTimeout s -> + (timeToDigit (smellTimeout s) sml, rainbow loc0) + | otherwise -> + case items of + [] -> (tsymbol tk, if vis then tcolor tk else tcolor2 tk) + i : _ -> Item.viewItem coitem (Item.jkind i) sflavour + vis = IS.member loc0 visible + rea = IS.member loc0 reachable + bg0 = if ctargeting /= TgtOff && loc0 == clocation + then Color.defFG -- highlight target cursor + else sVisBG vis rea -- FOV debug or standard bg + reverseVideo = Color.Attr{ fg = Color.bg Color.defaultAttr + , bg = Color.fg Color.defaultAttr + } + optVisually attr@Color.Attr{fg, bg} = + if (fg == Color.defBG) + || (bg == Color.defFG && fg == Color.defFG) + then reverseVideo + else attr + a = case dm of + ColorBW -> Color.defaultAttr + ColorFull -> optVisually Color.Attr{fg = fg0, bg = bg0} + in case over pxy of + Just c -> Color.AttrChar Color.defaultAttr c + _ -> Color.AttrChar a char + status = + take 28 (ldesc ++ repeat ' ') ++ + take 9 ("L: " ++ show (Dungeon.levelNumber slid) ++ repeat ' ') ++ + take 11 ("$: " ++ show wealth ++ repeat ' ') ++ + take 14 ("Dmg: " ++ damage ++ repeat ' ') ++ + take 32 ("HP: " ++ show bhp ++ + " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ') + toWidth :: Int -> String -> String + toWidth n x = take n (x ++ repeat ' ') + fLine y = + let f l x = let !ac = dis (PointXY (x, y)) in ac : l + in L.foldl' f [] [lxsize-1,lxsize-2..0] + sfLevel = -- Fully evaluated. + let f l y = let !line = fLine y in line : l + in L.foldl' f [] [lysize-1,lysize-2..0] + sfTop = toWidth lxsize msgTop + sfBottom = toWidth lxsize status + in Color.SingleFrame{..} + +-- | Render animations on top of the current screen frame. +animate :: State -> Diary -> Kind.COps -> Perception -> Color.Animation + -> [Maybe Color.SingleFrame] +animate s Diary{sreport} cops per anim = + let xsize = lxsize $ slevel s + over = renderReport sreport + topLineOnly = padMsg xsize over + basicFrame = draw ColorFull cops per s [topLineOnly] + in rederAnim s basicFrame anim + +-- | Render animations on top of a screen frame. +rederAnim :: State -> Color.SingleFrame -> Color.Animation + -> [Maybe Color.SingleFrame] +rederAnim s basicFrame anim = + let Level{lxsize, lysize} = slevel s + modifyFrame Color.SingleFrame{sfLevel = levelOld, ..} am = + let fLine y lineOld = + let f l (x, acOld) = + let loc = toPoint lxsize (PointXY (x, y)) + !ac = fromMaybe acOld $ IM.lookup loc am + in ac : l + in L.foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld)) + sfLevel = -- Fully evaluated. + let f l (y, lineOld) = let !line = fLine y lineOld in line : l + in L.foldl' f [] (zip [lysize-1,lysize-2..0] (reverse levelOld)) + in Just Color.SingleFrame{..} + in map (modifyFrame basicFrame) anim diff --git a/Game/LambdaHack/Dungeon.hs b/Game/LambdaHack/Dungeon.hs --- a/Game/LambdaHack/Dungeon.hs +++ b/Game/LambdaHack/Dungeon.hs @@ -4,7 +4,7 @@ ( -- * Level identifier LevelId, levelNumber, levelDefault -- * Dungeon - , Dungeon, fromList, currentFirst, adjust, (!), lookup, depth + , Dungeon, fromList, currentFirst, adjust, mapDungeon, (!), lookup, depth ) where import Prelude hiding (lookup) @@ -67,6 +67,10 @@ -- | Adjust the level at a given id. adjust :: (Level -> Level) -> LevelId -> Dungeon -> Dungeon adjust f lid (Dungeon m d) = Dungeon (M.adjust f lid m) d + +-- | Adjust the level at a given id. +mapDungeon :: (Level -> Level) -> Dungeon -> Dungeon +mapDungeon f (Dungeon m d) = Dungeon (M.map f m) d -- | Find a level with the given id. (!) :: Dungeon -> LevelId -> Level diff --git a/Game/LambdaHack/DungeonState.hs b/Game/LambdaHack/DungeonState.hs --- a/Game/LambdaHack/DungeonState.hs +++ b/Game/LambdaHack/DungeonState.hs @@ -33,13 +33,14 @@ import Game.LambdaHack.Place import qualified Game.LambdaHack.Effect as Effect import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Time convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY -> Rnd TileMap -convertTileMaps cdefTile cxsize cysize lmap = do +convertTileMaps cdefaultTile cxsize cysize lmap = do let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1)) assocs = map (\ (xy, t) -> (toPoint cxsize xy, t)) (M.assocs lmap) - pickedTiles <- replicateM (cxsize * cysize) cdefTile + pickedTiles <- replicateM (cxsize * cysize) cdefaultTile return $ Kind.listArray bounds pickedTiles Kind.// assocs unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap @@ -54,10 +55,10 @@ rollItems :: Kind.COps -> Int -> Int -> CaveKind -> TileMap -> Point -> Rnd [(Point, Item)] rollItems Kind.COps{cotile, coitem=coitem@Kind.Ops{okind}} - lvl depth CaveKind{cxsize, citemNum, cminStairDist} lmap ploc = do + ln depth CaveKind{cxsize, citemNum, cminStairDist} lmap ploc = do nri <- rollDice citemNum replicateM nri $ do - item <- newItem coitem lvl depth + item <- newItem coitem ln depth let ik = okind (jkind item) l <- case ieffect ik of Effect.Wound dice | maxDice dice > 0 -- a weapon @@ -73,9 +74,9 @@ _ -> findLoc lmap (const (Tile.hasFeature cotile F.Boring)) return (l, item) -placeStairs :: Kind.Ops TileKind -> TileMap -> X -> Int -> [Place] +placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Place] -> Rnd (Point, Kind.Id TileKind, Point, Kind.Id TileKind) -placeStairs cotile@Kind.Ops{opick} cmap cxsize cminStairDist dplaces = do +placeStairs cotile@Kind.Ops{opick} cmap CaveKind{..} dplaces = do su <- findLoc cmap (const (Tile.hasFeature cotile F.Boring)) sd <- findLocTry 1000 cmap [ \ l _ -> chessDist cxsize su l >= cminStairDist @@ -83,7 +84,8 @@ , \ l t -> l /= su && Tile.hasFeature cotile F.Boring t ] let fitArea loc = inside cxsize loc . qarea - findLegend loc = maybe "litLegend" qlegend $ L.find (fitArea loc) dplaces + findLegend loc = + maybe clitLegendTile qlegend $ L.find (fitArea loc) dplaces upId <- opick (findLegend su) $ Tile.kindHasFeature F.Ascendable downId <- opick (findLegend sd) $ Tile.kindHasFeature F.Descendable return (su, upId, sd, downId) @@ -92,25 +94,23 @@ buildLevel :: Kind.COps -> Cave -> Int -> Int -> Rnd Level buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, ouniqGroup} , cocave=Kind.Ops{okind} } - Cave{..} lvl depth = do - let cfg@CaveKind{..} = okind dkind - cmap <- convertTileMaps (opick cdefTile (const True)) cxsize cysize dmap + Cave{..} ln depth = do + let kc@CaveKind{..} = okind dkind + cmap <- convertTileMaps (opick cdefaultTile (const True)) cxsize cysize dmap (su, upId, sd, downId) <- - placeStairs cotile cmap cxsize cminStairDist dplaces - let stairs = (su, upId) : if lvl == depth then [] else [(sd, downId)] + placeStairs cotile cmap kc dplaces + let stairs = (su, upId) : if ln == depth then [] else [(sd, downId)] lmap = cmap Kind.// stairs - is <- rollItems cops lvl depth cfg lmap su + is <- rollItems cops ln depth kc lmap su -- TODO: split this into Level.defaultLevel let itemMap = mapToIMap cxsize ditem `IM.union` IM.fromList is litem = IM.map (\ i -> ([i], [])) itemMap unknownId = ouniqGroup "unknown space" level = Level - { lheroes = IM.empty - , lheroItem = IM.empty + { lactor = IM.empty + , linv = IM.empty , lxsize = cxsize , lysize = cysize - , lmonsters = IM.empty - , lmonItem = IM.empty , lsmell = IM.empty , lsecret = mapToIMap cxsize dsecret , litem @@ -119,6 +119,7 @@ , ldesc = cname , lmeta = dmeta , lstairs = (su, sd) + , ltime = timeAdd timeTurn timeTurn -- just stepped into the dungeon } return level diff --git a/Game/LambdaHack/EffectAction.hs b/Game/LambdaHack/EffectAction.hs --- a/Game/LambdaHack/EffectAction.hs +++ b/Game/LambdaHack/EffectAction.hs @@ -15,9 +15,7 @@ import qualified Data.IntMap as IM import qualified Data.Set as S import qualified Data.IntSet as IS -import System.Time -import Game.LambdaHack.Misc import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Action import Game.LambdaHack.Actor @@ -25,6 +23,7 @@ import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Display +import Game.LambdaHack.Draw import Game.LambdaHack.Grammar import Game.LambdaHack.Point import qualified Game.LambdaHack.HighScore as H @@ -35,11 +34,13 @@ import Game.LambdaHack.Perception import Game.LambdaHack.Random import Game.LambdaHack.State +import Game.LambdaHack.Time import qualified Game.LambdaHack.Config as Config import qualified Game.LambdaHack.Effect as Effect import qualified Game.LambdaHack.Kind as Kind import Game.LambdaHack.DungeonState -import qualified Game.LambdaHack.Save as Save +import qualified Game.LambdaHack.Color as Color +import qualified Game.LambdaHack.Dungeon as Dungeon -- TODO: instead of verbosity return msg components and tailor them outside? -- TODO: separately define messages for the case when source == target @@ -49,107 +50,202 @@ -- | The source actor affects the target actor, with a given effect and power. -- The second argument is verbosity of the resulting message. -- Both actors are on the current level and can be the same actor. --- The bool result indicates if the actors identify the effect. +-- The first bool result indicates if the effect was spectacular enough +-- for the actors to identify it (and the item that caused it, if any). +-- The second bool tells if the effect was seen by or affected the party. effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int - -> Action (Bool, String) -effectToAction Effect.NoEffect _ _ _ _ = nullEffect -effectToAction Effect.Heal _ _source target power = do - coactor@Kind.Ops{okind} <- contentf Kind.coactor + -> Action (Bool, Bool) +effectToAction effect verbosity source target power = do + oldTm <- gets (getActor target) + let oldHP = bhp oldTm + (b, msg) <- eff effect verbosity source target power + s <- get + -- If the target killed outright by the effect (e.g., in a recursive call), + -- there's nothing left to do. TODO: hacky; aren't messages lost? + if not (memActor target s) + then return (b, False) + else do + sm <- gets (getActor source) + tm <- gets (getActor target) + per <- getPerception + pl <- gets splayer + let tloc = bloc tm + sloc = bloc sm + newHP = bhp $ getActor target s + bb <- + if isAHero s source || + isAHero s target || + pl == source || + pl == target || + -- Target part of message shown below, so target visibility checked. + tloc `IS.member` totalVisible per + then do + -- Party sees the effect or is affected by it. + msgAdd msg + -- Try to show an animation. + cops <- getCOps + diary <- getDiary + let locs = tloc : if tloc == sloc then [] else [sloc] + twirlSplash c1 c2 = map (IM.fromList . zip locs) + [ [Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '*'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '/', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '-', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '\\', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '|'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '/'] + , [Color.AttrChar (Color.Attr c1 Color.defBG) '-'] + , [Color.AttrChar (Color.Attr c2 Color.defBG) '\\', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [Color.AttrChar (Color.Attr c2 Color.defBG) '%', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [Color.AttrChar (Color.Attr c2 Color.defBG) '%', + Color.AttrChar (Color.Attr Color.BrWhite Color.defBG) '^'] + , [] + ] + anim | newHP > oldHP = twirlSplash Color.BrBlue Color.Blue + | newHP < oldHP = twirlSplash Color.BrRed Color.Red + | otherwise = [] + animFrs = animate s diary cops per anim + mapM_ displayFramePush $ Nothing : animFrs + return (b, True) + else do + -- Hidden, but if interesting then heard. + when b $ msgAdd "You hear some noises." + return (b, False) + -- Now kill the actor, if needed. For monsters, no "die" message + -- is shown below. It should have been showsn in @eff@. + when (newHP <= 0) $ do + -- Place the actor's possessions on the map. + bitems <- gets (getActorItem target) + modify (updateLevel (dropItemsAt bitems tloc)) + -- Clean bodies up. + if target == pl + then -- Kill the player and check game over. + checkPartyDeath + else -- Kill the enemy. + modify (deleteActor target) + return bb + +-- | The boolean part of the result says if the ation was interesting +-- and the string part describes how the target reacted +-- (not what the source did). +eff :: Effect.Effect -> Int -> ActorId -> ActorId -> Int + -> Action (Bool, String) +eff Effect.NoEffect _ _ _ _ = nullEffect +eff Effect.Heal _ _source target power = do + Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getCOps let bhpMax m = maxDice (ahp $ okind $ bkind m) tm <- gets (getActor target) if bhp tm >= bhpMax tm || power <= 0 then nullEffect else do - focusIfAHero target - updateAnyActor target (addHp coactor power) -- TODO: duplicate code in bhpMax and addHp - return (True, actorVerbExtra coactor tm "feel" "better") -effectToAction (Effect.Wound nDm) verbosity source target power = do - coactor <- contentf Kind.coactor - pl <- gets splayer + void $ focusIfOurs target + updateAnyActor target (addHp coactor power) + return (True, actorVerb coactor tm "feel" "better") +eff (Effect.Wound nDm) verbosity source target power = do + Kind.COps{coactor} <- getCOps n <- rndToAction $ rollDice nDm if n + power <= 0 then nullEffect else do - focusIfAHero target + void $ focusIfOurs target + pl <- gets splayer tm <- gets (getActor target) - let newHP = bhp tm - n - power - killed = newHP <= 0 + let newHP = bhp tm - n - power msg - | killed = - if isAHero target || target == pl - then "" -- handled later on in checkPartyDeath - else actorVerb coactor tm "die" + | newHP <= 0 = + if target == pl + then "" -- Handled later on in checkPartyDeath. Suspense. + else -- Not as important, so let the player read the message + -- about monster death while he watches the combat animation. + if bparty tm `elem` allProjectiles + then actorVerb coactor tm "drop" "down" + else actorVerb coactor tm "die" "" | source == target = -- a potion of wounding, etc. - actorVerbExtra coactor tm "feel" "wounded" + actorVerb coactor tm "feel" "wounded" | verbosity <= 0 = "" - | isAHero target || target == pl = - actorVerbExtra coactor tm "lose" $ + | target == pl = + actorVerb coactor tm "lose" $ show (n + power) ++ "HP" - | otherwise = actorVerbExtra coactor tm "hiss" "in pain" + | otherwise = actorVerb coactor tm "hiss" "in pain" updateAnyActor target $ \ m -> m { bhp = newHP } -- Damage the target. - when killed $ do - -- Place the actor's possessions on the map. - bitems <- gets (getActorItem target) - modify (updateLevel (dropItemsAt bitems (bloc tm))) - -- Clean bodies up. - if target == pl - then checkPartyDeath -- kills the player and checks game over - else modify (deleteActor target) -- kills the enemy return (True, msg) -effectToAction Effect.Dominate _ source target _power - | isAMonster target = do -- Monsters have weaker will than heroes. - selectPlayer target - >>= assert `trueM` (source, target, "player dominates himself") - -- Prevent AI from getting a few free moves until new player ready. - updatePlayerBody (\ m -> m { btime = 0}) - displayAll - return (True, "") - | source == target = do - lm <- gets (lmonsters . slevel) - lxsize <- gets (lxsize . slevel) - lysize <- gets (lysize . slevel) - let cross m = bloc m : vicinityCardinal lxsize lysize (bloc m) - vis = L.concatMap cross $ IM.elems lm - rememberList vis - return (True, "A dozen voices yells in anger.") - | otherwise = nullEffect -effectToAction Effect.SummonFriend _ source target power = do +eff Effect.Dominate _ source target _power = do + s <- get + if not $ isAHero s target + then do -- Monsters have weaker will than heroes. + -- Can't use @focusIfOurs@, because the actor is specifically not ours. + selectPlayer target + >>= assert `trueM` (source, target, "player dominates himself") + -- Prevent AI from getting a few free moves until new player ready. + updatePlayerBody (\ m -> m { btime = stime s}) + -- Display status line and FOV for the newly controlled actor. + fr <- drawPrompt ColorBW "" + mapM_ displayFramePush [Nothing, Just fr, Nothing] + return (True, "") + else if source == target + then do + lm <- gets hostileList + lxsize <- gets (lxsize . slevel) + lysize <- gets (lysize . slevel) + let cross m = bloc m : vicinityCardinal lxsize lysize (bloc m) + vis = L.concatMap cross lm + rememberList vis + return (True, "A dozen voices yells in anger.") + else nullEffect +eff Effect.SummonFriend _ source target power = do tm <- gets (getActor target) - if isAHero source + s <- get + if not $ isAMonster s source then summonHeroes (1 + power) (bloc tm) else summonMonsters (1 + power) (bloc tm) return (True, "") -effectToAction Effect.SummonEnemy _ source target power = do +eff Effect.SummonEnemy _ source target power = do tm <- gets (getActor target) - if not $ isAHero source -- a trick: monster player will summon a hero + s <- get + -- A trick: monster player summons a hero. + if isAMonster s source then summonHeroes (1 + power) (bloc tm) else summonMonsters (1 + power) (bloc tm) return (True, "") -effectToAction Effect.ApplyPerfume _ source target _ = +eff Effect.ApplyPerfume _ source target _ = if source == target then return (True, "Tastes like water, but with a strong rose scent.") else do let upd lvl = lvl { lsmell = IM.empty } modify (updateLevel upd) return (True, "The fragrance quells all scents in the vicinity.") -effectToAction Effect.Regeneration verbosity source target power = - effectToAction Effect.Heal verbosity source target power -effectToAction Effect.Searching _ _source _target _power = +eff Effect.Regeneration verbosity source target power = + eff Effect.Heal verbosity source target power +eff Effect.Searching _ _source _target _power = return (True, "It gets lost and you search in vain.") -effectToAction Effect.Ascend _ source target power = do - coactor <- contentf Kind.coactor +eff Effect.Ascend _ source target power = do tm <- gets (getActor target) - if isAMonster target + s <- get + Kind.COps{coactor} <- getCOps + void $ focusIfOurs target + if not $ isAHero s target -- not target /= pl: to squash friendly monster then squashActor source target else effLvlGoUp (power + 1) - -- TODO: The following message too late if a monster squashed: - return (True, actorVerbExtra coactor tm "find" "a shortcut upstrairs") -effectToAction Effect.Descend _ source target power = do - coactor <- contentf Kind.coactor + -- TODO: The following message too late if a monster squashed by going up, + -- unless it's ironic. ;) The same below. + s2 <- get + return $ if maybe H.Camping snd (squit s2) == H.Victor + then (True, "") + else (True, actorVerb coactor tm "find" "a way upstairs") +eff Effect.Descend _ source target power = do tm <- gets (getActor target) - if isAMonster target + s <- get + Kind.COps{coactor} <- getCOps + void $ focusIfOurs target + if not $ isAHero s target then squashActor source target else effLvlGoUp (- (power + 1)) - -- TODO: The following message too late if a monster squashed: - return (True, actorVerbExtra coactor tm "find" "a shortcut downstairs") + s2 <- get + return $ if maybe H.Camping snd (squit s2) == H.Victor + then (True, "") + else (True, actorVerb coactor tm "find" "a way downstairs") nullEffect :: Action (Bool, String) nullEffect = return (False, "Nothing happens.") @@ -157,59 +253,61 @@ -- TODO: refactor with actorAttackActor. squashActor :: ActorId -> ActorId -> Action () squashActor source target = do - Kind.COps{coactor, coitem=Kind.Ops{okind, ouniqGroup}} <- contentOps + Kind.COps{coactor, coitem=Kind.Ops{okind, ouniqGroup}} <- getCOps sm <- gets (getActor source) tm <- gets (getActor target) let h2hKind = ouniqGroup "weight" power = maxDeep $ ipower $ okind h2hKind h2h = Item h2hKind power Nothing 1 verb = iverbApply $ okind h2hKind - msg = actorVerbActorExtra coactor sm verb tm " in a staircase accident" + msg = actorVerbActor coactor sm verb tm "in a staircase accident" msgAdd msg itemEffectAction 0 source target h2h - >>= assert `trueM` (source, target, "affected") + s <- get + -- The monster has to be killed first, before we step there (same turn!). + assert (not (memActor target s) `blame` (source, target, "not killed")) $ + return () effLvlGoUp :: Int -> Action () effLvlGoUp k = do - targeting <- gets (ctargeting . scursor) pbody <- gets getPlayerBody pl <- gets splayer slid <- gets slid st <- get + cops <- getCOps + lvl <- gets slevel case whereTo st k of - Nothing -> do -- we are at the "end" of the dungeon - b <- msgYesNo "Really escape the dungeon?" - if b - then fleeDungeon - else abortWith "Game resumed." + Nothing -> fleeDungeon -- we are at the "end" of the dungeon Just (nln, nloc) -> - assert (nln /= slid `blame` (nln, "stairs looped")) $ - tryWith (abortWith "somebody blocks the staircase") $ do + assert (nln /= slid `blame` (nln, "stairs looped")) $ do bitems <- gets getPlayerItem -- Remember the level (e.g., for a teleport via scroll on the floor). remember -- Remove the player from the old level. modify (deleteActor pl) - hs <- gets levelHeroList + hs <- gets heroList -- Monsters hear that players not on the level. Cancel smell. -- Reduces memory load and savefile size. when (L.null hs) $ modify (updateLevel (updateSmell (const IM.empty))) -- At this place the invariant that the player exists fails. -- Change to the new level (invariant not needed). - modify (\ s -> s {slid = nln}) - -- Add the player to the new level. + switchLevel nln + -- The player can now be safely added to the new level. modify (insertActor pl pbody) modify (updateAnyActorItem pl (const bitems)) -- At this place the invariant is restored again. inhabitants <- gets (locToActor nloc) case inhabitants of Nothing -> return () - Just h | isAHero h -> - -- Bail out if a party member blocks the staircase. - abort +-- Broken if the effect happens, e.g. via a scroll and abort is not enough. +-- Just h | isAHero st h -> +-- -- Bail out if a party member blocks the staircase. +-- abortWith "somebody blocks the staircase" Just m -> - -- Somewhat of a workaround: squash monster blocking the staircase. + -- Aquash an actor blocking the staircase. + -- This is not a duplication with the other calls to squashActor, + -- because here an inactive actor is squashed. squashActor pl m -- Verify the monster on the staircase died. inhabitants2 <- gets (locToActor nloc) @@ -221,65 +319,82 @@ -- The invariant "at most one actor on a tile" restored. -- Create a backup of the savegame. state <- get - diary <- currentDiary - liftIO $ Save.saveGameBkp state diary - when (targeting /= TgtOff) doLook -- TODO: lags behind perception + diary <- getDiary + saveGameBkp state diary + msgAdd $ lookAt cops False True state lvl nloc "" +-- | Change level and reset it's time and update the times of all actors. +-- The player may be added to @lactor@ of the new level only after +-- this operation is executed. +switchLevel :: Dungeon.LevelId -> Action () +switchLevel nln = do + timeCurrent <- gets stime + slid <- gets slid + when (slid /= nln) $ do + -- Switch to the new level. + modify (\ s -> s {slid = nln}) + timeLastVisited <- gets stime + let diff = timeAdd timeCurrent $ timeNegate timeLastVisited + when (diff /= timeZero) $ do + -- Reset the level time. + modify $ updateTime $ const timeCurrent + -- Update the times of all actors. + let upd m@Actor{btime} = m {btime = timeAdd btime diff} + modify (updateLevel (updateActorDict (IM.map upd))) + -- | The player leaves the dungeon. fleeDungeon :: Action () fleeDungeon = do - coitem <- contentf Kind.coitem - state <- get - let total = calculateTotal coitem state - items = L.concat $ IM.elems $ lheroItem $ slevel state + Kind.COps{coitem} <- getCOps + s <- get + go <- displayYesNo "This is the way out. Really leave now?" + recordHistory -- Prevent repeating the ending msgs. + when (not go) $ abortWith "Game resumed." + let (items, total) = calculateTotal coitem s + modify (\ st -> st {squit = Just (False, H.Victor)}) if total == 0 - then do - go <- msgClear >> msgMoreConfirm ColorFull "Coward!" - when go $ - msgMore "Next time try to grab some loot before escape!" - end - else do - let winMsg = "Congratulations, you won! Your loot, worth " ++ - show total ++ " gold, is:" -- TODO: use the name of the '$' item instead - displayItems winMsg True items - go <- session getConfirm - when go $ do - go2 <- handleScores True H.Victor total - when go2 $ msgMore "Can it be done better, though?" - end + then do + -- The player can back off at each of these steps. + go1 <- displayMore ColorFull "Coward!" + when (not go1) $ abortWith "Brave soul!" + go2 <- displayMore ColorFull + "Next time try to grab some loot before escape!" + when (not go2) $ abortWith "Here's your chance!" + else do + let winMsg = "Congratulations, you won! Your loot, worth " ++ + show total ++ " gold, is:" -- TODO: use the name of the '$' item instead + io <- itemOverlay True True items + tryIgnore $ do + displayOverAbort winMsg io + modify (\ st -> st {squit = Just (True, H.Victor)}) -- | The source actor affects the target actor, with a given item. -- If the event is seen, the item may get identified. -itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool +itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action () itemEffectAction verbosity source target item = do - Kind.Ops{okind} <- contentf Kind.coitem - sm <- gets (getActor source) - tm <- gets (getActor target) - per <- currentPerception - pl <- gets splayer + Kind.COps{coitem=Kind.Ops{okind}} <- getCOps + sm <- gets (getActor source) + slidOld <- gets slid let effect = ieffect $ okind $ jkind item -- The msg describes the target part of the action. - (b, msg) <- effectToAction effect verbosity source target (jpower item) - if isAHero source || isAHero target || pl == source || pl == target || - (bloc tm `IS.member` totalVisible per && - bloc sm `IS.member` totalVisible per) - then do - -- Party sees or affected, so reported. - msgAdd msg - -- Party sees or affected, so if interesting, the item gets identified. - when b $ discover item - else - -- Hidden, but if interesting then heard. - when b $ msgAdd "You hear some noises." - return b + (b1, b2) <- effectToAction effect verbosity source target (jpower item) + -- Party sees or affected, and the effect interesting, + -- so the item gets identified. + when (b1 && b2) $ discover item + -- Destroys attacking actor and its items: a hack for projectiles. + slidNew <- gets slid + modify (\ s -> s {slid = slidOld}) + when (bparty sm `elem` allProjectiles) $ + modify (deleteActor source) + modify (\ s -> s {slid = slidNew}) -- | Make the item known to the player. discover :: Item -> Action () discover i = do - cops@Kind.Ops{okind} <- contentf Kind.coitem + Kind.COps{coitem=coitem@Kind.Ops{okind}} <- getCOps state <- get let ik = jkind i - obj = unwords $ tail $ words $ objectItem cops state i + obj = unwords $ tail $ words $ objectItem coitem state i msg = "The " ++ obj ++ " turns out to be " kind = okind ik alreadyIdentified = L.length (iflavour kind) == 1 @@ -287,106 +402,99 @@ unless alreadyIdentified $ do modify (updateDiscoveries (S.insert ik)) state2 <- get - msgAdd $ msg ++ objectItem cops state2 i ++ "." + msgAdd $ msg ++ objectItem coitem state2 i ++ "." -- | Make the actor controlled by the player. -- Focus on the actor if level changes. False, if nothing to do. selectPlayer :: ActorId -> Action Bool selectPlayer actor = do - coactor <- contentf Kind.coactor - pl <- gets splayer - targeting <- gets (ctargeting . scursor) + Kind.COps{coactor} <- getCOps + pl <- gets splayer + cops <- getCOps + lvl <- gets slevel if actor == pl then return False -- already selected else do state <- get - when (absentHero actor state) $ abortWith "No such member of the party." let (nln, pbody, _) = findActorAnyLevel actor state + -- Switch to the new level. + switchLevel nln -- Make the new actor the player-controlled actor. - modify (\ s -> s { splayer = actor }) + modify (\ s -> s {splayer = actor}) -- Record the original level of the new player. - modify (updateCursor (\ c -> c { creturnLn = nln })) + modify (updateCursor (\ c -> c {creturnLn = nln})) -- Don't continue an old run, if any. stopRunning - -- Switch to the level. - modify (\ s -> s{slid = nln}) -- Announce. msgAdd $ capActor coactor pbody ++ " selected." - when (targeting /= TgtOff) doLook + msgAdd $ lookAt cops False True state lvl (bloc pbody) "" return True -focusIfAHero :: ActorId -> Action () -focusIfAHero target = - when (isAHero target) $ do - -- Focus on the hero being wounded/displaced/etc. - b <- selectPlayer target - -- Display status line for the new hero. - when b $ void displayAll +focusIfOurs :: ActorId -> Action Bool +focusIfOurs target = do + s <- get + pl <- gets splayer + if isAHero s target || target == pl + then do + -- Focus on the hero being wounded/displaced/etc. + b <- selectPlayer target + -- Display status line for the new hero. + when b $ do + -- Display status line and FOV for the new hero. + fr <- drawPrompt ColorFull "" + mapM_ displayFramePush [Nothing, Just fr, Nothing] + return b + else return False summonHeroes :: Int -> Point -> Action () summonHeroes n loc = assert (n > 0) $ do - cops <- contentOps - newHeroId <- gets (fst . scounter) + cops <- getCOps + newHeroId <- gets scounter modify (\ state -> iterate (addHero cops loc) state !! n) - selectPlayer (AHero newHeroId) - >>= assert `trueM` (newHeroId, "player summons himself") - -- Display status line for the new hero. - void displayAll + b <- focusIfOurs newHeroId + assert (b `blame` (newHeroId, "player summons himself")) $ + return () summonMonsters :: Int -> Point -> Action () summonMonsters n loc = do - Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} <- contentOps + Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} <- getCOps mk <- rndToAction $ opick "summon" (const True) hp <- rndToAction $ rollDice $ ahp $ okind mk modify (\ state -> iterate (addMonster cotile mk hp loc) state !! n) --- | Update player memory. -remember :: Action () -remember = do - per <- currentPerception - 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 -> L.foldr rememberItem m vis))) - -- | Remove dead heroes (or dead dominated monsters). Check if game is over. -- For now we only check the selected hero and at current level, -- but if poison, etc. is implemented, we'd need to check all heroes -- on any level. checkPartyDeath :: Action () checkPartyDeath = do - cops <- contentf Kind.coactor + Kind.COps{coactor} <- getCOps ahs <- gets allHeroesAnyLevel pl <- gets splayer pbody <- gets getPlayerBody config <- gets sconfig - when (bhp pbody <= 0) $ do -- TODO: change to guard? define mzero as abort? Why are the writes to the files performed when I call abort later? That probably breaks the laws of MonadPlus. Or is the tryWith abort handler placed after the write to files? - go <- msgMoreConfirm ColorBW $ actorVerb cops pbody "die" - history -- Prevent the msgs from being repeated. + when (bhp pbody <= 0) $ do + msgAdd $ actorVerb coactor pbody "die" "" + go <- displayMore ColorBW "" + recordHistory -- Prevent repeating the "die" msgs. let firstDeathEnds = Config.get config "heroes" "firstDeathEnds" if firstDeathEnds then gameOver go - else case L.filter (\ (actor, _) -> actor /= pl) ahs of + else case L.filter (/= pl) ahs of [] -> gameOver go - (actor, _nln) : _ -> do + actor : _ -> do msgAdd "The survivors carry on." -- One last look at the beautiful world. remember -- Remove the dead player. modify deletePlayer -- At this place the invariant that the player exists fails. - -- Focus on the new hero (invariant not needed). + -- Select the new player-controlled hero (invariant not needed), + -- but don't draw a frame for him with focusIfOurs, + -- in case the focus changes again during the same turn. + -- He's just a random next guy in the line. selectPlayer actor >>= assert `trueM` (pl, actor, "player resurrects") -- At this place the invariant is restored again. @@ -394,113 +502,99 @@ -- | End game, showing the ending screens, if requested. gameOver :: Bool -> Action () gameOver showEndingScreens = do + slid <- gets slid + modify (\ st -> st {squit = Just (False, H.Killed slid)}) when showEndingScreens $ do - cops <- contentf Kind.coitem - state <- get - slid <- gets slid - let total = calculateTotal cops state - status = H.Killed slid - handleScores True status total - msgMore "Let's hope another party can save the day!" - end - --- | Handle current score and display it with the high scores. --- False if display of the scores was void or interrupted by the user. --- --- Warning: scores are shown during the game, --- so we should be careful not to leak secret information through them --- (e.g., the nature of the items through the total worth of inventory). -handleScores :: Bool -> H.Status -> Int -> Action Bool -handleScores write status total = - if total == 0 - then return False - else do - config <- gets sconfig - time <- gets stime - curDate <- liftIO getClockTime - let points = case status of - H.Killed _ -> (total + 1) `div` 2 - _ -> total - let score = H.ScoreRecord points (-time) curDate status - (placeMsg, slideshow) <- liftIO $ H.register config write score - msgOverlaysConfirm placeMsg slideshow - session getConfirm + Kind.COps{coitem} <- getCOps + s <- get + dng <- gets sdungeon + time <- gets stime + let (items, total) = calculateTotal coitem s + deepest = Dungeon.levelNumber slid -- use deepest visited instead of level of death + depth = Dungeon.depth dng + failMsg | timeFit time timeTurn < 300 = + "That song shall be short." + | total < 100 = + "Born poor, dies poor." + | deepest < 4 && total < 500 = + "This should end differently." + | deepest < depth - 1 = + "This defeat brings no dishonour." + | deepest < depth = + "That is your name. 'Almost'." + | otherwise = + "Dead heroes make better legends." + loseMsg = failMsg ++ " Killing you nets " ++ + show total ++ " gold and some junk:" -- TODO: use the name of the '$' item instead + if null items + then modify (\ st -> st {squit = Just (True, H.Killed slid)}) + else do + io <- itemOverlay True True items + tryIgnore $ do + displayOverAbort loseMsg io + modify (\ st -> st {squit = Just (True, H.Killed slid)}) --- effectToAction does not depend on this function right now, but it might, --- and I know no better place to put it. -displayItems :: Msg -> Bool -> [Item] -> Action Bool -displayItems msg sorted is = do - cops <- contentf Kind.coitem +-- | Create a list of item names, split into many overlays. +itemOverlay ::Bool -> Bool -> [Item] -> Action [Overlay] +itemOverlay sorted cheat is = do + Kind.COps{coitem} <- getCOps state <- get - let inv = unlines $ - L.map (\ i -> letterLabel (jletter i) - ++ objectItem cops state i ++ " ") + lysize <- gets (lysize . slevel) + let inv = L.map (\ i -> letterLabel (jletter i) + ++ objectItemCheat coitem cheat state i ++ " ") ((if sorted then L.sortBy (cmpLetterMaybe `on` jletter) else id) is) - let ovl = inv ++ msgEnd - msgReset msg - overlay ovl + return $ splitOverlay lysize inv stopRunning :: Action () stopRunning = updatePlayerBody (\ p -> p { bdir = Nothing }) --- | Store current msg in the history and reset current msg. -history :: Action () -history = do - msg <- currentMsg - msgClear - config <- gets sconfig - let historyMax = Config.get config "ui" "historyMax" - -- TODO: not ideal, continuations of sentences are atop beginnings. - splitS = splitMsg (fst normalLevelBound + 1) msg 0 - takeMax diary = - take historyMax $ - L.map (padMsg (fst normalLevelBound + 1)) splitS ++ shistory diary - unless (L.null msg) $ do - diary <- currentDiary - diaryReset $ diary {shistory = takeMax diary} - -- TODO: depending on tgt, show extra info about tile or monster or both -- | Perform look around in the current location of the cursor. -doLook :: Action () +doLook :: ActionFrame () doLook = do - cops@Kind.COps{coactor} <- contentOps + cops@Kind.COps{coactor} <- getCOps loc <- gets (clocation . scursor) state <- get lvl <- gets slevel - per <- currentPerception + hms <- gets (lactor . slevel) + per <- getPerception target <- gets (btarget . getPlayerBody) pl <- gets splayer - let canSee = IS.member loc (totalVisible per) - monsterMsg = - if canSee - then case L.find (\ m -> bloc m == loc) (levelMonsterList state) of - Just m -> actorVerbExtra coactor m "be" "here" ++ " " - Nothing -> "" - else "" - vis | not $ loc `IS.member` totalVisible per = - " (not visible)" -- by party - | actorReachesLoc pl loc per (Just pl) = "" - | otherwise = " (not reachable)" -- by hero - mode = case target of - TEnemy _ _ -> "[targeting monster" ++ vis ++ "] " - TLoc _ -> "[targeting location" ++ vis ++ "] " - TCursor -> "[targeting current" ++ vis ++ "] " - -- general info about current loc - lookMsg = mode ++ lookAt cops True canSee state lvl loc monsterMsg - -- check if there's something lying around at current loc - is = lvl `rememberAtI` loc - if length is <= 2 - then msgAdd lookMsg - else do - displayItems lookMsg False is - session getConfirm >> msgAdd "" -- TODO: a hack; instead keep current overlay in the state to keep it from being overwritten on the screen in Turn.hs, just as msg is kept, and reset each turn + targeting <- gets (ctargeting . scursor) + assert (targeting /= TgtOff) $ do + let canSee = IS.member loc (totalVisible per) + monsterMsg = + if canSee + then case L.find (\ m -> bloc m == loc) (IM.elems hms) of + Just m -> actorVerb coactor m "be" "here" ++ " " + Nothing -> "" + else "" + vis | not $ loc `IS.member` totalVisible per = + " (not visible)" -- by party + | actorReachesLoc pl loc per (Just pl) = "" + | otherwise = " (not reachable)" -- by hero + mode = case target of + TEnemy _ _ -> "[targeting monster" ++ vis ++ "] " + TLoc _ -> "[targeting location" ++ vis ++ "] " + TPath _ -> "[targeting path" ++ vis ++ "] " + TCursor -> "[targeting current" ++ vis ++ "] " + -- general info about current loc + lookMsg = mode ++ lookAt cops True canSee state lvl loc monsterMsg + -- check if there's something lying around at current loc + is = lvl `rememberAtI` loc + io <- itemOverlay False False is + if length is > 2 + then displayOverlays lookMsg io + else do + fr <- drawPrompt ColorFull lookMsg + return ((), [Just fr]) gameVersion :: Action () gameVersion = do - Kind.COps{corule} <- contentOps - let pathsVersion = rpathsVersion $ stdRuleset corule + Kind.COps{corule} <- getCOps + let pathsVersion = rpathsVersion $ Kind.stdRuleset corule msg = "Version " ++ showVersion pathsVersion ++ " (frontend: " ++ frontendName ++ ", engine: LambdaHack " ++ showVersion Self.version ++ ")" diff --git a/Game/LambdaHack/Feature.hs b/Game/LambdaHack/Feature.hs --- a/Game/LambdaHack/Feature.hs +++ b/Game/LambdaHack/Feature.hs @@ -26,5 +26,5 @@ | Boring -- ^ items and stairs can be generated there | Exit -- ^ is a (not hidden) door, stair, etc. | Path -- ^ used for distinct paths throughout the level - | Secret !RollDice -- ^ tile is generated with this high secrecy value + | Secret !RollDice -- ^ discovering the secret will require this many turns deriving (Show, Read, Eq, Ord) diff --git a/Game/LambdaHack/Grammar.hs b/Game/LambdaHack/Grammar.hs --- a/Game/LambdaHack/Grammar.hs +++ b/Game/LambdaHack/Grammar.hs @@ -3,21 +3,22 @@ ( -- * Grammar types Verb, Object -- * General operations - , capitalize, suffixS, addIndefinite + , capitalize, pluralise, addIndefinite -- * Objects from content - , objectItem, objectActor, capActor + , objectItemCheat, objectItem, objectActor, capActor -- * Sentences - , actorVerb, actorVerbExtra, actorVerbItemExtra - , actorVerbActorExtra, actorVerbExtraItemExtra + , actorVerb, actorVerbItem, actorVerbActor, actorVerbExtraItem -- * Scenery description , lookAt ) where import Data.Char import qualified Data.Set as S +import qualified Data.Map as M import qualified Data.List as L import Data.Maybe +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Point import Game.LambdaHack.Item import Game.LambdaHack.Actor @@ -35,25 +36,90 @@ -- | The grammatical object type. type Object = String +-- | Nouns with irregular plural spelling. +-- See http://en.wikipedia.org/wiki/English_plural. +irregularPlural :: M.Map String String +irregularPlural = M.fromList + [ ("canto" , "cantos") + , ("homo " , "homos") + , ("photo" , "photos") + , ("zero" , "zeros") + , ("piano" , "pianos") + , ("portico", "porticos") + , ("pro" , "pros") + , ("quarto" , "quartos") + , ("kimono" , "kimonos") + , ("calf" , "calves") + , ("leaf" , "leaves") + , ("knife" , "knives") + , ("life" , "lives") + , ("dwarf" , "dwarves") + , ("hoof" , "hooves") + , ("elf" , "elves") + , ("staff" , "staves") + , ("child" , "children") + , ("foot" , "feet") + , ("goose" , "geese") + , ("louse" , "lice") + , ("man" , "men") + , ("mouse" , "mice") + , ("tooth" , "teeth") + , ("woman" , "women") + ] + +-- | The list of words with identical singular and plural form. +-- See http://en.wikipedia.org/wiki/English_plural. +noPlural :: S.Set String +noPlural = S.fromList + [ "buffalo" + , "deer" + , "moose" + , "sheep" + , "bison" + , "salmon" + , "pike" + , "trout" + , "swine" + , "aircraft" + , "watercraft" + , "spacecraft" + , "hovercraft" + , "information" + ] + -- | Tests if a character is a vowel (@u@ is too hard, so is @eu@). vowel :: Char -> Bool vowel l = l `elem` "aeio" -- | Adds the plural (@s@, @es@, @ies@) suffix to a word. +-- Used also for conjugation. -- See http://en.wikipedia.org/wiki/English_plural. suffixS :: String -> String suffixS word = case L.reverse word of - 'h' : 'c' : _ -> word ++ "es" - 'h' : 's' : _ -> word ++ "es" - 'i' : 's' : _ -> word ++ "es" - 's' : _ -> word ++ "es" - 'z' : _ -> word ++ "es" - 'x' : _ -> word ++ "es" - 'j' : _ -> word ++ "es" - 'o' : l : _ | not (vowel l) -> init word ++ "es" - 'y' : l : _ | not (vowel l) -> init word ++ "ies" - _ -> word ++ "s" + 'h' : 'c' : _ -> word ++ "es" + 'h' : 's' : _ -> word ++ "es" + 'i' : 's' : _ -> word ++ "es" + 's' : _ -> word ++ "es" + 'z' : _ -> word ++ "es" + 'x' : _ -> word ++ "es" + 'j' : _ -> word ++ "es" + 'o' : l : _ | not (vowel l) -> init word ++ "es" + 'y' : l : _ | not (vowel l) -> init word ++ "ies" + _ -> word ++ "s" +-- TODO: a suffix tree would be best, to catch ableman, seaman, etc. +pluralise :: Object -> Object +pluralise phrase = + case reverse $ words phrase of + [] -> assert `failure` "pluralise: no words" + word : rest -> + let pl = if word `S.member` noPlural + then word + else case M.lookup word irregularPlural of + Just plural -> plural + Nothing -> suffixS word + in unwords $ reverse $ pl : rest + conjugate :: String -> Verb -> Verb conjugate "you" "be" = "are" conjugate "You" "be" = "are" @@ -76,13 +142,15 @@ -- | Transform an object, adding a count and a plural suffix. makeObject :: Int -> (Object -> Object) -> Object -> Object makeObject 1 f obj = addIndefinite $ f obj -makeObject n f obj = show n ++ " " ++ f (suffixS obj) +makeObject n f obj = show n ++ " " ++ f (pluralise obj) -- TODO: when there's more of the above, split and move to Utils/ -- | How to refer to an item in object position of a sentence. -objectItem :: Kind.Ops ItemKind -> State -> Item -> Object -objectItem coitem@Kind.Ops{okind} state i = +-- If cheating is allowed, full identity of the object is revealed +-- together with its flavour (e.g. at game over screen). +objectItemCheat :: Kind.Ops ItemKind -> Bool -> State -> Item -> Object +objectItemCheat coitem@Kind.Ops{okind} cheat state i = let ik = jkind i kind = okind ik identified = L.length (iflavour kind) == 1 || @@ -90,12 +158,21 @@ addSpace s = if s == "" then "" else " " ++ s eff = effectToSuffix (ieffect kind) pwr = if jpower i == 0 then "" else "(+" ++ show (jpower i) ++ ")" - adj name = if identified - then name ++ addSpace eff ++ addSpace pwr - else let flavour = getFlavour coitem (sflavour state) ik - in flavourToName flavour ++ " " ++ name + adj name = + let known = name ++ addSpace eff ++ addSpace pwr + flavour = getFlavour coitem (sflavour state) ik + obscured = flavourToName flavour ++ " " ++ name + in if identified + then known + else if cheat + then flavourToName flavour ++ " " ++ known + else obscured in makeObject (jcount i) adj (iname kind) +-- | How to refer to an item in object position of a sentence. +objectItem :: Kind.Ops ItemKind -> State -> Item -> Object +objectItem coitem = objectItemCheat coitem False + -- | How to refer to an actor in object position of a sentence. objectActor :: Kind.Ops ActorKind -> Actor -> Object objectActor Kind.Ops{oname} a = @@ -105,38 +182,42 @@ capActor :: Kind.Ops ActorKind -> Actor -> Object capActor coactor x = capitalize $ objectActor coactor x --- | Sentences such as \"Dog barks.\" -actorVerb :: Kind.Ops ActorKind -> Actor -> Verb -> String -actorVerb coactor a v = +-- | Sentences such as \"Dog barks loudly.\" +actorVerb :: Kind.Ops ActorKind -> Actor -> Verb -> String-> String +actorVerb coactor a v extra = let cactor = capActor coactor a verb = conjugate cactor v - in cactor ++ " " ++ verb ++ "." - --- | Sentences such as \"Dog barks loudly.\" -actorVerbExtra :: Kind.Ops ActorKind -> Actor -> Verb -> String-> String -actorVerbExtra coactor a v extra = - L.init (actorVerb coactor a v) ++ " " ++ extra ++ "." + ending | null extra = "." + | otherwise = " " ++ extra ++ "." + in cactor ++ " " ++ verb ++ ending -- | Sentences such as \"Dog quaffs a red potion fast.\" -actorVerbItemExtra :: Kind.COps -> State -> Actor -> Verb -> Item -> String +actorVerbItem :: Kind.COps -> State -> Actor -> Verb -> Item -> String -> String -actorVerbItemExtra Kind.COps{coactor, coitem} state a v i extra = - actorVerbExtra coactor a v $ - objectItem coitem state i ++ extra +actorVerbItem Kind.COps{coactor, coitem} state a v i extra = + let ending | null extra = "" + | otherwise = " " ++ extra + in actorVerb coactor a v $ + objectItem coitem state i ++ ending -- | Sentences such as \"Dog bites goblin furiously.\" -actorVerbActorExtra :: Kind.Ops ActorKind -> Actor -> Verb -> Actor -> String +actorVerbActor :: Kind.Ops ActorKind -> Actor -> Verb -> Actor -> String -> String -actorVerbActorExtra coactor a v b extra = - actorVerbExtra coactor a v $ - objectActor coactor b ++ extra +actorVerbActor coactor a v b extra = + let ending | null extra = "" + | otherwise = " " ++ extra + in actorVerb coactor a v $ + objectActor coactor b ++ ending -- | Sentences such as \"Dog gulps down a red potion fast.\" -actorVerbExtraItemExtra :: Kind.COps -> State -> Actor -> Verb -> String +actorVerbExtraItem :: Kind.COps -> State -> Actor -> Verb -> String -> Item -> String -> String -actorVerbExtraItemExtra Kind.COps{coactor, coitem} state a v extra1 i extra2 = - actorVerbExtra coactor a v $ - extra1 ++ " " ++ objectItem coitem state i ++ extra2 +actorVerbExtraItem Kind.COps{coactor, coitem} state a v extra1 i extra2 = + assert (not $ null extra1) $ + let ending | null extra2 = "" + | otherwise = " " ++ extra2 + in actorVerb coactor a v $ + extra1 ++ " " ++ objectItem coitem state i ++ ending -- | Produces a textual description of the terrain and items at an already -- explored location. Mute for unknown locations. @@ -158,12 +239,10 @@ where is = lvl `rememberAtI` loc prefixSee = if canSee then "You see " else "You remember " - prefixThere = if canSee - then "There are several objects here" - else "You remember several objects here" isd = case is of [] -> "" [i] -> prefixSee ++ objectItem coitem s i ++ "." [i,j] -> prefixSee ++ objectItem coitem s i ++ " and " ++ objectItem coitem s j ++ "." - _ -> prefixThere ++ if detailed then ":" else "." + _ | detailed -> "Objects:" + _ -> "Objects here." diff --git a/Game/LambdaHack/HighScore.hs b/Game/LambdaHack/HighScore.hs --- a/Game/LambdaHack/HighScore.hs +++ b/Game/LambdaHack/HighScore.hs @@ -1,6 +1,6 @@ -- | High score table operations. module Game.LambdaHack.HighScore - ( Status(..), ScoreRecord(..), ScoreTable, restore, register, slideshow + ( Status(..), ScoreRecord(..), register ) where import System.Directory @@ -14,6 +14,8 @@ import qualified Game.LambdaHack.Config as Config import Game.LambdaHack.Dungeon import Game.LambdaHack.Misc +import Game.LambdaHack.Time +import Game.LambdaHack.Msg -- TODO: add heroes' names, exp and level, cause of death, user number/name. -- Note: I tried using Date.Time, but got all kinds of problems, @@ -25,7 +27,7 @@ -- from the best to the worst, in lexicographic ordering wrt the fields below. data ScoreRecord = ScoreRecord { points :: !Int -- ^ the score - , negTurn :: !Int -- ^ number of turns (negated, so less better) + , negTime :: !Time -- ^ game time spent (negated, so less better) , date :: !ClockTime -- ^ date of the last game interruption , status :: !Status -- ^ reason of the game interruption } @@ -36,7 +38,7 @@ Killed !LevelId -- ^ the player lost the game on the given level | Camping -- ^ game is supended | Victor -- ^ the player won - deriving (Eq, Ord) + deriving (Show, Eq, Ord) instance Binary Status where put (Killed ln) = putWord8 0 >> put ln @@ -66,19 +68,28 @@ return (ScoreRecord p n (TOD cs cp) s) -- | Show a single high score, from the given ranking in the high score table. -showScore :: (Int, ScoreRecord) -> String +showScore :: (Int, ScoreRecord) -> [String] showScore (pos, score) = let died = case status score of Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ "," Camping -> "is camping somewhere," Victor -> "emerged victorious" - time = calendarTimeToString . toUTCTime . date $ score + curDate = calendarTimeToString . toUTCTime . date $ score big = " " lil = " " - steps = negTurn score `div` (-10) - in printf - "%s\n%4d. %6d This adventuring party %s after %d steps \n%son %s. \n" - big pos (points score) died steps lil time + turns = - (negTime score `timeFit` timeTurn) + -- TODO: the spaces at the end are hand-crafted. Remove when display + -- of overlays adds such spaces automatically. + in [ printf + "%s" + big + , printf + "%4d. %6d This adventuring party %s after %d turns " + pos (points score) died turns + , printf + "%son %s. " + lil curDate + ] -- | The list of scores, in decreasing order. type ScoreTable = [ScoreRecord] @@ -114,14 +125,14 @@ -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown. -showTable :: ScoreTable -> Int -> Int -> String +showTable :: ScoreTable -> Int -> Int -> Overlay showTable h start height = let zipped = zip [1..] h screenful = take height . drop (start - 1) $ zipped - in L.concatMap showScore screenful + in concatMap showScore screenful -- | Produce a couple of renderings of the high scores table. -slideshow :: Int -> ScoreTable -> Int -> [String] +slideshow :: Int -> ScoreTable -> Int -> [Overlay] slideshow pos h height = if pos <= height then [showTable h 1 height] @@ -130,7 +141,7 @@ -- | Take care of saving a new score to the table -- and return a list of messages to display. -register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String]) +register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [Overlay]) register config write s = do h <- restore config let (h', pos) = insertPos s h diff --git a/Game/LambdaHack/Item.hs b/Game/LambdaHack/Item.hs --- a/Game/LambdaHack/Item.hs +++ b/Game/LambdaHack/Item.hs @@ -32,6 +32,7 @@ import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Random import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Color as Color import Game.LambdaHack.Flavour import qualified Game.LambdaHack.Kind as Kind @@ -239,9 +240,10 @@ strongestItem bitems $ \ i -> (ieffect $ okind $ jkind i) == Searching -- TODO: generalise, in particular take base damage into account -strongestSword :: Kind.Ops ItemKind -> [Item] -> Maybe Item -strongestSword Kind.Ops{osymbol} bitems = - strongestItem bitems $ \ i -> (osymbol $ jkind i) == ')' +strongestSword :: Kind.COps -> [Item] -> Maybe Item +strongestSword Kind.COps{coitem=Kind.Ops{osymbol}, corule} bitems = + strongestItem bitems $ \ i -> (osymbol $ jkind i) + `elem` (ritemMelee $ Kind.stdRuleset corule) strongestRegen :: Kind.Ops ItemKind -> [Item] -> Maybe Item strongestRegen Kind.Ops{okind} bitems = diff --git a/Game/LambdaHack/ItemAction.hs b/Game/LambdaHack/ItemAction.hs --- a/Game/LambdaHack/ItemAction.hs +++ b/Game/LambdaHack/ItemAction.hs @@ -9,6 +9,7 @@ import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe +import Data.Ord import qualified Data.IntSet as IS import Game.LambdaHack.Utils.Assert @@ -25,18 +26,17 @@ import Game.LambdaHack.EffectAction import qualified Game.LambdaHack.Kind as Kind import Game.LambdaHack.Content.ItemKind -import qualified Game.LambdaHack.Feature as F -import qualified Game.LambdaHack.Tile as Tile +import Game.LambdaHack.Time -- | Display inventory -inventory :: Action () +inventory :: ActionFrame () inventory = do items <- gets getPlayerItem if L.null items then abortWith "Not carrying anything." else do - displayItems "Carrying:" True items - abort + io <- itemOverlay True False items + displayOverlays "Carrying:" io -- | Let the player choose any item with a given group name. -- Note that this does not guarantee the chosen item belongs to the group, @@ -46,11 +46,11 @@ -> [Char] -- ^ accepted item symbols -> String -- ^ prompt -> String -- ^ how to refer to the collection of objects - -> Action (Maybe Item) + -> Action Item getGroupItem is object syms prompt packName = do - Kind.Ops{osymbol} <- contentf Kind.coitem + Kind.COps{coitem=Kind.Ops{osymbol}} <- getCOps let choice i = osymbol (jkind i) `elem` syms - header = capitalize $ suffixS object + header = capitalize $ pluralise object getItem prompt choice header is packName applyGroupItem :: ActorId -- ^ actor applying the item (is on current level) @@ -58,124 +58,144 @@ -> Item -- ^ the item to be applied -> Action () applyGroupItem actor verb item = do - cops <- contentOps + cops <- getCOps state <- get body <- gets (getActor actor) - per <- currentPerception + per <- getPerception -- only one item consumed, even if several in inventory let consumed = item { jcount = 1 } - msg = actorVerbItemExtra cops state body verb consumed "" + msg = actorVerbItem cops state body verb consumed "" loc = bloc body removeFromInventory actor consumed loc when (loc `IS.member` totalVisible per) $ msgAdd msg itemEffectAction 5 actor actor consumed - advanceTime actor playerApplyGroupItem :: Verb -> Object -> [Char] -> Action () playerApplyGroupItem verb object syms = do - Kind.Ops{okind} <- contentf Kind.coitem + Kind.COps{coitem=Kind.Ops{okind}} <- getCOps is <- gets getPlayerItem - iOpt <- getGroupItem is object syms + item <- getGroupItem is object syms ("What to " ++ verb ++ "?") "in inventory" pl <- gets splayer - case iOpt of - Just i -> applyGroupItem pl (iverbApply $ okind $ jkind i) i - Nothing -> neverMind True + applyGroupItem pl (iverbApply $ okind $ jkind item) item projectGroupItem :: ActorId -- ^ actor projecting the item (is on current lvl) - -> Point -- ^ target location for the projecting + -> Point -- ^ target location of the projectile -> Verb -- ^ how the projecting is called -> Item -- ^ the item to be projected -> Action () -projectGroupItem source loc verb item = do - cops@Kind.COps{coactor, cotile} <- contentOps +projectGroupItem source tloc _verb item = do + cops@Kind.COps{coactor} <- getCOps state <- get sm <- gets (getActor source) - per <- currentPerception + per <- getPerception + pl <- gets splayer + Actor{btime} <- gets getPlayerBody lvl <- gets slevel - let -- TODO: refine for, e.g., wands of digging that are aimed into walls. - locWalkable = Tile.hasFeature cotile F.Walkable (lvl `at` loc) - consumed = item { jcount = 1 } + ceps <- gets (ceps . scursor) + lxsize <- gets (lxsize . slevel) + lysize <- gets (lysize . slevel) + let consumed = item { jcount = 1 } sloc = bloc sm + sourceVis = sloc `IS.member` totalVisible per subject = - if sloc `IS.member` totalVisible per + if sourceVis then sm else template (heroKindId coactor) - Nothing (Just "somebody") 99 sloc - msg = actorVerbItemExtra cops state subject verb consumed "" - removeFromInventory source consumed sloc - case locToActor loc state of - Just ta -> do - -- The msg describes the source part of the action. - when (sloc `IS.member` totalVisible per || isAHero ta) $ msgAdd msg - -- Msgs inside itemEffectAction describe the target part. - b <- itemEffectAction 10 source ta consumed - unless b $ modify (updateLevel (dropItemsAt [consumed] loc)) - Nothing | locWalkable -> do - when (sloc `IS.member` totalVisible per) $ msgAdd msg - modify (updateLevel (dropItemsAt [consumed] loc)) - _ -> abortWith "blocked" - advanceTime source + Nothing (Just "somebody") 99 sloc timeZero animalParty + -- When projecting, the first turn is spent aiming. + -- The projectile is seen one tile from the actor, giving a hint + -- about the aim and letting the target evade. + msg = actorVerbItem cops state subject "aim" consumed "" + -- TODO: AI should choose the best eps. + eps = if source == pl then ceps else 0 + -- Setting monster's projectiles time to player time ensures + -- the projectile covers the whole normal distance already the first + -- turn that the player observes it moving. This removes + -- the possibility of micromanagement by, e.g., waiting until + -- the first distance is short. + -- If and when monster all move at once, player's projectiles + -- should be set to the time of the opposite party as well. + -- Both parties would see their own projectiles move part of the way + -- and the opposite party's projectiles waiting one turn. + (party, time) = + if bparty sm == heroParty || source == pl + then (heroProjectiles, timeAdd btime (timeNegate timeClip)) + else (enemyProjectiles, btime) + bl = bla lxsize lysize eps sloc tloc + case bl of + Nothing -> abortWith "cannot zap oneself" + Just [] -> assert `failure` (sloc, tloc, "project from the edge of level") + Just path@(loc:_) -> do + let projVis = loc `IS.member` totalVisible per + removeFromInventory source consumed sloc + inhabitants <- gets (locToActor loc) + if accessible cops lvl sloc loc && isNothing inhabitants + then + modify $ addProjectile cops consumed loc party path time + else + abortWith "blocked" + when (sourceVis || projVis) $ msgAdd msg -playerProjectGroupItem :: Verb -> Object -> [Char] -> Action () +playerProjectGroupItem :: Verb -> Object -> [Char] -> ActionFrame () playerProjectGroupItem verb object syms = do - ms <- gets (lmonsters . slevel) + ms <- gets hostileList lxsize <- gets (lxsize . slevel) ploc <- gets (bloc . getPlayerBody) - if L.any (adjacent lxsize ploc) (L.map bloc $ IM.elems ms) + if L.any (adjacent lxsize ploc) $ L.map bloc $ + L.filter (\ m -> bparty m `notElem` allProjectiles) ms then abortWith "You can't aim in melee." else playerProjectGI verb object syms -playerProjectGI :: Verb -> Object -> [Char] -> Action () +playerProjectGI :: Verb -> Object -> [Char] -> ActionFrame () playerProjectGI verb object syms = do state <- get pl <- gets splayer ploc <- gets (bloc . getPlayerBody) - per <- currentPerception + per <- getPerception let retarget msg = do msgAdd msg - updatePlayerBody (\ p -> p { btarget = TCursor }) - let upd cursor = cursor {clocation=ploc} + let upd cursor = cursor {clocation=ploc, ceps=0} modify (updateCursor upd) - targetMonster TgtAuto - -- TODO: draw digital line and see if obstacles prevent firing - -- TODO: don't tell the player if the tiles he can't see are reachable, - -- but let him throw there and let them land closer, if not reachable - -- TODO: similarly let him throw at walls and land in front (digital line) - case targetToLoc (totalVisible per) state of - Just loc | actorReachesLoc pl loc per (Just pl) -> do - Kind.Ops{okind} <- contentf Kind.coitem + frs <- targetMonster TgtAuto + -- Mark that unexpectedly it does not take time. + modify (\ s -> s {snoTime = True}) + return frs + case targetToLoc (totalVisible per) state ploc of + Just loc -> do + Kind.COps{coitem=Kind.Ops{okind}} <- getCOps is <- gets getPlayerItem - iOpt <- getGroupItem is object syms + item <- getGroupItem is object syms ("What to " ++ verb ++ "?") "in inventory" targeting <- gets (ctargeting . scursor) when (targeting == TgtAuto) $ endTargeting True - case iOpt of - Just i -> projectGroupItem pl loc (iverbProject $ okind $ jkind i) i - Nothing -> neverMind True - Just _ -> retarget "Last target unreachable." + projectGroupItem pl loc (iverbProject $ okind $ jkind item) item + returnNoFrame () Nothing -> retarget "Last target invalid." --- TODO: also target a monster by moving the cursor, if in target monster mode. --- TODO: sort monsters by distance to the player. - -- | Start the monster targeting mode. Cycle between monster targets. -targetMonster :: TgtMode -> Action () +targetMonster :: TgtMode -> ActionFrame () targetMonster tgtMode = do pl <- gets splayer - ms <- gets (lmonsters . slevel) - per <- currentPerception + ploc <- gets (bloc . getPlayerBody) + ms <- gets (hostileAssocs . slevel) + per <- getPerception + lxsize <- gets (lxsize . slevel) target <- gets (btarget . getPlayerBody) targeting <- gets (ctargeting . scursor) - let i = case target of - TEnemy (AMonster n) _ | targeting /= TgtOff -> n -- next monster - TEnemy (AMonster n) _ -> n - 1 -- try to retarget old monster - _ -> -1 -- try to target first monster (e.g., number 0) - dms = case pl of - AMonster n -> IM.delete n ms -- don't target yourself - AHero _ -> ms - (lt, gt) = IM.split i dms - gtlt = IM.assocs gt ++ IM.assocs lt + -- TODO: sort monsters by distance to the player. + let plms = L.filter ((/= pl) . fst) ms -- don't target yourself + ordLoc (_, m) = (chessDist lxsize ploc $ bloc m, bloc m) + dms = L.sortBy (comparing ordLoc) plms + (lt, gt) = case target of + TEnemy n _ | targeting /= TgtOff -> -- pick the next monster + let i = fromMaybe (-1) $ L.findIndex ((== n) . fst) dms + in L.splitAt (i + 1) dms + TEnemy n _ -> -- try to retarget the old monster + let i = fromMaybe (-1) $ L.findIndex ((== n) . fst) dms + in L.splitAt i dms + _ -> (dms, []) -- target first monster (e.g., number 0) + gtlt = gt ++ lt seen (_, m) = let mloc = bloc m in mloc `IS.member` totalVisible per -- visible by any @@ -183,66 +203,84 @@ lf = L.filter seen gtlt tgt = case lf of [] -> target -- no monsters in sight, stick to last target - (na, nm) : _ -> TEnemy (AMonster na) (bloc nm) -- pick the next + (na, nm) : _ -> TEnemy na (bloc nm) -- pick the next + -- Register the chosen monster, to pick another on next invocation. updatePlayerBody (\ p -> p { btarget = tgt }) setCursor tgtMode -- | Start the floor targeting mode or reset the cursor location to the player. -targetFloor :: TgtMode -> Action () +targetFloor :: TgtMode -> ActionFrame () targetFloor tgtMode = do ploc <- gets (bloc . getPlayerBody) target <- gets (btarget . getPlayerBody) targeting <- gets (ctargeting . scursor) let tgt = case target of - _ | targeting /= TgtOff -> TLoc ploc -- double key press: reset cursor TEnemy _ _ -> TCursor -- forget enemy target, keep the cursor + _ | targeting /= TgtOff -> TLoc ploc -- double key press: reset cursor + TPath _ -> TCursor t -> t -- keep the target from previous targeting session + -- Register that we want to target only locations. updatePlayerBody (\ p -> p { btarget = tgt }) setCursor tgtMode -- | Set, activate and display cursor information. -setCursor :: TgtMode -> Action () +setCursor :: TgtMode -> ActionFrame () setCursor tgtMode = assert (tgtMode /= TgtOff) $ do state <- get - per <- currentPerception + per <- getPerception ploc <- gets (bloc . getPlayerBody) clocLn <- gets slid - let upd cursor@Cursor{ctargeting} = - let clocation = fromMaybe ploc (targetToLoc (totalVisible per) state) + let upd cursor@Cursor{ctargeting, clocation=clocationOld, ceps=cepsOld} = + let clocation = + fromMaybe ploc (targetToLoc (totalVisible per) state ploc) + ceps = if clocation == clocationOld then cepsOld else 0 newTgtMode = if ctargeting == TgtOff then tgtMode else ctargeting - in cursor { ctargeting = newTgtMode, clocation, clocLn } + in cursor { ctargeting = newTgtMode, clocation, clocLn, ceps } modify (updateCursor upd) doLook +-- | Tweak the @eps@ parameter of the targeting digital line. +epsIncr :: Bool -> Action () +epsIncr b = do + targeting <- gets (ctargeting . scursor) + if targeting /= TgtOff + then modify $ updateCursor $ + \ c@Cursor{ceps} -> c {ceps = ceps + if b then 1 else -1} + else neverMind True -- no visual feedback, so no sense + -- | End targeting mode, accepting the current location or not. endTargeting :: Bool -> Action () endTargeting accept = do returnLn <- gets (creturnLn . scursor) target <- gets (btarget . getPlayerBody) - per <- currentPerception + per <- getPerception cloc <- gets (clocation . scursor) - ms <- gets (lmonsters . slevel) - -- return to the original level of the player - modify (\ state -> state {slid = returnLn}) + ms <- gets (hostileAssocs . slevel) + -- Return to the original level of the player. Note that this can be + -- a different level than the one we started targeting at, + -- if the player was changed while targeting. + switchLevel returnLn modify (updateCursor (\ c -> c { ctargeting = TgtOff })) - case target of - TEnemy _ _ -> do - let canSee = IS.member cloc (totalVisible per) - when (accept && canSee) $ - case L.find (\ (_im, m) -> bloc m == cloc) (IM.assocs ms) of - Just (im, m) -> - let tgt = TEnemy (AMonster im) (bloc m) - in updatePlayerBody (\ p -> p { btarget = tgt }) - Nothing -> return () - _ -> - if accept - then updatePlayerBody (\ p -> p { btarget = TLoc cloc }) - else updatePlayerBody (\ p -> p { btarget = TCursor }) - endTargetingMsg + when accept $ do + case target of + TEnemy _ _ -> do + -- If in monster targeting mode, switch to the monster under + -- the current cursor location, if any. + let canSee = IS.member cloc (totalVisible per) + when (accept && canSee) $ + case L.find (\ (_im, m) -> bloc m == cloc) ms of + Just (im, m) -> + let tgt = TEnemy im (bloc m) + in updatePlayerBody (\ p -> p { btarget = tgt }) + Nothing -> return () + _ -> updatePlayerBody (\ p -> p { btarget = TLoc cloc }) + if accept + then endTargetingMsg + else msgAdd "targeting canceled" endTargetingMsg :: Action () endTargetingMsg = do - cops <- contentf Kind.coactor + Kind.COps{coactor} <- getCOps pbody <- gets getPlayerBody state <- get lxsize <- gets (lxsize . slevel) @@ -250,11 +288,12 @@ targetMsg = case btarget pbody of TEnemy a _ll -> if memActor a state - then objectActor cops $ getActor a state + then objectActor coactor $ getActor a state else "a fear of the past" TLoc loc -> "location " ++ showPoint lxsize loc + TPath _ -> "a path" TCursor -> "current cursor position continuously" - msgAdd $ actorVerbExtra cops pbody verb targetMsg + msgAdd $ actorVerb coactor pbody verb targetMsg -- | Cancel something, e.g., targeting mode, resetting the cursor -- to the position of the player. Chosen target is not invalidated. @@ -267,32 +306,28 @@ -- | Accept something, e.g., targeting mode, keeping cursor where it was. -- Or perform the default action, if nothing needs accepting. -acceptCurrent :: Action () -> Action () +acceptCurrent :: ActionFrame () -> ActionFrame () acceptCurrent h = do targeting <- gets (ctargeting . scursor) if targeting /= TgtOff - then endTargeting True + then inFrame $ endTargeting True else h -- nothing to accept right now -- | Drop a single item. dropItem :: Action () dropItem = do -- TODO: allow dropping a given number of identical items. - cops <- contentOps + cops <- getCOps pl <- gets splayer state <- get pbody <- gets getPlayerBody ploc <- gets (bloc . getPlayerBody) - items <- gets getPlayerItem - iOpt <- getAnyItem "What to drop?" items "inventory" - case iOpt of - Just stack -> do - let i = stack { jcount = 1 } - removeOnlyFromInventory pl i (bloc pbody) - msgAdd (actorVerbItemExtra cops state pbody "drop" i "") - modify (updateLevel (dropItemsAt [i] ploc)) - Nothing -> neverMind True - playerAdvanceTime + ims <- gets getPlayerItem + stack <- getAnyItem "What to drop?" ims "in inventory" + let item = stack { jcount = 1 } + removeOnlyFromInventory pl item (bloc pbody) + msgAdd (actorVerbItem cops state pbody "drop" item "") + modify (updateLevel (dropItemsAt [item] ploc)) -- TODO: this is a hack for dropItem, because removeFromInventory -- makes it impossible to drop items if the floor not empty. @@ -332,10 +367,10 @@ actorPickupItem :: ActorId -> Action () actorPickupItem actor = do - cops@Kind.COps{coitem} <- contentOps + cops@Kind.COps{coitem} <- getCOps state <- get pl <- gets splayer - per <- currentPerception + per <- getPerception lvl <- gets slevel body <- gets (getActor actor) bitems <- gets (getActorItem actor) @@ -344,7 +379,7 @@ isPlayer = actor == pl -- check if something is here to pick up case lvl `atI` loc of - [] -> abortIfWith isPlayer "nothing here" + [] -> abortWith "nothing here" i:is -> -- pick up first item; TODO: let pl select item; not for monsters case assignLetter (jletter i) (bletter body) bitems of Just l -> do @@ -352,18 +387,17 @@ -- msg depends on who picks up and if a hero can perceive it if isPlayer then msgAdd (letterLabel (jletter ni) - ++ objectItem coitem state ni) + ++ objectItem coitem state ni ++ ".") else when perceived $ msgAdd $ - actorVerbExtraItemExtra cops state body "pick" "up" i "" + actorVerbExtraItem cops state body "pick" "up" i "" removeFromLoc i loc >>= assert `trueM` (i, is, loc, "item is stuck") -- add item to actor's inventory: updateAnyActor actor $ \ m -> m { bletter = maxLetter l (bletter body) } modify (updateAnyActorItem actor (const nitems)) - Nothing -> abortIfWith isPlayer "cannot carry any more" - advanceTime actor + Nothing -> abortWith "cannot carry any more" pickupItem :: Action () pickupItem = do @@ -381,18 +415,19 @@ -- known. In actor handlers we should make sure -- that messages are printed to the player only if the -- hero can perceive the action. --- Perhaps this means half of this code should be split and moved --- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed. -- TODO: you can drop an item already the floor, which works correctly, -- but is weird and useless. +allObjectsName :: String +allObjectsName = "Objects" + -- | Let the player choose any item from a list of items. getAnyItem :: String -- ^ prompt -> [Item] -- ^ all items in question -> String -- ^ how to refer to the collection of items - -> Action (Maybe Item) -getAnyItem prompt = getItem prompt (const True) "Objects" + -> Action Item +getAnyItem prompt = getItem prompt (const True) allObjectsName data ItemDialogState = INone | ISuitable | IAll deriving Eq @@ -403,58 +438,59 @@ -> String -- ^ how to describe suitable items -> [Item] -- ^ all items in question -> String -- ^ how to refer to the collection of items - -> Action (Maybe Item) + -> Action Item getItem prompt p ptext is0 isn = do lvl <- gets slevel body <- gets getPlayerBody let loc = bloc body tis = lvl `atI` loc - floorMsg = if L.null tis then "" else " -," - is = L.filter p is0 + floorFull = not $ null tis + (floorMsg, floorKey) | floorFull = (", -", [K.Char '-']) + | otherwise = ("", []) + isp = L.filter p is0 + bestFull = not $ null isp + (bestMsg, bestKey) + | bestFull = + let bestLetter = maybe "" (\ l -> ['(', l, ')']) $ + jletter $ L.maximumBy cmpItemLM isp + in (", RET" ++ bestLetter, [K.Return]) + | otherwise = ("", []) cmpItemLM i1 i2 = cmpLetterMaybe (jletter i1) (jletter i2) + keys ims = + let mls = mapMaybe jletter ims + ks = bestKey ++ floorKey ++ [K.Char '?'] ++ map K.Char mls + in zip ks $ repeat K.NoModifier choice ims = - if L.null ims - then "[?," ++ floorMsg ++ " ESC]" + if null ims + then "[?" ++ floorMsg else let mls = mapMaybe jletter ims r = letterRange mls - ret = maybe "" (\ l -> ['(', l, ')']) $ - jletter $ L.maximumBy cmpItemLM ims - in "[" ++ r ++ ", ?," ++ floorMsg ++ " RET" ++ ret ++ ", ESC]" + in "[" ++ r ++ ", ?" ++ floorMsg ++ bestMsg ask = do when (L.null is0 && L.null tis) $ abortWith "Not carrying anything." - msgReset (prompt ++ " " ++ choice is) - displayAll - session nextCommand >>= perform ISuitable - perform itemDialogState command = do - let ims = if itemDialogState == INone then is0 else is - msgClear - case command of - K.Char '?' | itemDialogState == ISuitable -> do - -- filter for suitable items - b <- displayItems - (ptext ++ " " ++ isn ++ ". " ++ choice is) True is - if b then session (getOptionalConfirm (const ask) - (perform IAll)) - else ask - K.Char '?' | itemDialogState == IAll -> do - -- show all items - b <- displayItems - ("Objects " ++ isn ++ ". " ++ choice is0) True is0 - if b then session (getOptionalConfirm (const ask) - (perform INone)) - else ask - K.Char '?' | itemDialogState == INone -> ask - K.Char '-' -> - case tis of - [] -> return Nothing - i:_rs -> -- use first item; TODO: let player select item - return $ Just i - K.Char l -> - return (L.find (maybe False (== l) . jletter) ims) - K.Return -> - if L.null ims - then return Nothing - else return $ Just $ L.maximumBy cmpItemLM ims - _ -> return Nothing + perform INone + perform itemDialogState = do + let (ims, imsOver, msg) = case itemDialogState of + INone -> (isp, [], prompt ++ " ") + ISuitable -> (isp, isp, ptext ++ " " ++ isn ++ ". ") + IAll -> (is0, is0, allObjectsName ++ " " ++ isn ++ ". ") + io <- itemOverlay True False imsOver + (command, modifier) <- + displayChoiceUI (msg ++ choice ims) io (keys ims) + assert (modifier == K.NoModifier) $ + case command of + K.Char '?' -> case itemDialogState of + INone -> perform ISuitable + ISuitable | ptext /= allObjectsName -> perform IAll + _ -> perform INone + K.Char '-' | floorFull -> + -- TODO: let player select item + return $ L.maximumBy cmpItemLM tis + K.Char l | l `elem` mapMaybe jletter ims -> + let mitem = L.find (maybe False (== l) . jletter) ims + in return $ fromJust mitem + K.Return | bestFull -> + return $ L.maximumBy cmpItemLM isp + k -> assert `failure` "perform: unexpected key: " ++ show k ask diff --git a/Game/LambdaHack/Key.hs b/Game/LambdaHack/Key.hs --- a/Game/LambdaHack/Key.hs +++ b/Game/LambdaHack/Key.hs @@ -1,6 +1,7 @@ -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Key - ( Key(..), handleDir, moveBinding, keyTranslate + ( Key(..), handleDir, dirAllMoveKey + , moveBinding, keyTranslate, Modifier(..), showKM ) where import Prelude hiding (Left, Right) @@ -32,6 +33,12 @@ | Unknown !String -- ^ an unknown key, registered to warn the user deriving (Ord, Eq) +-- | Our own encoding of modifiers. Incomplete. +data Modifier = + Control + | NoModifier + deriving (Ord, Eq) + showKey :: Key -> String showKey (Char c) = [c] showKey Esc = "ESC" -- these three are common and terse abbreviations @@ -50,6 +57,11 @@ showKey (KP c) = "" showKey (Unknown s) = s +-- | Show a key with a modifier, if any. +showKM :: (Key, Modifier) -> String +showKM (key, Control) = "CTRL-" ++ showKey key +showKM (key, NoModifier) = showKey key + instance Show Key where show = showKey @@ -59,32 +71,51 @@ dirViMoveKey :: [Key] dirViMoveKey = map Char dirViChar -dirViRunKey :: [Key] -dirViRunKey = map (Char . Char.toUpper) dirViChar - dirMoveKey :: [Key] dirMoveKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left] +dirAllMoveKey :: [Key] +dirAllMoveKey = dirViMoveKey ++ dirMoveKey + +dirViRunKey :: [Key] +dirViRunKey = map (Char . Char.toUpper) dirViChar + dirRunKey :: [Key] -dirRunKey = map KP ['7', '8', '9', '6', '3', '2', '1', '4'] +dirRunKey = map KP dirNums +_dirAllRunKey :: [Key] +_dirAllRunKey = dirViRunKey ++ dirRunKey + +dirNums :: [Char] +dirNums = ['7', '8', '9', '6', '3', '2', '1', '4'] + +dirHeroKey :: [Key] +dirHeroKey = map Char dirNums + -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. -handleDir :: X -> Key -> (Vector -> a) -> a -> a -handleDir lxsize e h k = +handleDir :: X -> (Key, Modifier) -> (Vector -> a) -> a -> a +handleDir lxsize (key, NoModifier) h k = let mvs = moves lxsize - assocs = zip dirViMoveKey mvs ++ zip dirMoveKey mvs - in maybe k h (L.lookup e assocs) + assocs = zip dirAllMoveKey $ mvs ++ mvs + in maybe k h (L.lookup key assocs) +handleDir _lxsize _ _h k = k +-- TODO: deduplicate -- | Binding of both sets of movement keys. moveBinding :: ((X -> Vector) -> a) -> ((X -> Vector) -> a) - -> [(Key, (String, a))] + -> [((Key, Modifier), (String, Bool, a))] moveBinding move run = - let assign f (key, dir) = (key, ("", f dir)) - in map (assign move) (zip dirViMoveKey movesWidth) ++ - map (assign move) (zip dirMoveKey movesWidth) ++ - map (assign run) (zip dirViRunKey movesWidth) ++ - map (assign run) (zip dirRunKey movesWidth) + let assign f (km, dir) = (km, ("", True, f dir)) + rNoModifier = repeat NoModifier + rControl = repeat Control + in map (assign move) (zip (zip dirViMoveKey rNoModifier) movesWidth) ++ + map (assign move) (zip (zip dirMoveKey rNoModifier) movesWidth) ++ + map (assign run) (zip (zip dirViRunKey rNoModifier) movesWidth) ++ + map (assign run) (zip (zip dirRunKey rNoModifier) movesWidth) ++ + map (assign run) (zip (zip dirMoveKey rControl) movesWidth) ++ + map (assign run) (zip (zip dirRunKey rControl) movesWidth) ++ + map (assign run) (zip (zip dirHeroKey rControl) movesWidth) -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros @@ -104,6 +135,8 @@ keyTranslate "underscore" = Char '_' keyTranslate "minus" = Char '-' keyTranslate "KP_Subtract" = Char '-' +keyTranslate "plus" = Char '+' +keyTranslate "KP_Add" = Char '+' keyTranslate "bracketleft" = Char '[' keyTranslate "bracketright" = Char ']' keyTranslate "braceleft" = Char '{' diff --git a/Game/LambdaHack/Kind.hs b/Game/LambdaHack/Kind.hs --- a/Game/LambdaHack/Kind.hs +++ b/Game/LambdaHack/Kind.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Game.LambdaHack.Kind ( -- * General content types - Id, Speedup(..), Ops(..), COps(..), createOps + Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset -- * Arrays of content identifiers , Array, (!), (//), listArray, array, bounds ) where @@ -69,13 +69,14 @@ groupFreq group k = fromMaybe 0 (L.lookup group $ getFreq k) kindFreq :: String -> Frequency (Id a, a) kindFreq group = - toFreq [ (n, (Id i, k)) + toFreq ("kindFreq ('" ++ group ++ "')") + [ (n, (Id i, k)) | (i, k) <- kindAssocs, let n = groupFreq group k, n > 0 ] okind (Id i) = kindMap IM.! fromEnum i correct a = not (L.null (getName a)) && L.all ((> 0) . snd) (getFreq a) offenders = validate content in assert (allB correct content) $ - assert (L.null offenders `blame` offenders) $ + assert (L.null offenders `blame` ("content not validated:", offenders)) $ Ops { osymbol = getSymbol . okind , oname = getName . okind @@ -104,6 +105,10 @@ , corule :: !(Ops RuleKind) , cotile :: !(Ops TileKind) } + +-- | The standard ruleset used for level operations. +stdRuleset :: Ops RuleKind -> RuleKind +stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard" instance Show COps where show _ = "Game content." diff --git a/Game/LambdaHack/Level.hs b/Game/LambdaHack/Level.hs --- a/Game/LambdaHack/Level.hs +++ b/Game/LambdaHack/Level.hs @@ -2,13 +2,13 @@ -- as the game progresses. module Game.LambdaHack.Level ( -- * The @Level@ type and its components - Party, PartyItem, SmellMap, SecretMap, ItemMap, TileMap, Level(..) + ActorDict, InvDict, SmellMap, SecretMap, ItemMap, TileMap, Level(..) -- * Level update - , updateHeroes, updateMonsters, updateHeroItem, updateMonItem + , updateActorDict, updateInv , updateSmell, updateIMap, updateLMap, updateLRMap, dropItemsAt -- * Level query , at, rememberAt, atI, rememberAtI - , stdRuleset, accessible, openable, findLoc, findLocTry + , accessible, openable, findLoc, findLocTry ) where import Data.Binary @@ -26,18 +26,19 @@ import Game.LambdaHack.Tile import qualified Game.LambdaHack.Feature as F import qualified Game.LambdaHack.Kind as Kind +import Game.LambdaHack.Time --- | All actors of a given side on the level. -type Party = IM.IntMap Actor +-- | All actors on the level, indexed by actor identifier. +type ActorDict = IM.IntMap Actor --- | Items carried by each party member. -type PartyItem = IM.IntMap [Item] +-- | Items carried by actors, indexed by actor identifier. +type InvDict = IM.IntMap [Item] -- | Current smell on map tiles. type SmellMap = IM.IntMap SmellTime -- | Current secrecy value on map tiles. -type SecretMap = IM.IntMap SecretStrength +type SecretMap = IM.IntMap SecretTime -- | Actual and remembered item lists on map tiles. type ItemMap = IM.IntMap ([Item], [Item]) @@ -47,12 +48,10 @@ -- | A single, inhabited dungeon level. data Level = Level - { lheroes :: Party -- ^ all heroes on the level - , lheroItem :: PartyItem -- ^ hero items + { lactor :: ActorDict -- ^ all actors on the level + , linv :: InvDict -- ^ items belonging to actors , lxsize :: X -- ^ width of the level , lysize :: Y -- ^ height of the level - , lmonsters :: Party -- ^ all monsters on the level - , lmonItem :: PartyItem -- ^ monster items , lsmell :: SmellMap -- ^ smells , lsecret :: SecretMap -- ^ secrecy values , litem :: ItemMap -- ^ items on the ground @@ -61,18 +60,17 @@ , ldesc :: String -- ^ level description for the player , lmeta :: String -- ^ debug information from cave generation , lstairs :: (Point, Point) -- ^ destination of the (up, down) stairs + , ltime :: Time -- ^ date of the last activity on the level } deriving Show -- | Update the hero and monster maps. -updateHeroes, updateMonsters :: (Party -> Party) -> Level -> Level -updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) } -updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) } +updateActorDict :: (ActorDict -> ActorDict) -> Level -> Level +updateActorDict f lvl = lvl { lactor = f (lactor lvl) } -- | Update the hero items and monster items maps. -updateHeroItem, updateMonItem :: (PartyItem -> PartyItem) -> Level -> Level -updateHeroItem f lvl = lvl { lheroItem = f (lheroItem lvl) } -updateMonItem f lvl = lvl { lmonItem = f (lmonItem lvl) } +updateInv :: (InvDict -> InvDict) -> Level -> Level +updateInv f lvl = lvl { linv = f (linv lvl) } -- | Update the smell map. updateSmell :: (SmellMap -> SmellMap) -> Level -> Level @@ -98,13 +96,11 @@ in updateIMap (IM.alter adj loc) instance Binary Level where - put (Level hs hi sx sy ms mi ls le li lm lrm ld lme lstairs) = do - put hs - put hi + put (Level ad ia sx sy ls le li lm lrm ld lme lstairs ltime) = do + put ad + put ia put sx put sy - put ms - put mi put ls put le put (assert @@ -116,13 +112,12 @@ put ld put lme put lstairs + put ltime get = do - hs <- get - hi <- get + ad <- get + ia <- get sx <- get sy <- get - ms <- get - mi <- get ls <- get le <- get li <- get @@ -131,7 +126,8 @@ ld <- get lme <- get lstairs <- get - return (Level hs hi sx sy ms mi ls le li lm lrm ld lme lstairs) + ltime <- get + return (Level ad ia sx sy ls le li lm lrm ld lme lstairs ltime) -- | Query for actual and remembered tile kinds on the map. at, rememberAt :: Level -> Point -> Kind.Id TileKind @@ -144,28 +140,24 @@ atI Level{litem} p = fst $ IM.findWithDefault ([], []) p litem rememberAtI Level{litem} p = snd $ IM.findWithDefault ([], []) p litem --- | The standard ruleset used for level operations. -stdRuleset :: Kind.Ops RuleKind -> RuleKind -stdRuleset Kind.Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard" - -- | Check whether one location is accessible from another, -- using the formula from the standard ruleset. accessible :: Kind.COps -> Level -> Point -> Point -> Bool accessible Kind.COps{ cotile=Kind.Ops{okind=okind}, corule} lvl@Level{lxsize} sloc tloc = - let check = raccessible $ stdRuleset corule + let check = raccessible $ Kind.stdRuleset corule src = okind $ lvl `at` sloc tgt = okind $ lvl `at` tloc in check lxsize sloc src tloc tgt -- | Check whether the location contains a door of secrecy lower than @k@ -- and that can be opened according to the standard ruleset. -openable :: Kind.Ops TileKind -> Level -> SecretStrength -> Point -> Bool +openable :: Kind.Ops TileKind -> Level -> SecretTime -> Point -> Bool openable cops lvl@Level{lsecret} k target = let tgt = lvl `at` target in hasFeature cops F.Openable tgt || (hasFeature cops F.Hidden tgt && - lsecret IM.! target < k) + lsecret IM.! target <= k) -- | Find a random location on the map satisfying a predicate. findLoc :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point diff --git a/Game/LambdaHack/Misc.hs b/Game/LambdaHack/Misc.hs --- a/Game/LambdaHack/Misc.hs +++ b/Game/LambdaHack/Misc.hs @@ -1,14 +1,11 @@ -- | Hacks that haven't found their home yet. module Game.LambdaHack.Misc - ( normalLevelBound, Time, divUp, Freqs + ( normalLevelBound, divUp, Freqs ) where -- | Level bounds. TODO: query terminal size instead and scroll view. normalLevelBound :: (Int, Int) normalLevelBound = (79, 21) - --- | Game time in turns. The time dimension. -type Time = Int -- | Integer division, rounding up. divUp :: Int -> Int -> Int diff --git a/Game/LambdaHack/Msg.hs b/Game/LambdaHack/Msg.hs --- a/Game/LambdaHack/Msg.hs +++ b/Game/LambdaHack/Msg.hs @@ -1,50 +1,165 @@ -- | Game messages displayed on top of the screen for the player to read. module Game.LambdaHack.Msg - ( Msg, more, msgEnd, yesno, addMsg, splitMsg, padMsg + ( Msg, moreMsg, yesnoMsg, padMsg + , Report, emptyReport, nullReport, singletonReport, addMsg + , splitReport, renderReport + , History, emptyHistory, singletonHistory, addReport, renderHistory + , takeHistory + , Overlay, splitOverlay, stringByLocation ) where import qualified Data.List as L import Data.Char +import Data.Binary +import qualified Data.ByteString.Char8 as BS +import qualified Data.IntMap as IM --- | The type of messages. -type Msg = String +import Game.LambdaHack.Misc +import Game.LambdaHack.PointXY --- | The \"press something to see more\" mark. -more :: Msg -more = " --more-- " +-- | The type of a single message. +type Msg = String --- | The \"the end of overlays or messages\" mark. -msgEnd :: Msg -msgEnd = " --end-- " +-- | The \"press something to see more\" mark. +moreMsg :: Msg +moreMsg = " --more-- " -- | The confirmation request message. -yesno :: Msg -yesno = " [yn]" +yesnoMsg :: Msg +yesnoMsg = " [yn]" --- | Append two messages. -addMsg :: Msg -> Msg -> Msg -addMsg [] x = x -addMsg xs [] = xs -addMsg xs x = xs ++ " " ++ x +-- | Add spaces at the message end, for display overlayed over the level map. +-- Also trims (does not wrap!) too long lines. +padMsg :: X -> String -> String +padMsg w xs = + let len = length xs + rev = reverse xs + in case compare w len of + LT -> reverse $ '$' : drop (len - w + 1) rev + EQ -> xs + GT -> case rev of + [] -> xs + ' ' : _ -> xs + _ -> reverse $ ' ' : rev --- | Split a message into chunks that fit in one line. -splitMsg :: Int -> Msg -> Int -> [String] -splitMsg w xs m - | w <= m = [xs] -- border case, we cannot make progress - | w >= length xs = [xs] -- no problem, everything fits +-- | The type of a set of messages to show at the screen at once. +newtype Report = Report [(BS.ByteString, Int)] + deriving Show + +instance Binary Report where + put (Report x) = put x + get = fmap Report get + +-- | Empty set of messages. +emptyReport :: Report +emptyReport = Report [] + +-- | Test if the set of messages is empty. +nullReport :: Report -> Bool +nullReport (Report l) = null l + +-- | Construct a singleton set of messages. +singletonReport :: Msg -> Report +singletonReport m = addMsg emptyReport m + +-- | Add message to the end of report. +addMsg :: Report -> Msg -> Report +addMsg r "" = r +addMsg (Report ((x, n) : xns)) y' | x == y = + Report $ (y, n + 1) : xns + where y = BS.pack y' +addMsg (Report xns) y = Report $ (BS.pack y, 1) : xns + +-- | Split a messages into chunks that fit in one line. +-- We assume the width of the messages line is the same as of level map. +splitReport :: Report -> [String] +splitReport r = + let w = fst normalLevelBound + 1 + in splitString w $ renderReport r + +-- | Render a report as a (possibly very long) string. +renderReport ::Report -> String +renderReport (Report []) = "" +renderReport (Report [xn]) = renderRepetition xn +renderReport (Report (xn : xs)) = + renderReport (Report xs) ++ " " ++ renderRepetition xn + +renderRepetition :: (BS.ByteString, Int) -> String +renderRepetition (s, 1) = BS.unpack s +renderRepetition (s, n) = BS.unpack s ++ "" + +-- | Split a string into lines. Avoids ending the line with a character +-- other than whitespace or punctuation. Space characters are removed +-- from hte start, but never from the end of lines. +splitString :: X -> String -> [String] +splitString w xs = splitString' w $ dropWhile isSpace xs + +splitString' :: X -> String -> [String] +splitString' w xs + | w <= 0 = [xs] -- border case, we cannot make progress + | w >= length xs = [xs] -- no problem, everything fits | otherwise = - let (pre, post) = splitAt (w - m) xs + let (pre, post) = splitAt w xs (ppre, ppost) = break (`elem` " .,:;!?") $ reverse pre - rpost = dropWhile isSpace ppost - in if L.null rpost - then pre : splitMsg w post m - else reverse rpost : splitMsg w (reverse ppre ++ post) m + testPost = dropWhile isSpace ppost + in if L.null testPost + then pre : splitString w post + else reverse ppost : splitString w (reverse ppre ++ post) --- | Add spaces at the message end, for display overlayed over the level map. -padMsg :: Int -> String -> String -padMsg w xs = - case L.reverse xs of - [] -> xs - ' ' : _ -> xs - _ | w == length xs -> xs - reversed -> L.reverse $ ' ' : reversed +-- | The history of reports. +newtype History = History [Report] + deriving Show + +instance Binary History where + put (History x) = put x + get = fmap History get + +-- | Empty history of reports. +emptyHistory :: History +emptyHistory = History [] + +-- | Construct a singleton history of reports. +singletonHistory :: Report -> History +singletonHistory r = addReport r emptyHistory + +-- | Render history as many lines of text, wrapping if necessary. +renderHistory :: History -> Overlay +renderHistory (History h) = L.concatMap splitReport h + +-- | Add a report to history, handling repetitions. +addReport :: Report -> History -> History +addReport (Report []) h = h +addReport m (History []) = History [m] +addReport (Report m) (History (Report h : hs)) = + case (reverse m, h) of + ((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 -> + let hist = Report ((s2, n1 + n2) : hhs) : hs + in History $ if null rs then hist else Report (reverse rs) : hist + _ -> History $ Report m : Report h : hs + +-- | Take the given prefix of reports from a history. +takeHistory :: Int -> History -> History +takeHistory k (History h) = History $ take k h + +-- | A screenful of text lines. When displayed, they are trimmed, not wrapped +-- and any lines below the lower screen edge are not visible. +type Overlay = [String] + +-- | Split an overlay into overlays that fit on the screen. +splitOverlay :: Y -> Overlay -> [Overlay] +splitOverlay _ [] = [] -- nothing to print over the level area +splitOverlay lysize ls | length ls <= lysize = [ls] -- all fits on one screen +splitOverlay lysize ls = let (pre, post) = splitAt (lysize - 1) ls + in pre : splitOverlay lysize post + +-- | Returns a function that looks up the characters in the +-- string by location. Takes the height of the display plus +-- the string. Returns also the message to print at the top +-- and number of screens required to display all of the string. +stringByLocation :: X -> Y -> Overlay -> (String, PointXY -> Maybe Char) +stringByLocation _ _ [] = ("", const Nothing) +stringByLocation lxsize lysize (msgTop : ls) = + let over = map (padMsg lxsize) $ take lysize ls + m = IM.fromDistinctAscList $ + zip [0..] (L.map (IM.fromList . zip [0..]) over) + in (msgTop, \ (PointXY (x, y)) -> IM.lookup y m >>= \ n -> IM.lookup x n) diff --git a/Game/LambdaHack/Perception.hs b/Game/LambdaHack/Perception.hs --- a/Game/LambdaHack/Perception.hs +++ b/Game/LambdaHack/Perception.hs @@ -1,6 +1,7 @@ -- | Actors perceiving other actors and the dungeon level. module Game.LambdaHack.Perception - ( Perception, totalVisible, debugTotalReachable, perception + ( DungeonPerception, Perception + , totalVisible, debugTotalReachable, dungeonPerception , actorReachesLoc, actorReachesActor, monsterSeesHero ) where @@ -15,6 +16,7 @@ import Game.LambdaHack.Level import Game.LambdaHack.Actor import Game.LambdaHack.ActorState +import Game.LambdaHack.Dungeon import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.FOV import qualified Game.LambdaHack.Config as Config @@ -30,10 +32,14 @@ { pvisible :: IS.IntSet } +-- | The type representing the perception for all levels in the dungeon. +type DungeonPerception = [(LevelId, Perception)] + +-- | The type representing the perception of all actors on the level. +-- -- Note: Heroes share visibility and only have separate reachability. --- The pplayer field must be void if the player is not on the current level. +-- The pplayer field must be void on all levels except where he resides. -- Right now, the field is used only for player-controlled monsters. --- | The type representing the perception of all actors on the level. data Perception = Perception { pplayer :: Maybe PerceptionReachable , pheroes :: IM.IntMap PerceptionReachable @@ -56,15 +62,13 @@ -- Defaults to false if the actor is not player-controlled (monster or hero). actorReachesLoc :: ActorId -> Point -> Perception -> Maybe ActorId -> Bool actorReachesLoc actor loc per pl = - let tryHero = case actor of - AMonster _ -> Nothing - AHero i -> do - hper <- IM.lookup i (pheroes per) - return $ loc `IS.member` preachable hper + let tryHero = do + hper <- IM.lookup actor (pheroes per) + return $ loc `IS.member` preachable hper tryPl = do -- the case for a monster under player control - guard $ Just actor == pl - pper <- pplayer per - return $ loc `IS.member` preachable pper + guard $ Just actor == pl + pper <- pplayer per + return $ loc `IS.member` preachable pper tryAny = tryHero `mplus` tryPl in fromMaybe False tryAny -- assume not visible, if no perception found @@ -81,55 +85,60 @@ -- TODO: When the code for throwing, digital lines and lights is complete. -- make this a special case of ActorSeesActor. --- | Whether a monster can see a hero (@False@ if the target is not a hero). +-- | Whether a monster can see a hero (@False@ if the target has +-- no perceptions, e.g., not a hero or a hero without perception, due +-- to being spawned on the same turn by a monster and then seen by another). -- An approximation, to avoid computing FOV for the monster. --- If the target actor has no FOV pre-computed, we assume it can't be seen. monsterSeesHero :: Kind.Ops TileKind -> Perception -> Level -> ActorId -> ActorId -> Point -> Point -> Bool monsterSeesHero cotile per lvl _source target sloc tloc = let rempty = PerceptionReachable IS.empty - reachable@PerceptionReachable{preachable} = case target of - AMonster _ -> rempty - -- TODO: instead of this fromMaybe clean up how Perception - -- is regenerated when levels are switched - AHero i -> fromMaybe rempty $ IM.lookup i $ pheroes per + reachable@PerceptionReachable{preachable} = + fromMaybe rempty $ IM.lookup target $ pheroes per in sloc `IS.member` preachable && isVisible cotile reachable lvl IS.empty tloc -- | Calculate the perception of all actors on the level. -perception :: Kind.COps -> State -> Perception -perception cops@Kind.COps{cotile} - state@State{ splayer - , sconfig - , sdebug = DebugMode{smarkVision} - } = - let lvl@Level{lheroes = hs} = slevel state - mode = Config.get sconfig "engine" "fovMode" +dungeonPerception :: Kind.COps -> State -> DungeonPerception +dungeonPerception cops s@State{slid, sdungeon} = + let lvlPer (ln, lvl) = (ln, levelPerception cops s lvl) + in map lvlPer $ currentFirst slid sdungeon + +-- | Calculate the perception of all actors on the level. +levelPerception :: Kind.COps -> State -> Level -> Perception +levelPerception cops@Kind.COps{cotile} + state@State{ splayer + , sconfig + , sdebug = DebugMode{smarkVision} + } + lvl@Level{lactor} = + let mode = Config.get sconfig "engine" "fovMode" radius = let r = Config.get sconfig "engine" "fovRadius" in if r < 1 then error $ "FOV radius is " ++ show r ++ ", should be >= 1" else r -- Perception for a player-controlled monster on the current level. mLocPer = - if isAMonster splayer && memActor splayer state + if not (isAHero state splayer) && IM.member splayer lactor then let m = getPlayerBody state in Just (bloc m, computeReachable cops radius mode smarkVision m lvl) else Nothing (mLoc, mPer) = (fmap fst mLocPer, fmap snd mLocPer) + hs = IM.filter (\ m -> bparty m == heroParty) lactor pers = IM.map (\ h -> computeReachable cops radius mode smarkVision h lvl) hs - locs = IM.map bloc hs + locs = map bloc $ IM.elems hs lpers = maybeToList mPer ++ IM.elems pers reachable = PerceptionReachable $ IS.unions (map preachable lpers) -- TODO: Instead of giving the monster a light source, alter vision. playerControlledMonsterLight = maybeToList mLoc - lights = IS.fromList $ playerControlledMonsterLight ++ IM.elems locs + lights = IS.fromList $ playerControlledMonsterLight ++ locs visible = computeVisible cotile reachable lvl lights - in Perception { pplayer = mPer - , pheroes = pers - , ptotal = visible - } + in Perception { pplayer = mPer + , pheroes = pers + , ptotal = visible + } -- | A location can be directly lit by an ambient shine or a weak, portable -- light source, e.g,, carried by a hero. (Only lights of radius 0 diff --git a/Game/LambdaHack/Place.hs b/Game/LambdaHack/Place.hs --- a/Game/LambdaHack/Place.hs +++ b/Game/LambdaHack/Place.hs @@ -17,6 +17,7 @@ import Game.LambdaHack.Misc import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Random +import Game.LambdaHack.Content.CaveKind -- TODO: use more, rewrite as needed, document each field. -- | The parameters of a place. Most are immutable and set @@ -50,7 +51,7 @@ -- | The map of tile kinds in a place (and generally anywhere in a cave). -- The map is sparse. The default tile that eventually fills the empty spaces --- is specified in the cave kind specification with @cdefTile@. +-- is specified in the cave kind specification with @cdefaultTile@. type TileMapXY = M.Map PointXY (Kind.Id TileKind) -- | For @CAlternate@ tiling, require the place be comprised @@ -85,20 +86,21 @@ -- | Given a few parameters, roll and construct a 'Place' datastructure -- and fill a cave section acccording to it. buildPlace :: Kind.COps -- ^ the game content - -> Kind.Id TileKind -- ^ fence tile, if fence solid + -> CaveKind -- ^ current cave kind -> Kind.Id TileKind -- ^ fence tile, if fence hollow - -> RollDeep -- ^ the chance of a dark place -> Int -- ^ current level depth -> Int -- ^ maximum depth -> Area -- ^ interior area of the place -> Rnd (TileMapXY, Place) -buildPlace Kind.COps{cotile, coplace=Kind.Ops{okind=pokind, opick=popick}} - qsolidFence qhollowFence cdarkChance lvl depth - r = assert (not (trivialArea r) `blame` r) $ do - dark <- chanceDeep lvl depth cdarkChance +buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick} + , coplace=Kind.Ops{okind=pokind, opick=popick} } + CaveKind{..} qhollowFence ln depth r + = assert (not (trivialArea r) `blame` r) $ do + qsolidFence <- opick cfillerTile (const True) + dark <- chanceDeep ln depth cdarkChance qkind <- popick "rogue" (placeValid r) let kr = pokind qkind - qlegend = if dark then "darkLegend" else "litLegend" + qlegend = if dark then cdarkLegendTile else clitLegendTile qseen = False qarea = expandFence (pfence kr) r place = assert (validArea qarea `blame` qarea) $ diff --git a/Game/LambdaHack/Point.hs b/Game/LambdaHack/Point.hs --- a/Game/LambdaHack/Point.hs +++ b/Game/LambdaHack/Point.hs @@ -2,9 +2,11 @@ module Game.LambdaHack.Point ( Point, toPoint, showPoint , origin, chessDist, adjacent, vicinity, vicinityCardinal - , inside, displacement + , inside, displacementXYZ, bla ) where +import qualified Data.List as L + import Game.LambdaHack.PointXY import Game.LambdaHack.VectorXY import Game.LambdaHack.Area @@ -77,9 +79,22 @@ inside :: X -> Point -> Area -> Bool inside lxsize loc = insideXY $ fromPoint lxsize loc --- | Calculate the displacement vector of a location wrt another location. -displacement :: X -> Point -> Point -> VectorXY -displacement lxsize loc0 loc1 +-- | Calculate the displacement vector from a location to another. +displacementXYZ :: X -> Point -> Point -> VectorXY +displacementXYZ lxsize loc0 loc1 | PointXY (x0, y0) <- fromPoint lxsize loc0 , PointXY (x1, y1) <- fromPoint lxsize loc1 = VectorXY (x1 - x0, y1 - y0) + +-- | Bresenham's line algorithm generalized to arbitrary starting @eps@ +-- (@eps@ value of 0 gives the standard BLA). +-- Skips the source point and goes through the second point +-- to the edge of the level. GIves @Nothing@ if the points are equal. +bla :: X -> Y -> Int -> Point -> Point -> Maybe [Point] +bla _ _ _ source target | source == target = Nothing +bla lxsize lysize eps source target = Just $ + let s = fromPoint lxsize source + e = fromPoint lxsize target + inBounds p@(PointXY (x, y)) = + lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= s + in L.map (toPoint lxsize) $ L.takeWhile inBounds $ L.tail $ blaXY eps s e diff --git a/Game/LambdaHack/PointXY.hs b/Game/LambdaHack/PointXY.hs --- a/Game/LambdaHack/PointXY.hs +++ b/Game/LambdaHack/PointXY.hs @@ -1,6 +1,6 @@ -- | Basic cartesian geometry operations on 2D points. module Game.LambdaHack.PointXY - ( X, Y, PointXY(..), fromTo, sortPointXY + ( X, Y, PointXY(..), fromTo, sortPointXY, blaXY ) where import qualified Data.List as L @@ -39,3 +39,22 @@ sortPointXY :: (PointXY, PointXY) -> (PointXY, PointXY) sortPointXY (a, b) | a <= b = (a, b) | otherwise = (b, a) + +-- | See . +balancedWord :: Int -> Int -> Int -> [Int] +balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p) +balancedWord p q eps = 1 : balancedWord p q (eps + p - q) + +-- | Bresenham's line algorithm generalized to arbitrary starting @eps@ +-- (@eps@ value of 0 gives the standard BLA). Includes the source point +-- and goes through the target point to infinity. +blaXY :: Int -> PointXY -> PointXY -> [PointXY] +blaXY eps (PointXY (x0, y0)) (PointXY (x1, y1)) = + let (dx, dy) = (x1 - x0, y1 - y0) + xyStep b (x, y) = (x + signum dx, y + signum dy * b) + yxStep b (x, y) = (x + signum dx * b, y + signum dy) + (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep) + | otherwise = (abs dx, abs dy, yxStep) + bw = balancedWord p q (eps `mod` (max 1 q)) + walk w xy = xy : walk (tail w) (step (head w) xy) + in L.map PointXY $ walk bw (x0, y0) diff --git a/Game/LambdaHack/Random.hs b/Game/LambdaHack/Random.hs --- a/Game/LambdaHack/Random.hs +++ b/Game/LambdaHack/Random.hs @@ -110,7 +110,7 @@ assert (n > 0 && n <= depth `blame` (n, depth)) $ do r1 <- rollDice d1 r2 <- rollDice d2 - return $ r1 + ((n - 1) * r2) `div` (depth - 1) + return $ r1 + ((n - 1) * r2) `div` max 1 (depth - 1) -- | Roll dice scaled with current level depth and return @True@ -- if the results if greater than 50. diff --git a/Game/LambdaHack/Running.hs b/Game/LambdaHack/Running.hs --- a/Game/LambdaHack/Running.hs +++ b/Game/LambdaHack/Running.hs @@ -5,7 +5,6 @@ import Control.Monad.State hiding (State, state) import qualified Data.List as L -import qualified Data.IntMap as IM import qualified Data.IntSet as IS import Game.LambdaHack.Utils.Assert @@ -25,26 +24,30 @@ import qualified Game.LambdaHack.Feature as F -- | Start running in the given direction and with the given number --- of tiles already traversed (usually 0). The first step of running --- succeeds much more often than subsequent steps, because most +-- of tiles already traversed (usually 0). The first turn of running +-- succeeds much more often than subsequent turns, because most -- of the disturbances are ignored, since the player is aware of them -- and still explicitly requests a run. -run :: (Vector, Int) -> Action () +run :: (Vector, Int) -> ActionFrame () run (dir, dist) = do - cops <- contentOps + cops <- getCOps pl <- gets splayer locHere <- gets (bloc . getPlayerBody) lvl <- gets slevel targeting <- gets (ctargeting . scursor) if targeting /= TgtOff - then moveCursor dir 10 + then do + frs <- moveCursor dir 10 + -- Mark that unexpectedly it does not take time. + modify (\ s -> s {snoTime = True}) + return frs else do let accessibleDir loc d = accessible cops lvl loc (loc `shift` d) -- Do not count distance if we just open a door. distNew = if accessibleDir locHere dir then dist + 1 else dist updatePlayerBody (\ p -> p { bdir = Just (dir, distNew) }) - -- attacks and opening doors disallowed while running - moveOrAttack False pl dir + -- Attacks and opening doors disallowed when continuing to run. + inFrame $ moveOrAttack False pl dir -- | Player running mode, determined from the nearby cave layout. data RunMode = @@ -85,19 +88,20 @@ RunCorridor (if diagonal lxsize d1 then d2 else d1, True) _ -> RunHub -- a hub of many separate corridors --- | Check for disturbances to running such newly visible items, monsters, etc. -runDisturbance :: Point -> Int -> Msg -> Party -> Party -> Perception -> Point +-- | Check for disturbances to running such as newly visible items, monsters. +runDisturbance :: Point -> Int -> Report + -> [Actor] -> [Actor] -> Perception -> Point -> (F.Feature -> Point -> Bool) -> (Point -> Bool) -> X -> Y -> (Vector, Int) -> Maybe (Vector, Int) runDisturbance locLast distLast msg hs ms per locHere locHasFeature locHasItems lxsize lysize (dirNew, distNew) = - let msgShown = not (L.null msg) - mslocs = IS.delete locHere $ IS.fromList (L.map bloc (IM.elems ms)) + let msgShown = not $ nullReport msg + mslocs = IS.delete locHere $ IS.fromList (L.map bloc ms) enemySeen = not (IS.null (mslocs `IS.intersection` totalVisible per)) surrLast = locLast : vicinity lxsize lysize locLast surrHere = locHere : vicinity lxsize lysize locHere locThere = locHere `shift` dirNew - heroThere = locThere `elem` L.map bloc (IM.elems hs) + heroThere = locThere `elem` L.map bloc hs -- Stop if you touch any individual tile with these propereties -- first time, unless you enter it next move, in which case stop then. touchList = [ locHasFeature F.Exit @@ -151,12 +155,12 @@ -- and it increments the counter of traversed tiles. continueRun :: (Vector, Int) -> Action () continueRun (dirLast, distLast) = do - cops@Kind.COps{cotile} <- contentOps + cops@Kind.COps{cotile} <- getCOps locHere <- gets (bloc . getPlayerBody) - per <- currentPerception - msg <- currentMsg - ms <- gets (lmonsters . slevel) - hs <- gets (lheroes . slevel) + per <- getPerception + Diary{sreport} <- getDiary + ms <- gets dangerousList + hs <- gets friendlyList lvl@Level{lxsize, lysize} <- gets slevel let locHasFeature f loc = Tile.hasFeature cotile f (lvl `at` loc) locHasItems loc = not $ L.null $ lvl `atI` loc @@ -164,7 +168,7 @@ tryRunDist (dir, distNew) | accessibleDir locHere dir = maybe abort run $ - runDisturbance locLast distLast msg hs ms per locHere + runDisturbance locLast distLast sreport hs ms per locHere locHasFeature locHasItems lxsize lysize (dir, distNew) | otherwise = abort -- do not open doors in the middle of a run tryRun dir = tryRunDist (dir, distLast) @@ -173,7 +177,7 @@ openableDir loc dir = Tile.hasFeature cotile F.Openable (lvl `at` (loc `shift` dir)) dirEnterable loc d = accessibleDir loc d || openableDir loc d - case runMode locHere dirLast dirEnterable lxsize of + ((), frames) <- case runMode locHere dirLast dirEnterable lxsize of RunDeadEnd -> abort -- we don't run backwards RunOpen -> tryRun dirLast -- run forward into the open space RunHub -> abort -- stop and decide where to go @@ -185,3 +189,4 @@ RunHub | turn -> abort -- stop and decide when to turn RunOpen -> tryRunAndStop dirNext -- no turn, get closer and stop RunHub -> tryRunAndStop dirNext -- no turn, get closer and stop + when (not $ null frames) abort -- something serious happened, stop running diff --git a/Game/LambdaHack/Save.hs b/Game/LambdaHack/Save.hs --- a/Game/LambdaHack/Save.hs +++ b/Game/LambdaHack/Save.hs @@ -1,12 +1,14 @@ -- | Saving and restoring games and player diaries. module Game.LambdaHack.Save - ( saveGame, restoreGame, rmBkpSaveDiary, saveGameBkp + ( saveGameFile, restoreGame, rmBkpSaveDiary, saveGameBkp ) where import System.Directory import System.FilePath import qualified Control.Exception as E hiding (handle) import Control.Monad +import Control.Concurrent +import System.IO.Unsafe (unsafePerformIO) -- horrors import Game.LambdaHack.Utils.File import Game.LambdaHack.State @@ -32,12 +34,17 @@ dfile <- diaryFile (sconfig state) encodeEOF dfile diary --- | Save a simple serialized version of the current state and diary. -saveGame :: State -> Diary -> IO () -saveGame state diary = do +saveLock :: MVar () +saveLock = unsafePerformIO newEmptyMVar + +-- | Save a simple serialized version of the current state. +-- Protected by a lock to avoid corrupting the file. +saveGameFile :: State -> IO () +saveGameFile state = do + putMVar saveLock () sfile <- saveFile (sconfig state) encodeEOF sfile state - saveDiary state diary -- save the diary often in case of crashes + takeMVar saveLock -- | Try to create a directory. Hide errors due to, -- e.g., insufficient permissions, because the game can run @@ -78,6 +85,7 @@ -- Possibly copy over data files. No problem if it fails. tryCopyDataFiles pathsDataFile appData -- If the diary file does not exist, create an empty diary. + -- TODO: when diary gets corrupted, start a new one, too. diary <- do dfile <- diaryFile config db <- doesFileExist dfile @@ -114,19 +122,31 @@ renameFile sfile bfile -- | Save the diary and a backup of the save game file, in case of crashes. +-- This is only a backup, so no problem is the game is shut down +-- before saving finishes, so we don't wait on the mvar. However, +-- if a previous save is already in progress, we skip this save. saveGameBkp :: State -> Diary -> IO () saveGameBkp state diary = do - saveGame state diary - mvBkp (sconfig state) + b <- tryPutMVar saveLock () + when b $ + void $ forkIO $ do + saveDiary state diary -- save the diary often in case of crashes + sfile <- saveFile (sconfig state) + encodeEOF sfile state + mvBkp (sconfig state) + takeMVar saveLock -- | Remove the backup of the savegame and save the player diary. -- Should be called before any non-error exit from the game. -- Sometimes the backup file does not exist and it's OK. -- We don't bother reporting any other removal exceptions, either, -- because the backup file is relatively unimportant. +-- We wait on the mvar, because saving the diary at game shutdown is important. rmBkpSaveDiary :: State -> Diary -> IO () rmBkpSaveDiary state diary = do + putMVar saveLock () saveDiary state diary -- save the diary often in case of crashes bfile <- bkpFile (sconfig state) bb <- doesFileExist bfile when bb $ removeFile bfile + takeMVar saveLock diff --git a/Game/LambdaHack/Start.hs b/Game/LambdaHack/Start.hs --- a/Game/LambdaHack/Start.hs +++ b/Game/LambdaHack/Start.hs @@ -16,8 +16,8 @@ import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Tile -import Game.LambdaHack.Level import qualified Game.LambdaHack.Kind as Kind +import Game.LambdaHack.Msg speedup :: Kind.Ops TileKind -> Kind.Speedup TileKind speedup Kind.Ops{ofoldrWithKey, obounds} = @@ -46,8 +46,8 @@ start :: Config.CP -> Session -> IO () start config1 slowSess = do let sess@Session{scops = cops@Kind.COps{corule}} = speedupCops slowSess - title = rtitle $ stdRuleset corule - pathsDataFile = rpathsDataFile $ stdRuleset corule + title = rtitle $ Kind.stdRuleset corule + pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule restored <- Save.restoreGame pathsDataFile config1 title case restored of Right (msg, diary) -> do -- Starting a new game. @@ -59,8 +59,9 @@ let state = defaultState config3 sflavour freshDungeon entryLevel entryLoc g3 hstate = initialHeroes cops entryLoc state - handlerToIO sess hstate diary{smsg = msg} handle + handlerToIO sess hstate diary{sreport = singletonReport msg} handleTurn Left (state, diary) -> -- Running a restored a game. handlerToIO sess state - diary{smsg = "Welcome back to " ++ title ++ "."} -- TODO:save old msg? - handle + -- This overwrites the "Really save/quit?" messages. + diary{sreport = singletonReport $ "Welcome back to " ++ title ++ "."} + handleTurn diff --git a/Game/LambdaHack/State.hs b/Game/LambdaHack/State.hs --- a/Game/LambdaHack/State.hs +++ b/Game/LambdaHack/State.hs @@ -3,7 +3,7 @@ ( -- * Game state State(..), TgtMode(..), Cursor(..) -- * Accessor - , slevel + , slevel, stime -- * Constructor , defaultState -- * State update @@ -15,20 +15,20 @@ ) where import qualified Data.Set as S -import qualified Data.IntSet as IS import Data.Binary import qualified Game.LambdaHack.Config as Config import qualified System.Random as R import System.Time import Game.LambdaHack.Actor -import Game.LambdaHack.Misc import Game.LambdaHack.Point import Game.LambdaHack.Level import qualified Game.LambdaHack.Dungeon as Dungeon import Game.LambdaHack.Item import Game.LambdaHack.Msg import Game.LambdaHack.FOV +import Game.LambdaHack.Time +import qualified Game.LambdaHack.HighScore as H -- | The diary contains all the player data -- that carries over from game to game. @@ -36,8 +36,8 @@ -- history of past games. This can be used for calculating player -- achievements, unlocking advanced game features and general data mining. data Diary = Diary - { smsg :: Msg - , shistory :: [Msg] + { sreport :: Report + , shistory :: History } -- | The state of a single game that can be save and restored. @@ -46,15 +46,15 @@ data State = State { splayer :: ActorId -- ^ represents the player-controlled actor , scursor :: Cursor -- ^ cursor location and level to return to - , stime :: Time -- ^ current in-game time , sflavour :: FlavourMap -- ^ association of flavour to items , sdisco :: Discoveries -- ^ items (kinds) that have been discovered , sdungeon :: Dungeon.Dungeon -- ^ all dungeon levels , slid :: Dungeon.LevelId -- ^ identifier of the current level - , scounter :: (Int, Int) -- ^ stores next hero index and monster index - , sparty :: IS.IntSet -- ^ heroes in the party + , scounter :: Int -- ^ stores next actor index , srandom :: R.StdGen -- ^ current random generator , sconfig :: Config.CP -- ^ game config + , snoTime :: Bool -- ^ last command unexpectedly took no time + , squit :: Maybe (Bool, H.Status) -- ^ cause of game shutdown , sdebug :: DebugMode -- ^ debugging mode } deriving Show @@ -72,6 +72,7 @@ , clocLn :: Dungeon.LevelId -- ^ cursor level , clocation :: Point -- ^ cursor coordinates , creturnLn :: Dungeon.LevelId -- ^ the level current player resides on + , ceps :: Int -- ^ a parameter of the tgt digital line } deriving Show @@ -85,15 +86,19 @@ slevel :: State -> Level slevel State{slid, sdungeon} = sdungeon Dungeon.! slid --- TODO: add date. +-- | Get current time from the dungeon data. +stime :: State -> Time +stime State{slid, sdungeon} = ltime $ sdungeon Dungeon.! slid + -- | Initial player diary. defaultDiary :: IO Diary defaultDiary = do - curDate <- getClockTime - let time = calendarTimeToString $ toUTCTime curDate + dateTime <- getClockTime + let curDate = calendarTimeToString $ toUTCTime dateTime return Diary - { smsg = "" - , shistory = ["Player diary started on " ++ time ++ "."] + { sreport = emptyReport + , shistory = singletonHistory $ singletonReport $ + "Player diary started on " ++ curDate ++ "." } -- | Initial game state. @@ -101,17 +106,17 @@ -> Point -> R.StdGen -> State defaultState config flavour dng lid ploc g = State - (AHero 0) -- hack: the hero is not yet alive - (Cursor TgtOff lid ploc lid) - 0 + 0 -- hack: the hero is not yet alive + (Cursor TgtOff lid ploc lid 0) flavour S.empty dng lid - (0, 0) - IS.empty + 0 g config + False + Nothing defaultDebugMode defaultDebugMode :: DebugMode @@ -126,7 +131,7 @@ -- | Update time within state. updateTime :: (Time -> Time) -> State -> State -updateTime f s = s { stime = f (stime s) } +updateTime f s = updateLevel (\ lvl@Level{ltime} -> lvl {ltime = f ltime}) s -- | Update item discoveries within state. updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State @@ -155,55 +160,55 @@ instance Binary Diary where put Diary{..} = do - put smsg + put sreport put shistory get = do - smsg <- get + sreport <- get shistory <- get return Diary{..} instance Binary State where - put (State player cursor time flav disco dng lid ct - party g config _) = do + put (State player cursor flav disco dng lid ct + g config snoTime _ _) = do put player put cursor - put time put flav put disco put dng put lid put ct - put party put (show g) put config + put snoTime get = do player <- get cursor <- get - time <- get flav <- get disco <- get dng <- get lid <- get ct <- get - party <- get g <- get - config <- get + config <- get + snoTime <- get return - (State player cursor time flav disco dng lid ct - party (read g) config defaultDebugMode) + (State player cursor flav disco dng lid ct + (read g) config snoTime Nothing defaultDebugMode) instance Binary Cursor where - put (Cursor act cln loc rln) = do + put (Cursor act cln loc rln eps) = do put act put cln put loc put rln + put eps get = do act <- get cln <- get loc <- get rln <- get - return (Cursor act cln loc rln) + eps <- get + return (Cursor act cln loc rln eps) instance Binary TgtMode where put TgtOff = putWord8 0 diff --git a/Game/LambdaHack/Strategy.hs b/Game/LambdaHack/Strategy.hs --- a/Game/LambdaHack/Strategy.hs +++ b/Game/LambdaHack/Strategy.hs @@ -15,15 +15,15 @@ -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where - return x = Strategy $ return $ uniformFreq [x] + return x = Strategy $ return $ uniformFreq "Strategy_return" [x] m >>= f = Strategy $ - filter (not . nullFreq) - [ toFreq [ (p * q, b) - | (p, a) <- runFrequency x - , y <- runStrategy (f a) - , (q, b) <- runFrequency y - ] - | x <- runStrategy m ] + filter (not . nullFreq) + [ toFreq "Strategy_bind" [ (p * q, b) + | (p, a) <- runFrequency x + , y <- runStrategy (f a) + , (q, b) <- runFrequency y + ] + | x <- runStrategy m ] instance MonadPlus Strategy where mzero = Strategy [] diff --git a/Game/LambdaHack/StrategyAction.hs b/Game/LambdaHack/StrategyAction.hs --- a/Game/LambdaHack/StrategyAction.hs +++ b/Game/LambdaHack/StrategyAction.hs @@ -7,8 +7,10 @@ import qualified Data.IntMap as IM import Data.Maybe import Control.Monad +import Control.Monad.State hiding (State, state) import Control.Arrow +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Point import Game.LambdaHack.Vector import Game.LambdaHack.Level @@ -23,11 +25,14 @@ import Game.LambdaHack.Actions import Game.LambdaHack.ItemAction import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Item import qualified Game.LambdaHack.Effect as Effect import qualified Game.LambdaHack.Tile as Tile import qualified Game.LambdaHack.Kind as Kind import qualified Game.LambdaHack.Feature as F +import Game.LambdaHack.Time +import qualified Game.LambdaHack.Color as Color {- Monster movement @@ -61,53 +66,47 @@ -- TODO: improve, split up, etc. -- | Monster AI strategy based on monster sight, smell, intelligence, etc. strategy :: Kind.COps -> ActorId -> State -> Perception -> Strategy (Action ()) -strategy cops actor oldState@State{splayer = pl, stime = time} per = +strategy cops actor oldState@State{splayer = pl} per = strat where Kind.COps{ cotile - , coactor=Kind.Ops{okind} + , coactor=coactor@Kind.Ops{okind} , coitem=coitem@Kind.Ops{okind=iokind} + , corule } = cops - lvl@Level{lsmell = nsmap, lxsize, lysize} = slevel oldState - Actor { bkind = ak, bloc = me, bdir = ad, btarget = tgt } = + lvl@Level{lsmell, lxsize, lysize, ltime} = slevel oldState + actorBody@Actor{ bkind = ak, bloc = me, bdir = ad, btarget, bparty } = getActor actor oldState - items = getActorItem actor oldState + bitems = getActorItem actor oldState mk = okind ak delState = deleteActor actor oldState enemyVisible a l = - asight mk && monsterSeesHero cotile per lvl actor a me l || - -- Any enemy can be flet if adjacent (e. g., a monster player). + asight mk && + isAHero delState a && + monsterSeesHero cotile per lvl actor a me l + -- Enemy can be felt if adjacent (e. g., a player-controlled monster). -- TODO: can this be replaced by setting 'lights' to [me]? - adjacent lxsize me l - -- If no heroes on the level, monsters go at each other. TODO: let them - -- earn XP by killing each other to make this dangerous to the player. - -- TODO: with some commands blocked, this can't happen now. Find a way - -- to test it, nevertheless. Have a scroll of monster fury? - hs = L.map (AHero *** bloc) $ - IM.assocs $ lheroes $ slevel delState - ms = L.map (AMonster *** bloc) $ - IM.assocs $ lmonsters $ slevel delState + || (asmell mk || asight mk) + && adjacent lxsize me l -- Below, "foe" is the hero (or a monster, or loc) chased by the actor. - (newTgt, floc, foeVisible) = + chase tgt = case tgt of - TEnemy a ll | focusedMonster -> - if memActor a delState - then let l = bloc $ getActor a delState - in if enemyVisible a l - then (TEnemy a l, Just l, True) - else if isJust (case closest of (_, m, _) -> m) || me == ll - then closest -- prefer visible foes - else (tgt, Just ll, False) -- last known loc of enemy - else closest -- enemy not on the level, temporarily chase others - TLoc loc -> if me == loc - then closest - else (tgt, Just loc, False) -- ignore all and go to loc + TEnemy a ll | focusedMonster && memActor a delState -> + let l = bloc $ getActor a delState + in if enemyVisible a l + then (TEnemy a l, Just l, True) + else if isJust (case closest of (_, m, _) -> m) || me == ll + then closest -- prefer visible foes + else (tgt, Just ll, False) -- last known loc of enemy + TLoc loc | me == loc -> closest + TLoc loc -> (tgt, Just loc, False) -- ignore all and go to loc _ -> closest + (newTgt, floc, foeVisible) = chase btarget closest = - let hsAndTraitor = if isAMonster pl && memActor pl delState - then (pl, bloc $ getPlayerBody delState) : hs - else hs - foes = if L.null hsAndTraitor then ms else hsAndTraitor + let hs = L.map (second bloc) $ heroAssocs $ slevel delState + foes = if not (isAHero delState pl) && memActor pl delState + then (pl, bloc $ getPlayerBody delState) : hs + else hs visible = L.filter (uncurry enemyVisible) foes foeDist = L.map (\ (a, l) -> (chessDist lxsize me l, l, a)) visible in case foeDist of @@ -132,51 +131,71 @@ onlyKeepsDir k = only (\ x -> maybe True (\ (d, _) -> euclidDistSq lxsize d x <= k) ad) onlyKeepsDir_9 = only (\ x -> maybe True (\ (d, _) -> neg x /= d) ad) - onlyNoMs = onlyMoves (unoccupied (levelMonsterList delState)) me + onlyNoMs = onlyMoves (unoccupied (dangerousList delState)) me -- Monsters don't see doors more secret than that. Enforced when actually -- opening doors, too, so that monsters don't cheat. TODO: remove the code -- duplication, though. - openPower = Tile.SecretStrength $ - case strongestSearch coitem items of + openPower = timeScale timeTurn $ + case strongestSearch coitem bitems of Just i -> aiq mk + jpower i Nothing -> aiq mk openableHere = openable cotile lvl openPower onlyOpenable = onlyMoves openableHere me accessibleHere = accessible cops lvl me onlySensible = onlyMoves (\ l -> accessibleHere l || openableHere l) me - focusedMonster = aspeed mk >= 10 + focusedMonster = actorSpeed coactor actorBody <= speedNormal movesNotBack = maybe id (\ (d, _) -> L.filter (/= neg d)) ad $ moves lxsize smells = L.map fst $ L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $ - L.filter (\ (_, s) -> s > 0) $ - L.map (\ x -> let sm = Tile.smelltime $ IM.findWithDefault - (Tile.SmellTime 0) (me `shift` x) nsmap - in (x, (sm - time) `max` 0)) movesNotBack + L.filter (\ (_, s) -> s > timeZero) $ + L.map (\ x -> let sm = IM.findWithDefault timeZero (me `shift` x) lsmell + in (x, max timeZero (sm `timeAdd` timeNegate ltime))) + movesNotBack attackDir d = dirToAction actor newTgt True `liftM` d moveDir d = dirToAction actor newTgt False `liftM` d + darkenActor = updateAnyActor actor $ \ m -> m {bcolor = Just Color.BrBlack} - strat = - foeVisible .=> attackDir (onlyFoe moveFreely) - .| foeVisible .=> liftFrequency (msum seenFreqs) - .| lootHere me .=> actionPickup - .| moveDir moveTowards -- go to last known foe location - .| attackDir moveAround + strat = case btarget of + TPath [] -> dieOrSleep + TPath (d : _) | not $ accessible cops lvl me (shift me d) -> dieOrSleep + -- TODO: perhaps colour differently the whole second turn of movement? + TPath [d] -> return $ darkenActor >> dirToAction actor (TPath []) True d + TPath (d : lv) -> return $ dirToAction actor (TPath lv) True d + _ -> foeVisible .=> attackDir (onlyFoe moveFreely) + .| foeVisible .=> liftFrequency (msum seenFreqs) + .| lootHere me .=> actionPickup + .| moveDir moveTowards -- go to last known foe location + .| attackDir moveAround + dieOrSleep | bparty `elem` allProjectiles = dieNow actor + | otherwise = wait actionPickup = return $ actorPickupItem actor tis = lvl `atI` me - seenFreqs = [applyFreq items 1, applyFreq tis 2, - throwFreq items 3, throwFreq tis 6] ++ towardsFreq - applyFreq is multi = toFreq - [ (benefit * multi, - applyGroupItem actor (iverbApply ik) i) + seenFreqs = [applyFreq bitems 1, applyFreq tis 2, + throwFreq bitems 3, throwFreq tis 6] ++ towardsFreq + applyFreq is multi = toFreq "applyFreq" + [ (benefit * multi, applyGroupItem actor (iverbApply ik) i) | i <- is, let ik = iokind (jkind i), let benefit = (1 + jpower i) * Effect.effectToBenefit (ieffect ik), benefit > 0, asight mk || isymbol ik == '!'] - throwFreq is multi = if adjacent lxsize me (fromJust floc) || not (asight mk) + foeAdjacent = maybe False (adjacent lxsize me) floc + -- TODO: also don't throw if any loc on path is visibly not accessible + -- from previous (and tweak eps in bla to make it accessible). + -- Also don't throw if target not in range. + eps = 0 + bl = bla lxsize lysize eps me (fromJust floc) + loc1 = case bl of + Nothing -> me + Just [] -> me + Just (lbl:_) -> lbl + throwFreq is multi = if foeAdjacent + || not (asight mk) + || not (accessible cops lvl me loc1) + || isJust (locToActor loc1 oldState) then mzero - else toFreq + else toFreq "throwFreq" [ (benefit * multi, projectGroupItem actor (fromJust floc) (iverbProject ik) i) | i <- is, @@ -184,8 +203,9 @@ let benefit = - (1 + jpower i) * Effect.effectToBenefit (ieffect ik), benefit > 0, - -- Wasting swords would be too cruel to the player. - isymbol ik /= ')'] + -- Wasting weapons and armour would be too cruel to the player. + -- TODO: specify in content + isymbol ik `elem` (ritemProject $ Kind.stdRuleset corule)] towardsFreq = map (scaleFreq 30) $ runStrategy $ moveDir moveTowards moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely) moveAround = @@ -210,18 +230,29 @@ onlyMoves :: (Point -> Bool) -> Point -> Strategy Vector -> Strategy Vector onlyMoves p l = only (\ x -> p (l `shift` x)) moveRandomly :: Strategy Vector - moveRandomly = liftFrequency $ uniformFreq (moves lxsize) + moveRandomly = liftFrequency $ uniformFreq "moveRandomly" (moves lxsize) dirToAction :: ActorId -> Target -> Bool -> Vector -> Action () -dirToAction actor tgt allowAttacks dir = do +dirToAction actor btarget allowAttacks dir = do -- set new direction - updateAnyActor actor $ \ m -> m { bdir = Just (dir, 0), btarget = tgt } + updateAnyActor actor $ \ m -> m { bdir = Just (dir, 0), btarget } -- perform action - tryWith (advanceTime actor) $ - -- if the following action aborts, we just advance the time and continue + tryWith (\ msg -> if null msg + then return () + else assert `failure` (msg, "in AI")) $ do + -- If the following action aborts, we just advance the time and continue. -- TODO: ensure time is taken for other aborted actions in this file + -- TODO: or just fail at each abort in AI code? or use tryWithFrame? moveOrAttack allowAttacks actor dir -- | A strategy to always just wait. -wait :: ActorId -> Strategy (Action ()) -wait actor = return $ advanceTime actor +wait :: Strategy (Action ()) +wait = return $ return () + +-- | A strategy to always just die. +dieNow :: ActorId -> Strategy (Action ()) +dieNow actor = return $ do -- TODO: explode if a potion + bitems <- gets (getActorItem actor) + Actor{bloc} <- gets (getActor actor) + modify (updateLevel (dropItemsAt bitems bloc)) + modify (deleteActor actor) diff --git a/Game/LambdaHack/Tile.hs b/Game/LambdaHack/Tile.hs --- a/Game/LambdaHack/Tile.hs +++ b/Game/LambdaHack/Tile.hs @@ -10,33 +10,28 @@ -- to try to compress their representation and/or recompute them. -- Instead, of defining a @Tile@ type, we express various properties -- of concrete tiles by arrays or sparse IntMaps, as appropriate. +-- +-- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Tile - ( SecretStrength(..), SmellTime(..) + (SecretTime, SmellTime , kindHasFeature, kindHas, hasFeature , isClear, isLit, similar, canBeHidden ) where import qualified Data.List as L -import Data.Binary import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Feature as F import qualified Game.LambdaHack.Kind as Kind -import Game.LambdaHack.Misc +import Game.LambdaHack.Time --- | The type of secrecy strength of hidden terrain tiles (e.g., doors). -newtype SecretStrength = SecretStrength{secretStrength :: Time} - deriving (Show, Eq, Ord) -instance Binary SecretStrength where - put = put . secretStrength - get = fmap SecretStrength get +-- | The time interval needed to discover a given secret, +-- e.g., a hidden terrain tile, e.g., a hidden door. +type SecretTime = Time -- | The last time a hero left a smell in a given tile. To be used -- by monsters that hunt by smell. -newtype SmellTime = SmellTime{smelltime :: Time} deriving Show -instance Binary SmellTime where - put = put . smelltime - get = fmap SmellTime get +type SmellTime = Time -- | Whether a tile kind has the given feature. kindHasFeature :: F.Feature -> TileKind -> Bool diff --git a/Game/LambdaHack/Time.hs b/Game/LambdaHack/Time.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Time.hs @@ -0,0 +1,143 @@ +-- | Game time and speed. +module Game.LambdaHack.Time + ( Time, timeZero, timeClip, timeTurn + , timeAdd, timeFit, timeNegate, timeScale + , timeToDigit + , Speed, toSpeed, speedNormal + , speedScale, ticksPerMeter, traveled, speedFromWeight, rangeFromSpeed + ) where + +import Data.Binary +import Data.Int (Int64) +import qualified Data.Char as Char + +-- | Game time in ticks. The time dimension. +-- One tick is 1 microsecond (one millionth of a second), +-- one turn is 0.5 s. +newtype Time = Time Int64 + deriving (Show, Eq, Ord) + +instance Binary Time where + put (Time n) = put n + get = fmap Time get + +-- | Start of the game time, or zero lenght time interval. +timeZero :: Time +timeZero = Time 0 + +-- | The smallest unit of time. Do not export, because the proportion +-- of turn to tick is an implementation detail. +-- The significance of this detail is only that it determines resolution +-- of the time dimension. +_timeTick :: Time +_timeTick = Time 1 + +-- TODO: don't have a fixed time, but instead set it at 1/3 or 1/4 +-- of timeTurn depending on level. Clips are a UI feature +-- after all, so should depend on the user situation. +-- | At least once per clip all moves are resolved and a frame +-- or a frame delay is generated. +-- Currently one clip is 0.1 s, but it may change, +-- and the code should not depend on this fixed value. +timeClip :: Time +timeClip = Time 100000 + +-- | One turn is 0.5 s. The code may depend on that. +-- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). +timeTurn :: Time +timeTurn = Time 500000 + +-- | This many turns fit in a single second. +turnsInSecond :: Int64 +turnsInSecond = 2 + +-- | This many ticks fits in a single second. Do not export, +_ticksInSecond :: Int64 +_ticksInSecond = + let Time ticksInTurn = timeTurn + in ticksInTurn * turnsInSecond + +-- | Time addition. +timeAdd :: Time -> Time -> Time +timeAdd (Time t1) (Time t2) = Time (t1 + t2) + +-- | How many time intervals of the latter kind fits in an interval +-- of the former kind. +timeFit :: Time -> Time -> Int +timeFit (Time t1) (Time t2) = fromIntegral $ t1 `div` t2 + +-- | Negate a time interval. Can be used to subtract from a time +-- or to reverse the ordering on time. +timeNegate :: Time -> Time +timeNegate (Time t) = Time (-t) + +-- | Scale time by an @Int@ scalar value. +timeScale :: Time -> Int -> Time +timeScale (Time t) s = Time (t * fromIntegral s) + +-- | Represent the main 10 thresholds of a time range by digits, +-- given the total length of the time range. +timeToDigit :: Time -> Time -> Char +timeToDigit (Time maxT) (Time t) = + let k = 10 * t `div` maxT + digit | k > 9 = '*' + | k < 0 = '-' + | otherwise = Char.intToDigit $ fromIntegral k + in digit + +-- | Speed in meters per 1 million seconds (m/Ms). +-- Actors at normal speed (2 m/s) take one time turn (0.5 s) +-- to move one tile (1 m by 1 m). +newtype Speed = Speed Int64 + deriving (Show, Eq, Ord) + +instance Binary Speed where + put (Speed n) = put n + get = fmap Speed get + +-- | Number of seconds in a kilo-second. +sInMs :: Int64 +sInMs = 1000000 + +-- | Constructor for content definitions. +toSpeed :: Double -> Speed +toSpeed s = Speed $ round $ s * fromIntegral sInMs + +-- | Normal speed (2 m/s) that suffices to move one tile in one turn. +speedNormal :: Speed +speedNormal = Speed $ 2 * sInMs + +-- | Scale speed by an @Int@ scalar value. +speedScale :: Speed -> Int -> Speed +speedScale (Speed v) s = Speed (v * fromIntegral s) + +-- | The number of time ticks it takes to walk 1 meter at the given speed. +ticksPerMeter :: Speed -> Time +ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `div` v + +-- | Distance in meters (so also in tiles, given the chess metric) +-- traveled in a given time by a body with a given speed. +traveled :: Speed -> Time -> Int +traveled (Speed v) (Time t) = + fromIntegral $ v * t `div` (_ticksInSecond * sInMs) + +-- | Calculate projectile speed from item weight in grams +-- and speed bonus in percents. +-- See . +speedFromWeight :: Int -> Int -> Speed +speedFromWeight weight bonus = + let w = fromIntegral weight + b = fromIntegral bonus + mpMs | w <= 500 = sInMs * 16 + | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000) + | otherwise = sInMs * (10000 - w) `div` 1000 + in Speed $ max 0 $ mpMs * (100 + b) `div` 100 + +-- | Calculate maximum range in meters of a projectile from its speed. +-- See . +-- With this formula, each projectile flies for exactly one second, +-- that is 2 turns, and then drops to the ground. +-- Dividing and multiplying by 2 ensures both turns of flight +-- cover the same distance. +rangeFromSpeed :: Speed -> Int +rangeFromSpeed (Speed v) = fromIntegral $ 2 * (v `div` (sInMs * 2)) diff --git a/Game/LambdaHack/Turn.hs b/Game/LambdaHack/Turn.hs --- a/Game/LambdaHack/Turn.hs +++ b/Game/LambdaHack/Turn.hs @@ -1,172 +1,250 @@ -- | The main loop of the game, processing player and AI moves turn by turn. -module Game.LambdaHack.Turn ( handle ) where +module Game.LambdaHack.Turn ( handleTurn ) where import Control.Monad import Control.Monad.State hiding (State, state) +import Control.Arrow ((&&&)) import qualified Data.List as L import qualified Data.Ord as Ord -import qualified Data.IntMap as IM import qualified Data.Map as M +import qualified Data.IntMap as IM +import Data.Maybe +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Action import Game.LambdaHack.Actions -import qualified Game.LambdaHack.Config as Config import Game.LambdaHack.EffectAction import qualified Game.LambdaHack.Binding as Binding -import Game.LambdaHack.Level import Game.LambdaHack.Actor import Game.LambdaHack.ActorState +import Game.LambdaHack.Level import Game.LambdaHack.Random import Game.LambdaHack.State import Game.LambdaHack.Strategy import Game.LambdaHack.StrategyAction import Game.LambdaHack.Running -import qualified Game.LambdaHack.Tile as Tile +import qualified Game.LambdaHack.Key as K +import Game.LambdaHack.Msg +import Game.LambdaHack.Draw +import qualified Game.LambdaHack.Kind as Kind +import Game.LambdaHack.Time +import qualified Game.LambdaHack.HighScore as H --- One turn proceeds through the following functions: --- --- handle --- handleAI, handleMonster --- nextMove --- handle (again) --- --- OR: --- --- handle --- handlePlayer, playerCommand --- handleAI, handleMonster --- nextMove --- handle (again) +-- One clip proceeds through the following functions: -- +-- handleTurn +-- handleActors +-- handleMonster or handlePlayer +-- handleActors +-- handleMonster or handlePlayer +-- ... +-- handleTurn (again) + -- What's happening where: -- --- handle: determine who moves next, --- dispatch to handleAI or handlePlayer --- --- handlePlayer: remember, display, get and process commmand(s), --- update smell map, update perception --- --- handleAI: find monsters that can move +-- handleTurn: HP regeneration, monster generation, determine who moves next, +-- dispatch to handlePlayer and handleActors, advance global game time -- --- handleMonster: determine and process monster action, advance monster time +-- handleActors: find an actor that can move, advance actor time, +-- update perception, remember, push frame, repeat -- --- nextMove: advance global game time, HP regeneration, monster generation +-- handlePlayer: update perception, remember, display frames, +-- get and process commmands (zero or more), update smell map -- --- This is rather convoluted, and the functions aren't named very aptly, so we --- should clean this up later. TODO. +-- handleMonster: determine and process monster action --- | Decide if the hero is ready for another move. --- If yes, run a player move, if not, run an AI move. --- In either case, eventually the next turn is started or the game ends. -handle :: Action () -handle = do - debug "handle" - state <- get - let ptime = btime (getPlayerBody state) -- time of player's next move - let time = stime state -- current game time - debug $ "handle: time check. ptime = " +-- | Start a clip (a part of a turn for which one or more frames +-- will be generated). Do whatever has to be done +-- every fixed number of time units, e.g., monster generation. +-- Run the player and other actors moves. +-- Eventually advance the time and repeat. +handleTurn :: Action () +handleTurn = do + debug "handleTurn" + time <- gets stime -- the end time of this clip, inclusive + let clipN = (time `timeFit` timeClip) `mod` (timeTurn `timeFit` timeClip) + -- Regenerate HP and add monsters each turn, not each clip. + when (clipN == 1) regenerateLevelHP + when (clipN == 3) generateMonster + ptime <- gets (btime . getPlayerBody) -- time of player's next move + debug $ "handleTurn: time check. ptime = " ++ show ptime ++ ", time = " ++ show time - if ptime > time - then handleAI -- the hero can't make a move yet; monsters first - else handlePlayer -- it's the hero's turn! - - -- TODO: readd this, but only for the turns when anything moved - -- and only after a rendering delay is added, so that the move is visible - -- on modern computers. Use the same delay for running (not disabled now). - -- We redraw the map even between player moves so that the movements of fast - -- monsters can be traced on the map. - -- displayGeneric ColorFull (const "") + handleActors timeZero + modify (updateTime (timeAdd timeClip)) + squit <- gets squit + case squit of + Nothing -> handleTurn + Just status@(_, H.Camping) -> do + pl <- gets splayer + advanceTime False pl -- rewind player time: his action was only Save + shutGame status + Just status -> shutGame status -- TODO: We should replace this structure using a priority search queue/tree. --- | Handle monster moves. Perform moves for individual monsters as long as --- there are monsters that have a move time which is less than or equal to --- the current time. -handleAI :: Action () -handleAI = do - debug "handleAI" - time <- gets stime - ms <- gets (lmonsters . slevel) - pl <- gets splayer - if IM.null ms - then nextMove - else let order = Ord.comparing (btime . snd) - (i, m) = L.minimumBy order (IM.assocs ms) - actor = AMonster i - in if btime m > time || actor == pl - then nextMove -- no monster is ready for another move - else handleMonster actor +-- | Perform moves for individual actors not controlled +-- by the player, as long as there are actors +-- with the next move time less than or equal to the current time. +-- Some very fast actors may move many times a clip and then +-- we introduce subclips and produce many frames per clip to avoid +-- jerky movement. Otherwise we push exactly one frame or frame delay. +handleActors :: Time -- ^ the start time of current subclip, exclusive + -> Action () +handleActors subclipStart = do + debug "handleActors" + Kind.COps{coactor} <- getCOps + time <- gets stime -- the end time of this clip, inclusive + lactor <- gets (allButHeroesAssocs . slevel) + pl <- gets splayer + pbody <- gets getPlayerBody + squit <- gets squit + let as = (pl, pbody) : lactor -- older actors act first + mnext = if null as -- wait until any actor spawned + then Nothing + else let -- Heroes move first then monsters, then the rest. + order = Ord.comparing (btime . snd &&& bparty . snd) + (actor, m) = L.minimumBy order as + in if btime m > time + then Nothing -- no actor is ready for another move + else Just (actor, m) + case mnext of + _ | isJust squit -> return () + Nothing -> when (subclipStart == timeZero) $ displayFramePush Nothing + Just (actor, m) -> do + advanceTime True actor -- advance time while the actor still alive + if actor == pl || bparty m == heroParty + then + -- Player moves always start a new subclip. + startClip $ do + handlePlayer + handleActors $ btime m + else + let speed = actorSpeed coactor m + delta = ticksPerMeter speed + in if subclipStart == timeZero + || btime m > timeAdd subclipStart delta + then + -- That's the first move this clip + -- or the monster has already moved this subclip. + -- I either case, start a new subclip. + startClip $ do + handleMonster actor + handleActors $ btime m + else do + -- The monster didn't yet move this subclip. + handleMonster actor + handleActors subclipStart -- | Handle the move of a single monster. handleMonster :: ActorId -> Action () handleMonster actor = do debug "handleMonster" - cops <- contentOps + cops <- getCOps state <- get - -- Simplification: this is the perception after the last player command - -- and does not take into account, e.g., other monsters opening doors. - per <- currentPerception + per <- getPerception -- Run the AI: choses an action from those given by the AI strategy. join $ rndToAction $ frequency (head (runStrategy (strategy cops actor state per - .| wait actor))) - handleAI - --- TODO: nextMove may not be a good name. It's part of the problem of the --- current design that all of the top-level functions directly call each --- other, rather than being called by a driver function. --- | After everything has been handled for the current game time, we can --- advance the time. Here is the place to do whatever has to be done for --- every time unit, e.g., monster generation. -nextMove :: Action () -nextMove = do - debug "nextMove" - modify (updateTime (+1)) - regenerateLevelHP - generateMonster - handle + .| wait))) -- | Handle the move of the hero. handlePlayer :: Action () handlePlayer = do debug "handlePlayer" - -- Determine perception before running player command, in case monsters - -- have opened doors, etc. - withPerception $ do - remember -- The hero notices his surroundings, before they get displayed. - oldPlayerTime <- gets (btime . getPlayerBody) - playerCommand - -- At this point, the command was successful and possibly took some time. - newPlayerTime <- gets (btime . getPlayerBody) - if newPlayerTime == oldPlayerTime - then handlePlayer -- no time taken, repeat - else do - state <- get - pl <- gets splayer - let time = stime state - ploc = bloc (getPlayerBody state) - sTimeout = Config.get (sconfig state) "monsters" "smellTimeout" - -- Update smell. Only humans leave a strong scent. - when (isAHero pl) $ - modify (updateLevel (updateSmell (IM.insert ploc - (Tile.SmellTime - (time + sTimeout))))) - -- Determine perception to let monsters target heroes. - withPerception handleAI + -- When running, stop if aborted by a disturbance. + -- Otherwise let the player issue commands, until any of them takes time. + -- First time, just after pushing frames, ask for commands in Push mode. + tryWith (\ msg -> stopRunning >> playerCommand msg) $ + ifRunning continueRun abort + addSmell --- | Determine and process the next player command. -playerCommand :: Action () -playerCommand = do - displayAll -- draw the current surroundings - history -- update the message history and reset current message - tryRepeatedlyWith stopRunning $ -- on abort, just ask for a new command - ifRunning continueRun $ do - k <- session nextCommand - session (\ Session{skeyb} -> - case M.lookup k (Binding.kcmd skeyb) of - Just (_, c) -> c - Nothing -> - abortWith $ "unknown command <" ++ show k ++ ">") +-- | Determine and process the next player command. The argument is the last +-- abort message due to running, if any. +playerCommand :: Msg -> Action () +playerCommand msgRunAbort = do + -- The frame state is now Push. + Binding.Binding{kcmd} <- getBinding + kmPush <- case msgRunAbort of + "" -> getKeyCommand (Just True) + _ -> drawPrompt ColorFull msgRunAbort >>= getKeyChoice [] + -- The frame state is now None and remains so between each pair + -- of lines of @loop@ (but can change within called actions). + let loop :: (K.Key, K.Modifier) -> Action () + loop km = do + -- Messages shown, so update history and reset current report. + recordHistory + -- On abort, just reset state and call loop again below. + (timed, frames) <- tryWithFrame (return False) $ do + -- Look up the key. + case M.lookup km kcmd of + Just (_, declaredTimed, c) -> do + ((), frs) <- c + -- Targeting cursor movement and a few other subcommands + -- are wrongly marked as timed. This is indicated in their + -- definitions by setting @snoTime@ flag and used and reset here. + snoTime <- gets snoTime + let timed = declaredTimed && not snoTime + modify (\ s -> s {snoTime = False}) + -- Ensure at least one frame, if the command takes no time. + -- No frames for @abort@, so the code is here, not below. + if not timed && null (catMaybes frs) + then do + fr <- drawPrompt ColorFull "" + return (timed, [Just fr]) + else return (timed, frs) + Nothing -> let msgKey = "unknown command <" ++ K.showKM km ++ ">" + in abortWith msgKey + -- The command was aborted or successful and if the latter, + -- possibly took some time. + if not timed + then do + -- If no time taken, rinse and repeat. + -- Analyse the obtained frames. + let (mfr, frs) = case reverse $ catMaybes frames of + [] -> (Nothing, []) + f : fs -> (Just f, reverse fs) + -- Show, one by one, all but the last frame. + -- Note: the code that generates the frames is responsible + -- for inserting the @more@ prompt. + b <- getOverConfirm frs + -- Display the last frame while waiting for the next key or, + -- if there is no next frame, just get the key. + kmNext <- case mfr of + Just fr | b -> getKeyChoice [] fr + _ -> getKeyCommand Nothing + -- Look up and perform the next command. + loop kmNext + else do + -- Exit the loop and let other actors act. No next key needed + -- and no frames could have been generated. + assert (null frames `blame` length frames) $ + return () + loop kmPush +-- | Advance (or rewind) the move time for the given actor. +advanceTime :: Bool -> ActorId -> Action () +advanceTime forward actor = do + Kind.COps{coactor} <- getCOps + pl <- gets splayer + let upd m@Actor{btime} = + let speed = actorSpeed coactor m + ticks = ticksPerMeter speed + delta | forward = ticks + | otherwise = timeNegate ticks + in m {btime = timeAdd btime delta} + updateAnyActor actor upd + -- A hack to synchronize the whole party: + body <- gets (getActor actor) + when (actor == pl) $ do + let updParty m = if bparty m == heroParty + then m {btime = btime body} + else m + modify (updateLevel (updateActorDict (IM.map updParty))) + + +-- The issues below are now complicated (?) by the fact that we now generate +-- a game screen frame at least once every clip and a jointed pair +-- of frame+key input for each command that does not take time. +-- -- Design thoughts (in order to get rid or partially rid of the somewhat -- convoluted design we have): We have three kinds of commands. -- diff --git a/Game/LambdaHack/Utils/Assert.hs b/Game/LambdaHack/Utils/Assert.hs --- a/Game/LambdaHack/Utils/Assert.hs +++ b/Game/LambdaHack/Utils/Assert.hs @@ -22,6 +22,7 @@ " " ++ show blamed in trace s False +infix 1 `failure` -- | Like 'Prelude.undefined', but shows the source location -- and also the value to blame for the failure. To be used as in: -- diff --git a/Game/LambdaHack/Utils/Frequency.hs b/Game/LambdaHack/Utils/Frequency.hs --- a/Game/LambdaHack/Utils/Frequency.hs +++ b/Game/LambdaHack/Utils/Frequency.hs @@ -17,55 +17,65 @@ -- TODO: do not expose runFrequency -- | The frequency distribution type. -newtype Frequency a = Frequency - { runFrequency :: [(Int, a)] -- ^ Give acces to raw frequency values. +data Frequency a = Frequency + { _name :: String -- ^ short description for debug, etc. + , runFrequency :: [(Int, a)] -- ^ give acces to raw frequency values } deriving Show instance Monad Frequency where - return x = Frequency [(1, x)] - m >>= f = Frequency - [(p * q, y) | (p, x) <- runFrequency m, - (q, y) <- runFrequency (f x) ] + return x = Frequency "return" [(1, x)] + Frequency name xs >>= f = + Frequency ("bind (" ++ name ++ ")") + [(p * q, y) | (p, x) <- xs, + (q, y) <- runFrequency (f x) ] instance MonadPlus Frequency where - mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys) - mzero = Frequency [] + mplus (Frequency xname xs) (Frequency yname ys) = + Frequency ("mplus (" ++ xname ++ ") (" ++ yname ++ ")") + (xs ++ ys) + mzero = Frequency "mzero" [] instance Functor Frequency where - fmap f (Frequency xs) = Frequency (map (\ (p, x) -> (p, f x)) xs) + fmap f (Frequency name xs) = Frequency name (map (\ (p, x) -> (p, f x)) xs) -- | Uniform discrete frequency distribution. -uniformFreq :: [a] -> Frequency a -uniformFreq = Frequency . map (\ x -> (1, x)) +uniformFreq :: String -> [a] -> Frequency a +uniformFreq name = Frequency name . map (\ x -> (1, x)) --- | Takes a list of frequencies and items into the frequency distribution. -toFreq :: [(Int, a)] -> Frequency a +-- | Takes a name and a list of frequencies and items +-- into the frequency distribution. +toFreq :: String -> [(Int, a)] -> Frequency a toFreq = Frequency --- | Scale frequecy distribution, multiplying it by an integer constant. -scaleFreq :: Int -> Frequency a -> Frequency a -scaleFreq n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs) +-- | Scale frequecy distribution, multiplying it +-- by a positive integer constant. +scaleFreq :: Show a => Int -> Frequency a -> Frequency a +scaleFreq n (Frequency name xs) = + assert (n > 0 `blame` ("negative scale for " ++ name, n, xs)) $ + Frequency name (map (\ (p, x) -> (n * p, x)) xs) -- | Leave only items that satisfy a predicate. filterFreq :: (a -> Bool) -> Frequency a -> Frequency a -filterFreq p (Frequency l) = Frequency $ filter (p . snd) l +filterFreq p (Frequency name l) = + Frequency ("filterFreq (" ++ name ++ ")") + (filter (p . snd) l) -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen) -rollFreq (Frequency []) _ = - assert `failure` "choice from an empty frequency" -rollFreq (Frequency [(n, x)]) _ | n <= 0 = - assert `failure` ("singleton frequency with nothing to pick", n, x) -rollFreq (Frequency [(_, x)]) g = (x, g) -- speedup -rollFreq (Frequency fs) g = - assert (sumf > 0 `blame` ("frequency with nothing to pick", fs)) $ +rollFreq (Frequency name []) _ = + assert `failure` ("choice from an empty frequency: " ++ name) +rollFreq (Frequency name [(n, x)]) _ | n <= 0 = + assert `failure` ("singleton frequency with nothing to pick: " ++ name, n, x) +rollFreq (Frequency _ [(_, x)]) g = (x, g) -- speedup +rollFreq (Frequency name fs) g = + assert (sumf > 0 `blame` ("frequency with nothing to pick: " ++ name, fs)) $ (frec r fs, ng) where sumf = sum (map fst fs) (r, ng) = R.randomR (1, sumf) g frec :: Int -> [(Int, a)] -> a - frec m [] = assert `failure` ("impossible", fs, m) + frec m [] = assert `failure` ("impossible", name, fs, m) frec m ((n, x) : _) | m <= n = x frec m ((n, _) : xs) = frec (m - n) xs diff --git a/Game/LambdaHack/Utils/LQueue.hs b/Game/LambdaHack/Utils/LQueue.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Utils/LQueue.hs @@ -0,0 +1,35 @@ +-- | Queues implemented with two stacks to ensure fast writes. +module Game.LambdaHack.Utils.LQueue + ( LQueue, newLQueue, nullLQueue, trimLQueue, tryReadLQueue, writeLQueue + ) where + +import Data.Maybe + +-- | Queues implemented with two stacks. +type LQueue a = ([a], [a]) -- (read_end, write_end) + +-- | Create a new empty mutable queue. +newLQueue :: LQueue a +newLQueue = ([], []) + +-- | Check if the queue is empty. +nullLQueue :: LQueue a -> Bool +nullLQueue (rs, ws) = null rs && null ws + +-- | Remove all but the last written non-@Nothing@ element of the queue. +trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a) +trimLQueue (rs, ws) = + let trim (_, w:_) = ([w], []) + trim ([], []) = ([], []) + trim (rsj, []) = ([last rsj], []) + in trim (filter isJust rs, filter isJust ws) + +-- | Try reading a queue. Return @Nothing@ if empty. +tryReadLQueue :: LQueue a -> Maybe (a, LQueue a) +tryReadLQueue (r : rs, ws) = Just (r, (rs, ws)) +tryReadLQueue ([], []) = Nothing +tryReadLQueue ([], ws) = tryReadLQueue (reverse ws, []) + +-- | Write to the queue. Faster than reading. +writeLQueue :: LQueue a -> a -> LQueue a +writeLQueue (rs, ws) w = (rs, w : ws) diff --git a/Game/LambdaHack/Vector.hs b/Game/LambdaHack/Vector.hs --- a/Game/LambdaHack/Vector.hs +++ b/Game/LambdaHack/Vector.hs @@ -2,7 +2,7 @@ -- but not unique, way. module Game.LambdaHack.Vector ( Vector, toVector, shift, shiftBounded, moves, movesWidth - , euclidDistSq, diagonal, neg, towards + , euclidDistSq, diagonal, neg, towards, displacement, displacePath ) where import Data.Binary @@ -94,6 +94,7 @@ neg :: Vector -> Vector neg (Vector dir) = Vector (-dir) +-- TODO: use bla for that -- | Given a vector of arbitrary non-zero length, produce a unit vector -- that points in the same direction (in the chessboard metric). -- Of several equally good directions it picks one of those that visually @@ -114,7 +115,9 @@ else neg (toDir lxsize $ VectorXY dxy) -- TODO: Perhaps produce all acceptable directions and let AI choose. --- That would also eliminate the Doubles. +-- That would also eliminate the Doubles. Or only directions from bla? +-- Smart monster could really use all dirs to be less predictable, +-- but it wouldn't look as natural as bla, so for less smart bla is better. -- | Given two distinct locations, determine the direction (a unit vector) -- in which one should move from the first in order to get closer -- to the second. Ignores obstacles. Of several equally good directions @@ -124,5 +127,19 @@ towards :: X -> Point -> Point -> Vector towards lxsize loc0 loc1 = assert (loc0 /= loc1 `blame` (loc0, loc1)) $ - let v = displacement lxsize loc0 loc1 + let v = displacementXYZ lxsize loc0 loc1 in normalize lxsize v + +-- | A vector from a point to another. We have +-- +-- > shift loc1 (displacement loc1 loc2) == loc2 +-- +-- Particularly simple and fast implementation in the linear representation. +displacement :: Point -> Point -> Vector +displacement loc1 loc2 = Vector $ loc2 - loc1 + +-- | A vector from a point to another. W have +displacePath :: [Point] -> [Vector] +displacePath [] = [] +displacePath lp1@(_ : lp2) = + map (uncurry displacement) $ zip lp1 lp2 diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -1,9 +1,9 @@ cabal-version: >= 1.10 name: LambdaHack -version: 0.2.0 +version: 0.2.1 license: BSD3 license-file: LICENSE -tested-with: GHC == 7.2.2, GHC == 7.4 +tested-with: GHC == 7.2.2, GHC == 7.4.1 data-files: LICENSE, CREDITS, PLAYING.md, README.md, config.default, config.bot, scores author: Andres Loeh, Mikolaj Konarski @@ -22,15 +22,17 @@ but the fundamental source of flexibility lies in the strict and type-safe separation of code and content. . - Upcoming new features: improved squad combat, - player action undo/redo, ranged combat animations, - completely redesigned UI. Long term goals are focused - around procedural content generation and include - the improvement of the AI monad EDSL, so that rules + New in this release are missiles flying for three turns + (by an old kosmikus' idea), visual feedback for targeting + and animations of combat and individual monster moves. + Upcoming new features: improved squad combat, player action + undo/redo, completely redesigned UI. Long term goals + are focused around procedural content generation and include + in-game content creation, auto-balancing, persistent + content modification based on player behaviour + and the improvement of the AI monad EDSL, so that rules for synthesising monster behaviour from game content - are extensible, readable and easy to debug, - in-game content creation, auto-balancing and persistent - content modification based on player behaviour. + are extensible, readable and easy to debug. . A larger game that depends on the LambdaHack library is Allure of the Stars, available from @@ -78,6 +80,7 @@ Game.LambdaHack.Content.RuleKind, Game.LambdaHack.Content.TileKind, Game.LambdaHack.Display, + Game.LambdaHack.Draw, Game.LambdaHack.Dungeon, Game.LambdaHack.DungeonState, Game.LambdaHack.Effect, @@ -110,10 +113,12 @@ Game.LambdaHack.Strategy, Game.LambdaHack.StrategyAction, Game.LambdaHack.Tile, + Game.LambdaHack.Time, Game.LambdaHack.Turn, Game.LambdaHack.Utils.Assert, Game.LambdaHack.Utils.File, Game.LambdaHack.Utils.Frequency, + Game.LambdaHack.Utils.LQueue, Game.LambdaHack.Vector Game.LambdaHack.VectorXY other-modules: Paths_LambdaHack @@ -135,7 +140,7 @@ other-extensions: MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, CPP ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind + ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude ghc-options: -fno-ignore-asserts -funbox-strict-fields if flag(curses) { @@ -166,7 +171,7 @@ ConfigDefault hs-source-dirs: LambdaHack other-modules: Paths_LambdaHack - build-depends: LambdaHack >= 0.2.0 && < 0.2.1, + build-depends: LambdaHack >= 0.2.1 && < 0.2.2, template-haskell >= 2.6 && < 3, ConfigFile >= 1.1.1 && < 2, @@ -186,9 +191,9 @@ BangPatterns, RecordWildCards, NamedFieldPuns other-extensions: CPP, QuasiQuotes ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind + ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude ghc-options: -fno-ignore-asserts -funbox-strict-fields - ghc-options: -threaded + ghc-options: -threaded -with-rtsopts=-C0.005 executable DumbBot main-is: Main.hs @@ -199,5 +204,5 @@ default-extensions: MonoLocalBinds, BangPatterns, RecordWildCards, NamedFieldPuns ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind + ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude ghc-options: -fno-ignore-asserts -funbox-strict-fields diff --git a/LambdaHack/Content/ActorKind.hs b/LambdaHack/Content/ActorKind.hs --- a/LambdaHack/Content/ActorKind.hs +++ b/LambdaHack/Content/ActorKind.hs @@ -5,6 +5,7 @@ import qualified Game.LambdaHack.Content as Content import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Random +import Game.LambdaHack.Time cdefs :: Content.CDefs ActorKind cdefs = Content.CDefs @@ -13,9 +14,9 @@ , getFreq = afreq , validate = avalidate , content = - [hero, eye, fastEye, nose] + [hero, projectile, eye, fastEye, nose] } -hero, eye, fastEye, nose :: ActorKind +hero, projectile, eye, fastEye, nose :: ActorKind hero = ActorKind { asymbol = '@' @@ -23,24 +24,37 @@ , afreq = [("hero", 1)] -- Does not appear randomly in the dungeon. , acolor = BrWhite -- Heroes white, monsters colorful. , ahp = RollDice 60 1 - , aspeed = 10 + , aspeed = toSpeed 2 , asight = True , asmell = False , aiq = 13 -- Can see hidden doors, when he is under alien control. - , aregen = 5000 + , aregen = 500 } +projectile = ActorKind -- includes homing missiles + { asymbol = '*' + , aname = "projectile" + , afreq = [("projectile", 1)] -- Does not appear randomly in the dungeon. + , acolor = BrWhite + , ahp = RollDice 0 0 + , aspeed = toSpeed 0 + , asight = False + , asmell = False + , aiq = 0 + , aregen = maxBound + } + eye = ActorKind { asymbol = 'e' , aname = "reducible eye" , afreq = [("monster", 60), ("summon", 50)] , acolor = BrRed , ahp = RollDice 3 4 - , aspeed = 10 + , aspeed = toSpeed 2 , asight = True , asmell = False , aiq = 8 - , aregen = 1000 + , aregen = 100 } fastEye = ActorKind { asymbol = 'e' @@ -48,11 +62,11 @@ , afreq = [("monster", 15)] , acolor = BrBlue , ahp = RollDice 1 4 - , aspeed = 5 + , aspeed = toSpeed 4 , asight = True , asmell = False , aiq = 12 - , aregen = 50 -- Regenerates fast (at max HP most of the time!). + , aregen = 5 -- Regenerates fast (at max HP most of the time!). } nose = ActorKind { asymbol = 'n' @@ -60,9 +74,9 @@ , afreq = [("monster", 20), ("summon", 100)] , acolor = Green , ahp = RollDice 7 2 - , aspeed = 11 + , aspeed = toSpeed 1.8 , asight = False , asmell = True , aiq = 0 - , aregen = 1000 + , aregen = 100 } diff --git a/LambdaHack/Content/CaveKind.hs b/LambdaHack/Content/CaveKind.hs --- a/LambdaHack/Content/CaveKind.hs +++ b/LambdaHack/Content/CaveKind.hs @@ -36,8 +36,12 @@ , copenChance = 1%10 , chiddenChance = 1%5 , citemNum = RollDice 5 2 - , cdefTile = "fillerWall" - , ccorTile = "darkCorridor" + , cdefaultTile = "fillerWall" + , ccorridorTile = "darkCorridor" + , cfillerTile = "fillerWall" + , cdarkLegendTile = "darkLegend" + , clitLegendTile = "litLegend" + , chiddenTile = "hidden" } arena = rogue { csymbol = 'A' @@ -49,8 +53,8 @@ , cvoidChance = 1%3 , cnonVoidMin = 2 , citemNum = RollDice 3 2 -- few rooms - , cdefTile = "floorArenaLit" - , ccorTile = "path" + , cdefaultTile = "floorArenaLit" + , ccorridorTile = "path" } empty = rogue { csymbol = '.' @@ -64,8 +68,8 @@ , cnonVoidMin = 1 , cminStairDist = 50 , citemNum = RollDice 6 2 -- whole floor strewn with treasure - , cdefTile = "floorRoomLit" - , ccorTile = "floorRoomLit" + , cdefaultTile = "floorRoomLit" + , ccorridorTile = "floorRoomLit" } noise = rogue { csymbol = '!' @@ -77,6 +81,6 @@ , cvoidChance = 0 , cnonVoidMin = 0 , citemNum = RollDice 3 2 -- few rooms - , cdefTile = "noiseSet" - , ccorTile = "path" + , cdefaultTile = "noiseSet" + , ccorridorTile = "path" } diff --git a/LambdaHack/Content/ItemKind.hs b/LambdaHack/Content/ItemKind.hs --- a/LambdaHack/Content/ItemKind.hs +++ b/LambdaHack/Content/ItemKind.hs @@ -15,9 +15,9 @@ , getFreq = ifreq , validate = ivalidate , content = - [amulet, dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight] + [amulet, dart, gem1, gem2, gem3, gold, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight] } -amulet, dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight :: ItemKind +amulet, dart, gem1, gem2, gem3, gold, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight :: ItemKind gem, potion, scroll :: ItemKind -- generic templates @@ -32,7 +32,9 @@ , icount = intToDeep 1 , ipower = (RollDice 2 3, RollDice 1 10) , iverbApply = "tear down" - , iverbProject = "throw" + , iverbProject = "cast" + , iweight = 30 + , itoThrow = -50 -- not dense enough } dart = ItemKind { isymbol = '|' @@ -43,7 +45,9 @@ , icount = (RollDice 3 3, RollDice 0 0) , ipower = intToDeep 0 , iverbApply = "snap" - , iverbProject = "throw" + , iverbProject = "hurl" + , iweight = 50 + , itoThrow = 0 -- a cheap dart } gem = ItemKind { isymbol = '*' @@ -54,16 +58,18 @@ , icount = intToDeep 0 , ipower = intToDeep 0 , iverbApply = "crush" - , iverbProject = "throw" + , iverbProject = "toss" + , iweight = 50 + , itoThrow = 0 } gem1 = gem - { icount = (RollDice 1 1, RollDice 1 1) -- appears on lvl 1 + { icount = (RollDice 0 0, RollDice 1 1) -- appears on lvl 1 } gem2 = gem { icount = (RollDice 0 0, RollDice 1 2) -- appears halfway } gem3 = gem - { icount = (RollDice 0 0, RollDice 1 1) -- appears on max depth + { icount = (RollDice 0 0, RollDice 1 3) -- appears on max depth } gold = ItemKind { isymbol = '$' @@ -74,18 +80,22 @@ , icount = (RollDice 0 0, RollDice 10 10) , ipower = intToDeep 0 , iverbApply = "grind" - , iverbProject = "throw" + , iverbProject = "toss" + , iweight = 31 + , itoThrow = 0 } -javelin = ItemKind +harpoon = ItemKind { isymbol = '|' - , iname = "javelin" + , iname = "harpoon" , ifreq = [("dng", 30)] , iflavour = zipPlain [Brown] , ieffect = Wound (RollDice 1 2) , icount = (RollDice 0 0, RollDice 2 2) , ipower = (RollDice 1 1, RollDice 2 2) , iverbApply = "break up" - , iverbProject = "throw" + , iverbProject = "hurl" + , iweight = 4000 + , itoThrow = 0 -- cheap but deadly } potion = ItemKind { isymbol = '!' @@ -97,6 +107,8 @@ , ipower = intToDeep 0 , iverbApply = "gulp down" , iverbProject = "lob" + , iweight = 200 + , itoThrow = -50 -- oily, bad grip } potion1 = potion { ifreq = [("dng", 5)] @@ -120,7 +132,9 @@ , icount = intToDeep 1 , ipower = (RollDice 1 6, RollDice 3 2) , iverbApply = "squeeze down" - , iverbProject = "throw" + , iverbProject = "toss" + , iweight = 15 + , itoThrow = 0 } scroll = ItemKind { isymbol = '?' @@ -131,7 +145,9 @@ , icount = intToDeep 1 , ipower = intToDeep 0 , iverbApply = "decipher" - , iverbProject = "throw" + , iverbProject = "lob" + , iweight = 50 + , itoThrow = -75 -- bad shape, even rolled up } scroll1 = scroll { ieffect = SummonFriend @@ -153,6 +169,8 @@ , ipower = (RollDice 1 2, RollDice 4 2) , iverbApply = "hit" , iverbProject = "heave" + , iweight = 2000 + , itoThrow = -50 -- ensuring it hits with the tip costs speed } wand = ItemKind { isymbol = '/' @@ -164,6 +182,8 @@ , ipower = intToDeep 0 , iverbApply = "snap" , iverbProject = "zap" + , iweight = 300 + , itoThrow = 25 -- magic } fist = sword { isymbol = '@' diff --git a/LambdaHack/Content/RuleKind.hs b/LambdaHack/Content/RuleKind.hs --- a/LambdaHack/Content/RuleKind.hs +++ b/LambdaHack/Content/RuleKind.hs @@ -37,4 +37,6 @@ , rtitle = "LambdaHack" , rpathsDataFile = Self.getDataFileName , rpathsVersion = Self.version + , ritemMelee = ")" + , ritemProject = "!?|/" } diff --git a/PLAYING.md b/PLAYING.md --- a/PLAYING.md +++ b/PLAYING.md @@ -57,32 +57,29 @@ /|\ /|\ 1 2 3 b j n -Shift and a movement key make the hero run in the indicated direction, -until anything of interest is spotted. '5' and '.' skip a turn. -(Note that If you are using the curses or vty frontends, -numerical keypad may not work correctly depending on the versions -of curses, terminfo and terminal emulators. Vi keys should work regardless.) +SHIFT (or CTRL) and a movement key make the hero run in the indicated +direction, until anything of interest is spotted. '5' and '.' skip a turn. Melee, searching for secret doors and opening closed doors can be done by bumping into a monster, a wall and a door, respectively. Below are the default keys for major commands. Those of them that take hero time are marked with a *. - key command - < ascend a level* - > descend a level* - ? display help - Q quit without saving - X save and exit the game - c close a door* - d drop an object* - g get an object* - i display inventory - o open a door* - q quaff a potion* - r read a scroll* - t throw a dart* - z zap a wand* + key command + < ascend a level* + > descend a level* + ? display help + Q quit without saving + X save and exit the game + c close a door* + d drop an object* + g get an object* + i display inventory + o open a door* + q quaff a potion* + r read a scroll* + t throw a dart* + z zap a wand* To make a ranged attack, you need to set your target first, using targeting mode. Note that the target, for the few commands that require any, @@ -95,28 +92,29 @@ than the selected hero). The targeting commands and all the less used commands are listed below. None of them takes hero time. - key command - ESC cancel action - RET accept choice - SPACE clear messages - TAB cycle among heroes on level - * target monster - / target location - D dump current configuration - P display previous messages - V display game version - [ target next shallower level - ] target next deeper level - { target 10 levels shallower - } target 10 levels deeper - 0--9 select a hero anywhere in the dungeon (gtk only) + key command + ESC cancel action + RET accept choice + SPACE clear messages + TAB cycle among heroes on level + * target monster + / target location + D dump current configuration + P display previous messages + V display game version + [ target next shallower level + ] target next deeper level + { target 10 levels shallower + } target 10 levels deeper + 0--9 select a hero anywhere in the dungeon -There are also some debug and cheat keys. Use at your own peril! +There are also some debug and cheat keys, all entered with the CTRL +key modifier. Use at your own peril! - key command - O toggle "omniscience" - I inform about level meta-data - R rotate display modes + key command + CTRL-o toggle "omniscience" + CTRL-i inform about level meta-data + CTRL-r rotate vision modes (effective next turn) Monsters diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -61,12 +61,21 @@ e.g., by helping it play longer, as in the supplied config.bot. -Compatibility note ------------------- +Compatibility notes +------------------- The current code was tested with GHC 7.2.2 and several pre-release versions of GHC 7.4. A [few tweaks] [6] are needed to compile with 7.0 and some more are needed for 6.12. + +If you are using the curses or vty frontends, +numerical keypad may not work correctly depending on the versions +of curses, terminfo and terminal emulators. +Selecting heroes via number keys or SHIFT-keypad keys is disabled +with curses, because CTRL-keypad for running does not work there, +so the numbers produced by the keypad have to be used. With vty on xterm, +CTRL-direction keys seem to work OK, but on rxvt they do not. +Vi keys (ykuhlbjn) should work everywhere regardless. Gtk works fine, too. Further information diff --git a/config.default b/config.default --- a/config.default +++ b/config.default @@ -18,6 +18,8 @@ ; braceright: TgtAscend (-10) ; slash: TgtFloor ; asterisk: TgtEnemy +; plus: EpsIncr True +; minus: EpsIncr False ; Tab: HeroCycle ; ; ; ; Items. @@ -27,7 +29,7 @@ ; q: Apply { verb = "quaff", object = "potion", syms = "!" } ; r: Apply { verb = "read", object = "scroll", syms = "?" } ; z: Project { verb = "zap", object = "wand", syms = "/" } -; t: Project { verb = "throw", object = "dart", syms = "|" } +; t: Project { verb = "throw", object = "missile", syms = "|" } ; ; ; ; Saving or ending the game. ; X: GameSave @@ -84,7 +86,7 @@ ; period: KP_Begin ; [monsters] -; smellTimeout: 1000 +; smellTimeout: 100 ; [ui] ; font: Terminus,Monospace normal normal normal normal 12 diff --git a/scores b/scores Binary files a/scores and b/scores differ