Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge pull request #29 from kosmikus/mikolaj

Milestone 0.2.1
  • Loading branch information...
commit aa921be12957d81593b10e837a04b903308625cd 2 parents e5a5c0b + 917e99f
Mikolaj Konarski Mikolaj authored
Showing with 3,562 additions and 2,010 deletions.
  1. +423 −225 Game/LambdaHack/Action.hs
  2. +183 −124 Game/LambdaHack/Actions.hs
  3. +93 −58 Game/LambdaHack/Actor.hs
  4. +154 −82 Game/LambdaHack/ActorState.hs
  5. +19 −17 Game/LambdaHack/Binding.hs
  6. +31 −19 Game/LambdaHack/BindingAction.hs
  7. +21 −17 Game/LambdaHack/Cave.hs
  8. +43 −6 Game/LambdaHack/Color.hs
  9. +26 −19 Game/LambdaHack/Command.hs
  10. +5 −2 Game/LambdaHack/Content/ActorKind.hs
  11. +6 −2 Game/LambdaHack/Content/CaveKind.hs
  12. +2 −0  Game/LambdaHack/Content/ItemKind.hs
  13. +2 −0  Game/LambdaHack/Content/RuleKind.hs
  14. +5 −196 Game/LambdaHack/Display.hs
  15. +39 −26 Game/LambdaHack/Display/Curses.hs
  16. +387 −105 Game/LambdaHack/Display/Gtk.hs
  17. +30 −23 Game/LambdaHack/Display/Std.hs
  18. +61 −43 Game/LambdaHack/Display/Vty.hs
  19. +177 −0 Game/LambdaHack/Draw.hs
  20. +5 −1 Game/LambdaHack/Dungeon.hs
  21. +18 −17 Game/LambdaHack/DungeonState.hs
  22. +357 −263 Game/LambdaHack/EffectAction.hs
  23. +1 −1  Game/LambdaHack/Feature.hs
  24. +125 −46 Game/LambdaHack/Grammar.hs
  25. +24 −13 Game/LambdaHack/HighScore.hs
  26. +5 −3 Game/LambdaHack/Item.hs
  27. +206 −170 Game/LambdaHack/ItemAction.hs
  28. +48 −15 Game/LambdaHack/Key.hs
  29. +8 −3 Game/LambdaHack/Kind.hs
  30. +27 −35 Game/LambdaHack/Level.hs
  31. +1 −4 Game/LambdaHack/Misc.hs
  32. +151 −36 Game/LambdaHack/Msg.hs
  33. +42 −33 Game/LambdaHack/Perception.hs
  34. +10 −8 Game/LambdaHack/Place.hs
  35. +19 −4 Game/LambdaHack/Point.hs
  36. +20 −1 Game/LambdaHack/PointXY.hs
  37. +1 −1  Game/LambdaHack/Random.hs
  38. +25 −20 Game/LambdaHack/Running.hs
  39. +27 −7 Game/LambdaHack/Save.hs
  40. +7 −6 Game/LambdaHack/Start.hs
  41. +37 −32 Game/LambdaHack/State.hs
  42. +8 −8 Game/LambdaHack/Strategy.hs
  43. +94 −63 Game/LambdaHack/StrategyAction.hs
  44. +8 −13 Game/LambdaHack/Tile.hs
  45. +143 −0 Game/LambdaHack/Time.hs
  46. +201 −123 Game/LambdaHack/Turn.hs
  47. +1 −0  Game/LambdaHack/Utils/Assert.hs
  48. +35 −25 Game/LambdaHack/Utils/Frequency.hs
  49. +35 −0 Game/LambdaHack/Utils/LQueue.hs
  50. +20 −3 Game/LambdaHack/Vector.hs
  51. +20 −15 LambdaHack.cabal
  52. +24 −10 LambdaHack/Content/ActorKind.hs
  53. +12 −8 LambdaHack/Content/CaveKind.hs
  54. +33 −13 LambdaHack/Content/ItemKind.hs
  55. +2 −0  LambdaHack/Content/RuleKind.hs
  56. +40 −42 PLAYING.md
  57. +11 −2 README.md
  58. +4 −2 config.default
  59. BIN  scores
648 Game/LambdaHack/Action.hs
View
@@ -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 @@ instance Monad Action where
(>>=) = 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)
+ runAction (f x) s p k a nst nm
+ in runAction m s p next a st ms)
-instance MonadIO Action where
- liftIO x = Action (\ _s _e _p k _a st ms -> x >>= k 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 @@ rndToAction r = do
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 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"))
--- | Try the given computation until it succeeds without failure.
-tryRepeatedly :: Action () -> Action ()
-tryRepeatedly = tryRepeatedlyWith (return ())
-
--- | 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
-
--- | 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
-
--- | Ignore unexpected kestrokes until a SPACE or ESC is pressed.
-getConfirm :: Session -> Action Bool
-getConfirm Session{sfs} = liftIO $ getConfirmD sfs
-
--- | 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 msg, await confirmation, ignore confirmation.
-msgMore :: Msg -> Action ()
-msgMore msg = msgClear >> msgMoreConfirm ColorFull msg >> return ()
-
--- | 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
-
--- | Clear message and overlay.
-clearDisplay :: Action Bool
-clearDisplay = do
- msgClear
- displayAll
- return False
-
--- | 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
+ _ -> return False
+
+-- | 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
+
+-- | 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 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 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 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)
+
+-- | 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
+
+-- | 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 @@ updatePlayerBody f = do
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
-
--- | Add a turn to the player time counter.
-playerAdvanceTime :: Action ()
-playerAdvanceTime = do
- pl <- gets splayer
- advanceTime pl
-
--- | Display command help.
-displayHelp :: Action ()
-displayHelp = do
- let disp Session{skeyb} =
- msgOverlaysConfirm "Basic keys. [press SPACE or ESC]" $ keyHelp skeyb
- session disp
- abort
+-- | Obtains the current date and time.
+currentDate :: Action ClockTime
+currentDate = liftIO getClockTime
+
+-- | 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
+
+-- | 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
307 Game/LambdaHack/Actions.hs
View
@@ -24,8 +24,6 @@ import Game.LambdaHack.Actor
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.ActorKind
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 @@ moveCursor dir n = do
-- 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 @@ guessBump _ _ _ = neverMind True
-- | 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 @@ playerTriggerTile feat = do
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 @@ actorOpenDoor actor dir = do
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 @@ actorOpenDoor actor dir = do
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 @@ tgtAscend k = do
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 @@ tgtAscend k = do
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 @@ tgtAscend k = do
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 @@ search = do
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 @@ moveOrAttack :: Bool -- ^ allow attacks?
-> 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 @@ moveOrAttack allowAttacks actor dir = do
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 @@ moveOrAttack allowAttacks actor dir = do
-- 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 @@ rollMonster Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} per state = do
, \ 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 @@ rollMonster Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} per state = do
-- | 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 :: Action ()
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 @@ regenerateLevelHP = do
-- 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
151 Game/LambdaHack/Actor.hs
View
@@ -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,13 +19,38 @@ import Data.Maybe
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@,
@@ -32,67 +60,51 @@ data Actor = Actor
{ 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 @@ findHeroName config n =
-- 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 @@ monsterGenChance d numMonsters =
-- | 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 @@ unoccupied actors loc =
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)"
236 Game/LambdaHack/ActorState.hs
View
@@ -12,10 +12,12 @@ import qualified Data.Char as Char
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.Config as Config
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 @@ getPlayerItem s@State{splayer} =
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 @@ updateAnyLevel f ln s@State{slid, sdungeon}
| 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,54 +125,69 @@ targetToLoc visible s@State{slid, scursor} =
-- 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
+
+-- 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
-levelHeroList, levelMonsterList :: State -> [Actor]
-levelHeroList state = IM.elems $ lheroes $ slevel state
-levelMonsterList state = IM.elems $ lmonsters $ slevel state
+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
@@ -164,39 +198,50 @@ locToActor loc state =
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 @@ initialHeroes cops ploc state =
-- 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
36 Game/LambdaHack/Binding.hs
View
@@ -11,13 +11,15 @@ import qualified Data.Set as S
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 @@ coImage kmacro k =
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 @@ keyHelp Binding{kcmd, kmacro, kmajor, ktimed} =
, " /|\\ /|\\"
, " 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 @@ keyHelp Binding{kcmd, kmacro, kmajor, ktimed} =
, "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
+ ]
50 Game/LambdaHack/BindingAction.hs
View
@@ -18,7 +18,7 @@ import Game.LambdaHack.Running
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 @@ configCmd config =
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 @@ checkCursor h = do
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 @@ stdBinding config cmdS cmdD =
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
}
38 Game/LambdaHack/Cave.hs
View
@@ -6,7 +6,9 @@ module Game.LambdaHack.Cave
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 qualified Game.LambdaHack.Feature as F
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 @@ buildCave :: Kind.COps -- ^ content definitions
-> 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 @@ buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{okind=tokind, opick}
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 @@ buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{okind=tokind, opick}
}
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 @@ digCorridors _ _ = M.empty
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 @@ mergeCorridor :: Kind.Ops TileKind
-> 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
49 Game/LambdaHack/Color.hs
View
@@ -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 @@ data Color =
| 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,10 +50,46 @@ data Attr = Attr
}
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
isBright c = c >= BrBlack
45 Game/LambdaHack/Command.hs
View
@@ -14,16 +14,20 @@ import qualified Game.LambdaHack.Feature as F
-- | 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
| Can