packages feed

LambdaHack 0.2.0 → 0.2.1

raw patch · 59 files changed

+3546/−1994 lines, 59 filesdep ~LambdaHackdep ~base

Dependency ranges changed: LambdaHack, base

Files

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 @@   (>>=)  = 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
Game/LambdaHack/Actions.hs view
@@ -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
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,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)"
Game/LambdaHack/ActorState.hs view
@@ -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
Game/LambdaHack/Binding.hs view
@@ -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+    ]
Game/LambdaHack/BindingAction.hs view
@@ -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   }
Game/LambdaHack/Cave.hs view
@@ -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
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 @@   | 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
Game/LambdaHack/Command.hs view
@@ -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"
Game/LambdaHack/Content/ActorKind.hs view
@@ -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
Game/LambdaHack/Content/CaveKind.hs view
@@ -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
Game/LambdaHack/Content/ItemKind.hs view
@@ -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
Game/LambdaHack/Content/RuleKind.hs view
@@ -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
Game/LambdaHack/Display.hs view
@@ -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
Game/LambdaHack/Display/Curses.hs view
@@ -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
Game/LambdaHack/Display/Gtk.hs view
@@ -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}
Game/LambdaHack/Display/Std.hs view
@@ -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.
Game/LambdaHack/Display/Vty.hs view
@@ -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.
+ Game/LambdaHack/Draw.hs view
@@ -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
Game/LambdaHack/Dungeon.hs view
@@ -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
Game/LambdaHack/DungeonState.hs view
@@ -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
Game/LambdaHack/EffectAction.hs view
@@ -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 ++ ")"
Game/LambdaHack/Feature.hs view
@@ -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)
Game/LambdaHack/Grammar.hs view
@@ -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."
Game/LambdaHack/HighScore.hs view
@@ -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
Game/LambdaHack/Item.hs view
@@ -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 =
Game/LambdaHack/ItemAction.hs view
@@ -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
Game/LambdaHack/Key.hs view
@@ -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)   = "<KeyPad " ++ [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 '{'
Game/LambdaHack/Kind.hs view
@@ -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."
Game/LambdaHack/Level.hs view
@@ -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
Game/LambdaHack/Misc.hs view
@@ -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
Game/LambdaHack/Msg.hs view
@@ -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 ++ "<x" ++ show n ++ ">"++-- | 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)
Game/LambdaHack/Perception.hs view
@@ -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
Game/LambdaHack/Place.hs view
@@ -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) $
Game/LambdaHack/Point.hs view
@@ -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
Game/LambdaHack/PointXY.hs view
@@ -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 <http://roguebasin.roguelikedevelopment.org/index.php/Digital_lines>.+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)
Game/LambdaHack/Random.hs view
@@ -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.
Game/LambdaHack/Running.hs view
@@ -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
Game/LambdaHack/Save.hs view
@@ -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
Game/LambdaHack/Start.hs view
@@ -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
Game/LambdaHack/State.hs view
@@ -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
Game/LambdaHack/Strategy.hs view
@@ -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 []
Game/LambdaHack/StrategyAction.hs view
@@ -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)
Game/LambdaHack/Tile.hs view
@@ -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
+ Game/LambdaHack/Time.hs view
@@ -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 <https://github.com/kosmikus/LambdaHack/wiki/Item-statistics>.+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 <https://github.com/kosmikus/LambdaHack/wiki/Item-statistics>.+-- 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))
Game/LambdaHack/Turn.hs view
@@ -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. --
Game/LambdaHack/Utils/Assert.hs view
@@ -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: --
Game/LambdaHack/Utils/Frequency.hs view
@@ -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
+ Game/LambdaHack/Utils/LQueue.hs view
@@ -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)
Game/LambdaHack/Vector.hs view
@@ -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
LambdaHack.cabal view
@@ -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
LambdaHack/Content/ActorKind.hs view
@@ -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   }
LambdaHack/Content/CaveKind.hs view
@@ -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"   }
LambdaHack/Content/ItemKind.hs view
@@ -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  = '@'
LambdaHack/Content/RuleKind.hs view
@@ -37,4 +37,6 @@   , rtitle         = "LambdaHack"   , rpathsDataFile = Self.getDataFileName   , rpathsVersion  = Self.version+  , ritemMelee     = ")"+  , ritemProject   = "!?|/"   }
PLAYING.md view
@@ -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
README.md view
@@ -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
config.default view
@@ -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
scores view

binary file changed (226 → 45 bytes)