packages feed

LambdaHack 0.2.1 → 0.2.6

raw patch · 79 files changed

+3563/−2721 lines, 79 filesdep ~LambdaHack

Dependency ranges changed: LambdaHack

Files

+ Game/LambdaHack/Ability.hs view
@@ -0,0 +1,20 @@+-- | AI strategy abilities.+module Game.LambdaHack.Ability+  ( Ability(..)+  ) where++-- | All possible AI actor abilities. AI chooses among these when considering+-- the next action to perform. The ability descriptions refer to the target+-- that any actor picks each turn, depending on the actor's characteristics+-- and his environment.+data Ability =+    Track   -- ^ move along a set path, if any, meleeing any opponents+  | Heal    -- ^ heal if almost dead+  | Flee    -- ^ flee if almost dead+  | Melee   -- ^ melee target+  | Pickup  -- ^ gather items, if no foes visible+  | Ranged  -- ^ attack the visible target opponent at range, some of the time+  | Tools   -- ^ use items, if target opponent visible, some of the time+  | Chase   -- ^ chase the target, ignoring any actors on the way+  | Wander  -- ^ wander around, meleeing any opponents on the way+  deriving (Show, Eq, Ord, Enum, Bounded)
Game/LambdaHack/Action.hs view
@@ -1,31 +1,27 @@--- | Game action monad and basic building blocks--- for player and monster actions.-{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+-- | Game action monad and basic building blocks for player and monster+-- actions. Uses @liftIO@ of the @Action@ monad, but does not export it.+-- Has no direct access to the Action monad implementation. module Game.LambdaHack.Action-  ( -- * Actions and basic operations-    ActionFun, Action, handlerToIO, rndToAction+  ( -- * Actions and accessors+    Action, getPerception, getCOps, getBinding     -- * Actions returning frames-  , ActionFrame, returnNoFrame, whenFrame, inFrame-    -- * Game session and its accessors-  , Session(..), getCOps, getBinding+  , ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame, tryWithFrame     -- * Various ways to abort action   , abort, abortWith, abortIfWith, neverMind     -- * Abort exception handlers-  , tryWith, tryWithFrame, tryRepeatedlyWith, tryIgnore, tryIgnoreFrame+  , tryWith, tryRepeatedlyWith, tryIgnore     -- * Diary and report   , getDiary, msgAdd, recordHistory     -- * Key input-  , getKeyCommand, getKeyChoice, getOverConfirm+  , getKeyCommand, getKeyFrameCommand, 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+  , saveGameBkp, dumpCfg, endOrLoop, frontendName, startFrontend   , debug   ) where @@ -34,165 +30,34 @@ 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.Action.ActionLift import Game.LambdaHack.Perception-import Game.LambdaHack.Display+import Game.LambdaHack.Action.Frontend import Game.LambdaHack.Draw import Game.LambdaHack.Msg import Game.LambdaHack.State import Game.LambdaHack.Level import Game.LambdaHack.Actor import Game.LambdaHack.ActorState-import qualified Game.LambdaHack.Save as Save+import qualified Game.LambdaHack.Action.Save as Save import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Random import qualified Game.LambdaHack.Key as K import Game.LambdaHack.Binding-import qualified Game.LambdaHack.HighScore as H+import Game.LambdaHack.Action.HighScore (register) import qualified Game.LambdaHack.Config as Config-import qualified Game.LambdaHack.Color as Color+import qualified Game.LambdaHack.Action.ConfigIO as ConfigIO+import Game.LambdaHack.Animation (SingleFrame(..)) 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-   -> DungeonPerception              -- ^ cached perception-   -> (State -> Diary -> a -> IO r)  -- ^ continuation-   -> (Msg -> IO r)                  -- ^ failure/reset continuation-   -> State                          -- ^ current state-   -> Diary                          -- ^ current diary-   -> IO r---- | Actions of player-controlled characters and of any other actors.-newtype Action a = Action-  { runAction :: forall r . ActionFun r a-  }--instance Show (Action a) where-  show _ = "an action"---- TODO: check if it's strict enough, if we don't keep old states for too long,--- Perhaps make state type fields strict for that, too?-instance Monad Action where-  return = returnAction-  (>>=)  = bindAction--instance Functor Action where-  fmap f (Action g) = Action (\ s p k a st ms ->-                               let k' st' ms' = k st' ms' . f-                               in g s p k' a st ms)--instance MonadState State Action where-  get     = Action (\ _s _p k _a  st ms -> k st  ms st)-  put nst = Action (\ _s _p k _a _st ms -> k nst ms ())---- | Invokes the action continuation on the provided argument.-returnAction :: a -> Action a-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 p k a st ms ->-                          let next nst nm x =-                                runAction (f x) s p k a nst nm-                          in runAction m s p next a st ms)---- 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{scops} state diary h =-  runAction h-    sess-    (dungeonPerception scops state)  -- create and cache perception-    (\ _ _ x -> return x)    -- final continuation returns result-    (\ msg ->-      ioError $ userError $ "unhandled abort  " ++ msg)  -- e.g., in AI code-    state-    diary---- | Invoke pseudo-random computation with the generator kept in the state.-rndToAction :: Rnd a -> Action a-rndToAction r = do-  g <- gets srandom-  let (a, ng) = runState r g-  modify (\ state -> state {srandom = ng})-  return a---- | Actions and screen frames, including delays, resulting--- from performing the actions.-type ActionFrame a = Action (a, [Maybe Color.SingleFrame])---- | Return the value with an empty set of screen frames.-returnNoFrame :: a -> ActionFrame a-returnNoFrame a = return (a, [])---- | As the @when@ monad operation, but on type @ActionFrame ()@.-whenFrame :: Bool -> ActionFrame () -> ActionFrame ()-whenFrame True x  = x-whenFrame False _ = returnNoFrame ()---- | Inject action into actions with screen frames.-inFrame :: Action () -> ActionFrame ()-inFrame act = act >> returnNoFrame ()---- | 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-  }---- | Get the frontend session.-getFrontendSession :: Action FrontendSession-getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs)---- | Get the content operations.-getCOps :: Action Kind.COps-getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops)---- | 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 = 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 :: (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)+import qualified Game.LambdaHack.DungeonState as DungeonState+import Game.LambdaHack.Item+import Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Tile as Tile  -- | Set the current exception handler. Apart of executing it, -- draw and pass along a frame with the abort message, if any.@@ -202,53 +67,13 @@       msgToFrames msg = do         msgReset ""         fr <- drawPrompt ColorFull msg-        return ((), [Just fr])+        returnFrame 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 :: (Msg -> Action ()) -> Action () -> Action ()-tryRepeatedlyWith exc h =-  tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h---- | Try the given computation and silently catch failure.-tryIgnore :: Action () -> Action ()-tryIgnore =-  tryWith (\ msg -> if null msg-                    then return ()-                    else assert `failure` (msg, "in tryIgnore"))---- | Try the given computation and silently catch failure,--- returning empty set of screen frames.-tryIgnoreFrame :: ActionFrame () -> ActionFrame ()-tryIgnoreFrame =-  tryWith (\ msg -> if null msg-                    then returnNoFrame ()-                    else assert `failure` (msg, "in tryIgnoreFrame"))---- | Get the current diary.-getDiary :: Action Diary-getDiary = Action (\ _s _p k _a st diary -> k st diary diary)---- | 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} ())---- | 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{..} ())---- | 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@@ -269,15 +94,18 @@     K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)     _ -> (nc, modifier) --- | Wait for a player keypress.-getKeyChoice :: [(K.Key, K.Modifier)] -> Color.SingleFrame-          -> Action (K.Key, K.Modifier)-getKeyChoice keys frame = do+-- | Display frame and wait for a player command.+getKeyFrameCommand :: SingleFrame -> Action (K.Key, K.Modifier)+getKeyFrameCommand frame = do   fs <- getFrontendSession-  liftIO $ promptGetKey fs keys frame+  keyb <- getBinding+  (nc, modifier) <- liftIO $ promptGetKey fs [] frame+  return $ case modifier of+    K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)+    _ -> (nc, modifier)  -- | Ignore unexpected kestrokes until a SPACE or ESC is pressed.-getConfirm :: Color.SingleFrame -> Action Bool+getConfirm :: SingleFrame -> Action Bool getConfirm frame = do   fs <- getFrontendSession   let keys = [ (K.Space, K.NoModifier), (K.Esc, K.NoModifier)]@@ -287,7 +115,7 @@     _       -> return False  -- | A series of confirmations for all overlays.-getOverConfirm :: [Color.SingleFrame] -> Action Bool+getOverConfirm :: [SingleFrame] -> Action Bool getOverConfirm []     = return True getOverConfirm (x:xs) = do   b <- getConfirm x@@ -296,7 +124,7 @@     else return False  -- | A yes-no confirmation.-getYesNo :: Color.SingleFrame -> Action Bool+getYesNo :: SingleFrame -> Action Bool getYesNo frame = do   fs <- getFrontendSession   let keys = [ (K.Char 'y', K.NoModifier)@@ -308,41 +136,49 @@     K.Char 'y' -> return True     _          -> return False +-- TODO: perhaps add prompt to Report instead?+promptAdd :: Msg -> Msg -> Msg+promptAdd "" msg = msg+promptAdd prompt msg = prompt ++ " " ++ msg+ -- | 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)+  let newPrompt = promptAdd prompt moreMsg+  frame <- drawPrompt dm newPrompt   getConfirm frame  -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice. displayYesNo :: Msg -> Action Bool displayYesNo prompt = do-  frame <- drawPrompt ColorBW (prompt ++ yesnoMsg)+  frame <- drawPrompt ColorBW (promptAdd prompt yesnoMsg)   getYesNo frame  -- | Print a msg and several overlays, one per page.--- All frames require confirmations. Raise @abort@ if the players presses ESC.+-- All frames require confirmations. Raise @abort@ if the player presses ESC. displayOverAbort :: Msg -> [Overlay] -> Action () displayOverAbort prompt xs = do-  let f x = drawOverlay ColorFull prompt (x ++ [moreMsg])+  let newPrompt = promptAdd prompt ""+  let f x = drawOverlay ColorFull newPrompt (x ++ [moreMsg])   frames <- mapM f xs-  b <- getOverConfirm frames-  when (not b) abort+  go <- getOverConfirm frames+  when (not go) abort  -- | Print a msg and several overlays, one per page.--- The last frame does not expect a confirmation.-displayOverlays :: Msg -> [Overlay] -> ActionFrame ()-displayOverlays _      []     = returnNoFrame ()-displayOverlays prompt [x]    = do+-- The last frame does not expect a confirmation and so does not show+-- the invitation to press some keys.+displayOverlays :: Msg -> 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])+  returnFrame frame+displayOverlays prompt pressKeys (x:xs) = do+  frame <- drawOverlay ColorFull (promptAdd prompt pressKeys) (x ++ [moreMsg])   b <- getConfirm frame   if b-    then displayOverlays prompt xs+    then displayOverlays prompt pressKeys xs     else returnNoFrame ()  -- | Print a prompt and an overlay and wait for a player keypress.@@ -355,15 +191,17 @@         [] -> ([], [], "", [], keys)         [x] -> (x, [], "", [], keys)         x:xs -> (x, xs, ", SPACE", [moreMsg], (K.Space, K.NoModifier) : keys)+      legalKeys =  (K.Esc, K.NoModifier) : keysS   frame <- drawOverlay ColorFull (prompt ++ spc ++ ", ESC]") (over ++ more)-  (key, modifier) <- getKeyChoice ((K.Esc, K.NoModifier) : keysS) frame+  fs <- getFrontendSession+  (key, modifier) <- liftIO $ promptGetKey fs legalKeys frame   case key of     K.Esc -> neverMind True     K.Space | not (null rest) -> displayChoiceUI prompt rest keys     _ -> return (key, modifier)  -- | Push a frame or a single frame's worth of delay to the frame queue.-displayFramePush :: Maybe Color.SingleFrame -> Action ()+displayFramePush :: Maybe SingleFrame -> Action () displayFramePush mframe = do   fs <- getFrontendSession   liftIO $ displayFrame fs False mframe@@ -371,7 +209,7 @@ -- | 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 :: ColorMode -> Msg -> Action SingleFrame drawPrompt dm prompt = do   cops <- getCOps   per <- getPerception@@ -384,7 +222,7 @@ -- 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 :: ColorMode -> Msg -> Overlay -> Action SingleFrame drawOverlay dm prompt overlay = do   cops <- getCOps   per <- getPerception@@ -419,123 +257,203 @@       isRunning = isJust bdir   liftIO $ displayFrame fs isRunning $ Just frame --- | Update player memory.+-- | Update heroes memory. remember :: Action () remember = do   per <- getPerception   let vis = IS.toList (totalVisible per)   rememberList vis --- | Update player at the given list of locations..+-- | Update heroes memory at the given list of locations. rememberList :: [Point] -> Action () rememberList vis = do+  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getCOps   lvl <- gets slevel   let rememberTile = [(loc, lvl `at` loc) | loc <- vis]+      unknownId = ouniqGroup "unknown space"+      newClear (loc, tk) = lvl `rememberAt` loc == unknownId+                           && Tile.isExplorable cotile tk+      clearN = length $ filter newClear rememberTile   modify (updateLevel (updateLRMap (Kind.// rememberTile)))+  modify (updateLevel (\ l@Level{lseen} -> l {lseen = lseen + clearN}))   let alt Nothing      = Nothing       alt (Just ([], _)) = Nothing       alt (Just (t, _))  = Just (t, t)       rememberItem = IM.alter alt   modify (updateLevel (updateIMap (\ m -> foldr rememberItem m vis))) --- | Update the cached perception for the given computation.-withPerception :: Action () -> Action ()-withPerception h =-  Action (\ sess@Session{scops} _ k a st ms ->-           runAction h sess (dungeonPerception scops st) k a st ms)---- | Get the current perception.-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 ()-updateAnyActor actor f = modify (updateAnyActorBody actor f)---- | Update player-controlled actor stats.-updatePlayerBody :: (Actor -> Actor) -> Action ()-updatePlayerBody f = do-  pl <- gets splayer-  updateAnyActor pl f---- | Obtains the current date and time.-currentDate :: Action ClockTime-currentDate = liftIO getClockTime- -- | Save the diary and a backup of the save game file, in case of crashes. -- -- See 'Save.saveGameBkp'.-saveGameBkp :: State -> Diary -> Action ()-saveGameBkp state diary = liftIO $ Save.saveGameBkp state diary+saveGameBkp :: Action ()+saveGameBkp = do+  state <- get+  diary <- getDiary+  liftIO $ Save.saveGameBkp state diary  -- | Dumps the current configuration to a file. -- -- See 'Config.dump'. dumpCfg :: FilePath -> Config.CP -> Action ()-dumpCfg fn config = liftIO $ Config.dump fn config+dumpCfg fn config = liftIO $ ConfigIO.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.+-- Aborts if display of the scores was 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 :: Bool -> 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+    curDate <- liftIO getClockTime+    let score = register config write total time curDate status+    (placeMsg, slideshow) <- liftIO 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+-- | Continue or restart or exit the game.+endOrLoop :: Action () -> Action ()+endOrLoop handleTurn = do+  squit <- gets squit   Kind.COps{coitem} <- getCOps   s <- get-  diary <- getDiary   let (_, total) = calculateTotal coitem s-  case status of-    H.Camping -> do-      -- Save an display in parallel.+  -- The first, boolean component of squit determines+  -- if ending screens should be shown, the other argument describes+  -- the cause of the disruption of game flow.+  case squit of+    Nothing -> handleTurn  -- just continue+    Just (_, status@Camping) -> do+      -- Save and 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+      -- Do nothing, that is, quit the game loop.+    Just (showScreens, status@Killed{}) -> 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?"+        void $ displayMore ColorBW "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+      tryWith+        (\ finalMsg ->+          let highScoreMsg = "Let's hope another party can save the day!"+              msg = if null finalMsg then highScoreMsg else finalMsg+          in void $ displayMore ColorBW msg+          -- Do nothing, that is, quit the game loop.+        )+        (do+           when showScreens $ handleScores True status total+           go <- displayMore ColorBW "Next time will be different."+           when (not go) $ abortWith "You could really win this time."+           restartGame handleTurn+        )+    Just (showScreens, status@Victor) -> do       Diary{sreport} <- getDiary       unless (nullReport sreport) $ do         -- 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+      when showScreens $ do+        tryIgnore $ 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+      restartGame handleTurn+    Just (_, Restart) -> do+      void $ displayMore ColorBW "This time for real."+      restartGame handleTurn++restartGame :: Action () -> Action ()+restartGame handleTurn = do+  -- Take the original config from config file, to reroll RNG, if needed+  -- (the current config file has the RNG rolled for the previous game).+  config <- getOrigConfig+  cops <- getCOps+  state <- gameResetAction config cops+  modify $ const state+  saveGameBkp+  handleTurn++-- TODO: do this inside Action ()+gameReset :: Config.CP -> Kind.COps -> IO State+gameReset config1 cops@Kind.COps{ coitem+                                , cofact=Kind.Ops{opick}} = do+  (g2, config2) <- ConfigIO.getSetGen config1 "dungeonRandomGenerator"+  let (DungeonState.FreshDungeon{..}, ag) =+        runState (DungeonState.generate cops config2) g2+      (sflavour, ag2) = runState (dungeonFlavourMap coitem) ag+      factionName = Config.getOption config2 "heroes" "faction"+      sfaction =+        evalState+          (opick (fromMaybe "playable" factionName) (const True)) ag2+  (g3, config3) <- ConfigIO.getSetGen config2 "startingRandomGenerator"+  let state =+        defaultState+          config3 sfaction sflavour freshDungeon entryLevel entryLoc g3+      hstate = initialHeroes cops entryLoc state+  return hstate+gameResetAction :: Config.CP -> Kind.COps -> Action State+gameResetAction config cops = liftIO $ gameReset config cops++-- | Wire together content, the definitions of game commands,+-- config and a high-level startup function+-- to form the starting game session. Evaluate to check for errors,+-- in particular verify content consistency.+-- Then create the starting game config from the default config file+-- and initialize the engine with the starting session.+startFrontend :: Kind.COps -> (Config.CP -> Binding (ActionFrame ()))+              -> Action () -> IO ()+startFrontend !scops@Kind.COps{corule} stdBinding handleTurn = do+  let configDefault = rconfigDefault $ Kind.stdRuleset corule+  sconfig <- ConfigIO.mkConfig configDefault+  let !sbinding = stdBinding sconfig+      !sorigConfig = sconfig+      -- The only option taken not from config in savegame,+      -- but from current config file, possibly from user directory.+      configFont = fromMaybe "" $ Config.getOption sconfig "ui" "font"+      -- In addition to handling the turn, if the game ends or exits,+      -- handle the diary and backup savefile.+      handleGame = do+        handleTurn+        diary <- getDiary+        -- Save diary often, at each game exit, in case of crashes.+        liftIO $ Save.rmBkpSaveDiary sconfig diary+      loop sfs = start sconfig Session{..} handleGame+  startup configFont loop++-- | Compute and insert auxiliary optimized components into game content,+-- to be used in time-critical sections of the code.+speedupCops :: Session -> Session+speedupCops sess@Session{scops = cops@Kind.COps{cotile=tile}} =+  let ospeedup = Tile.speedup tile+      cotile = tile {Kind.ospeedup}+      scops = cops {Kind.cotile}+  in sess {scops}++-- | Either restore a saved game, or setup a new game.+-- Then call the main game loop.+start :: Config.CP -> Session -> Action () -> IO ()+start config slowSess handleGame = do+  let sess@Session{scops = cops@Kind.COps{ corule }} = speedupCops slowSess+      title = rtitle $ Kind.stdRuleset corule+      pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule+  restored <- Save.restoreGame pathsDataFile config title+  case restored of+    Right (diary, msg) -> do  -- Starting a new game.+      state <- gameReset config cops+      handlerToIO sess state+        diary{sreport = singletonReport msg}+        -- TODO: gameReset >> handleTurn or defaultState {squit=Reset}+        handleGame+    Left (state, diary, msg) ->  -- Running a restored a game.+      handlerToIO sess state+        -- This overwrites the "Really save/quit?" messages.+        diary{sreport = singletonReport msg}+        handleGame  -- | Debugging. debug :: String -> Action ()
+ Game/LambdaHack/Action/ActionLift.hs view
@@ -0,0 +1,214 @@+-- | Game action monad and basic building blocks for player and monster+-- actions. Exports 'liftIO' for injecting 'IO' into the 'Action' monad,+-- but does not export the implementation of the Action monad.+-- The 'liftIO' and 'handlerToIO' operations are used only in Action.hs.+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+module Game.LambdaHack.Action.ActionLift+  ( -- * Actions and basic operations+    ActionFun, Action, liftIO, handlerToIO, withPerception, getPerception+    -- * Actions returning frames+  , ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame+    -- * Game session and assessors to its components+  , Session(..), getFrontendSession, getCOps, getBinding, getOrigConfig+    -- * Various ways to abort action+  , abort, abortWith, abortIfWith, neverMind+    -- * Abort exception handlers+  , tryWith, tryRepeatedlyWith, tryIgnore+    -- * Diary and report+  , getDiary, msgAdd, historyReset, msgReset+  ) where++import Control.Monad.State hiding (State, state, liftIO)+import qualified Data.List as L+import Data.Maybe++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Perception+import Game.LambdaHack.Action.Frontend+import Game.LambdaHack.Msg+import Game.LambdaHack.State+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Binding+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.Animation (SingleFrame(..))++-- | 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+   -> DungeonPerception              -- ^ cached perception+   -> (State -> Diary -> a -> IO r)  -- ^ continuation+   -> (Msg -> IO r)                  -- ^ failure/reset continuation+   -> State                          -- ^ current state+   -> Diary                          -- ^ current diary+   -> IO r++-- | Actions of player-controlled characters and of any other actors.+newtype Action a = Action+  { runAction :: forall r . ActionFun r a+  }++instance Show (Action a) where+  show _ = "an action"++-- TODO: check if it's strict enough, if we don't keep old states for too long,+-- Perhaps make state type fields strict for that, too?+instance Monad Action where+  return = returnAction+  (>>=)  = bindAction++instance Functor Action where+  fmap f (Action g) = Action (\ s p k a st ms ->+                               let k' st' ms' = k st' ms' . f+                               in g s p k' a st ms)++instance MonadState State Action where+  get     = Action (\ _s _p k _a  st ms -> k st  ms st)+  put nst = Action (\ _s _p k _a _st ms -> k nst ms ())++-- | Invokes the action continuation on the provided argument.+returnAction :: a -> Action a+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 p k a st ms ->+                          let next nst nm x =+                                runAction (f x) s p k a nst nm+                          in runAction m s p next a st ms)++-- Instance commented out, so that outside of Action/ nobody can+-- subvert the Action monad 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{scops} state diary h =+  runAction h+    sess+    (dungeonPerception scops state)  -- create and cache perception+    (\ _ _ x -> return x)    -- final continuation returns result+    (\ msg ->+      ioError $ userError $ "unhandled abort  " ++ msg)  -- e.g., in AI code+    state+    diary++-- | Update the cached perception for the given computation.+withPerception :: Action () -> Action ()+withPerception h =+  Action (\ sess@Session{scops} _ k a st ms ->+           runAction h sess (dungeonPerception scops st) k a st ms)++-- | Get the current perception.+getPerception :: Action Perception+getPerception = Action (\ _s per k _a s ms ->+                         k s ms (fromJust $ L.lookup (slid s) per))++-- | Actions and screen frames, including delays, resulting+-- from performing the actions.+type ActionFrame a = Action (a, [Maybe SingleFrame])++-- | Return the value with an empty set of screen frames.+returnNoFrame :: a -> ActionFrame a+returnNoFrame a = return (a, [])++-- | Return the trivial value with a single frame to show.+returnFrame :: SingleFrame -> ActionFrame ()+returnFrame fr = return ((), [Just fr])++-- | As the @when@ monad operation, but on type @ActionFrame ()@.+whenFrame :: Bool -> ActionFrame () -> ActionFrame ()+whenFrame True x  = x+whenFrame False _ = returnNoFrame ()++-- | Inject action into actions with screen frames.+inFrame :: Action () -> ActionFrame ()+inFrame act = act >> returnNoFrame ()++-- | The information that is constant across a playing session,+-- including many consecutive games in a single session,+-- but is completely disregarded and reset when a new playing session starts.+data Session = Session+  { sfs   :: FrontendSession           -- ^ frontend session information+  , scops :: Kind.COps                 -- ^ game content+  , sbinding    :: Binding (ActionFrame ())+                                       -- ^ binding of keys to commands+  , sorigConfig :: Config.CP           -- ^ config from the config file+  }++-- | Get the frontend session.+getFrontendSession :: Action FrontendSession+getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs)++-- | Get the content operations.+getCOps :: Action Kind.COps+getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops)++-- | Get the key binding.+getBinding :: Action (Binding (ActionFrame ()))+getBinding = Action (\ Session{sbinding} _p k _a st ms -> k st ms sbinding)++-- | Get the config from the config file.+getOrigConfig :: Action (Config.CP)+getOrigConfig =+  Action (\ Session{sorigConfig} _p k _a st ms -> k st ms sorigConfig)++-- | Reset the state and resume from the last backup point, i.e., invoke+-- the failure continuation.+abort :: Action 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 :: (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)++-- | Take a handler and a computation. If the computation fails, the+-- handler is invoked and then the computation is retried.+tryRepeatedlyWith :: (Msg -> Action ()) -> Action () -> Action ()+tryRepeatedlyWith exc h =+  tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h++-- | Try the given computation and silently catch failure.+tryIgnore :: Action () -> Action ()+tryIgnore =+  tryWith (\ msg -> if null msg+                    then return ()+                    else assert `failure` (msg, "in tryIgnore"))++-- | Get the current diary.+getDiary :: Action Diary+getDiary = Action (\ _s _p k _a st diary -> k st diary diary)++-- | 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} ())++-- | 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{..} ())++-- | 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} ())
+ Game/LambdaHack/Action/ConfigIO.hs view
@@ -0,0 +1,99 @@+-- | Personal game configuration file support.+module Game.LambdaHack.Action.ConfigIO+  (  mkConfig, appDataDir, getFile, dump, getSetGen+  ) where++import System.Directory+import System.FilePath+import System.Environment+import qualified Data.ConfigFile as CF+import qualified Data.Char as Char+import qualified Data.List as L+import qualified System.Random as R++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Config++overrideCP :: CP -> FilePath -> IO CP+overrideCP (CP defCF) cfile = do+  c <- CF.readfile defCF cfile+  return $ toCP $ forceEither c++-- | Read the player configuration file and use it to override+-- any default config options. Currently we can't unset options, only override.+--+-- The default config, passed in argument @configDefault@,+-- is expected to come from the default configuration file included via CPP+-- in file @ConfigDefault.hs@.+mkConfig :: String -> IO CP+mkConfig configDefault = do+  let delFileMarker = L.init $ L.drop 3 $ lines configDefault+      delComment = L.map (L.drop 2) delFileMarker+      unConfig = unlines delComment+      -- Evaluate, to catch config errors ASAP.+      !defCF = forceEither $ CF.readstring CF.emptyCP unConfig+      !defConfig = toCP defCF+  cfile <- configFile+  b <- doesFileExist cfile+  if not b+    then return defConfig+    else overrideCP defConfig cfile++-- | Personal data directory for the game. Depends on the OS and the game,+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.+appDataDir :: IO FilePath+appDataDir = do+  progName <- getProgName+  let name = L.takeWhile Char.isAlphaNum progName+  getAppUserDataDirectory name++-- | Path to the user configuration file in the personal data directory.+configFile :: IO FilePath+configFile = do+  appData <- appDataDir+  return $ combine appData "config"++-- | Looks up a file path in the config file and makes it absolute.+-- If the game's configuration directory exists,+-- the file path is appended to it; otherwise, it's appended+-- to the current directory.+getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath+getFile conf s o = do+  current <- getCurrentDirectory+  appData <- appDataDir+  let path    = get conf s o+      appPath = combine appData path+      curPath = combine current path+  b <- doesDirectoryExist appData+  return $ if b then appPath else curPath++-- | Dumps the current configuration to a file.+dump :: FilePath -> CP -> IO ()+dump fn (CP conf) = do+  current <- getCurrentDirectory+  let path  = combine current fn+      sdump = CF.to_string conf+  writeFile path sdump++-- | Simplified setting of an option in a given section. Overwriting forbidden.+set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP+set (CP conf) s o v =+  if CF.has_option conf s o+  then assert `failure`"Overwritten config option: " ++ s ++ "." ++ o+  else CP $ forceEither $ CF.set conf s o v++-- | Gets a random generator from the config or,+-- if not present, generates one and updates the config with it.+getSetGen :: CP      -- ^ config+          -> String  -- ^ name of the generator+          -> IO (R.StdGen, CP)+getSetGen config option =+  case getOption config "engine" option of+    Just sg -> return (read sg, config)+    Nothing -> do+      -- Pick the randomly chosen generator from the IO monad+      -- and record it in the config for debugging (can be 'D'umped).+      g <- R.newStdGen+      let gs = show g+          c = set config "engine" option gs+      return (g, c)
+ Game/LambdaHack/Action/Frontend.hs view
@@ -0,0 +1,33 @@+-- | Display game data on the screen and receive user input+-- using one of the available raw frontends and derived  operations.+module Game.LambdaHack.Action.Frontend+  ( -- * Re-exported part of the raw frontend+    FrontendSession, startup, frontendName, nextEvent+    -- * Derived operations+  , displayFrame, promptGetKey+  ) where++import Game.LambdaHack.Action.Frontend.Chosen+import qualified Game.LambdaHack.Key as K (Key, Modifier)+import Game.LambdaHack.Animation (SingleFrame(..))++-- | Push a frame or a single frame's worth of delay to the frame queue.+displayFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()+displayFrame fs isRunning = display fs True isRunning++-- TODO: move promptGetKey here and then change its type to+-- promptGetKey :: FrontendSession+--              -> [((K.Key, K.Modifier), a)]+--              -> ((K.Key, K.Modifier) -> a)  -- ^ handle unexpected key+--              -> SingleFrame+--              -> IO a+-- Then see if it can be used instead of the dangerous, low level nextEvent.+-- | 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)] -> SingleFrame+             -> IO (K.Key, K.Modifier)+promptGetKey sess keys frame = do+  km <- promptGetAnyKey sess frame+  if null keys || km `elem` keys+    then return km+    else promptGetKey sess keys frame
+ Game/LambdaHack/Action/Frontend/Chosen.hs view
@@ -0,0 +1,19 @@+-- | Re-export the operations of the chosen raw frontend+-- (determined at compile time with cabal flags).+{-# LANGUAGE CPP #-}+module Game.LambdaHack.Action.Frontend.Chosen+  ( -- * Re-exported raw frontend+    FrontendSession, startup, frontendName, nextEvent, promptGetAnyKey, display+  ) where++-- Wrapper for selected Display frontend.++#ifdef CURSES+import Game.LambdaHack.Action.Frontend.Curses as D+#elif VTY+import Game.LambdaHack.Action.Frontend.Vty as D+#elif STD+import Game.LambdaHack.Action.Frontend.Std as D+#else+import Game.LambdaHack.Action.Frontend.Gtk as D+#endif
+ Game/LambdaHack/Action/Frontend/Curses.hs view
@@ -0,0 +1,157 @@+-- | Text frontend based on HSCurses.+module Game.LambdaHack.Action.Frontend.Curses+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent, promptGetAnyKey+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import qualified UI.HSCurses.Curses as C+import qualified UI.HSCurses.CursesHelper as C+import qualified Data.List as L+import qualified Data.Map as M+import Control.Monad+import Data.Char (ord, chr)++import Game.LambdaHack.Utils.Assert+import qualified Game.LambdaHack.Key as K (Key(..),  Modifier(..))+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (SingleFrame(..))++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { swin    :: C.Window  -- ^ the window to draw to+  , sstyles :: M.Map Color.Attr C.CursesStyle+      -- ^ map from fore/back colour pairs to defined curses styles+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "curses"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = do+  C.start+--  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.+            bg <- Color.legalBG ]+  nr <- C.colorPairs+  when (nr < L.length s) $+    C.end >>+    (assert `failure`+       "Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")+  let (ks, vs) = unzip s+  ws <- C.convertStyles vs+  let styleMap = M.fromList (zip ks ws)+  k (FrontendSession C.stdScr styleMap)+  C.end++-- | Output to the screen via the frontend.+display :: FrontendSession          -- ^ frontend session data+        -> Bool+        -> Bool+        -> Maybe SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display _ _ _ Nothing = return ()+display FrontendSession{..}  _ _ (Just 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 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.+  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 -> Maybe Bool -> IO (K.Key, K.Modifier)+nextEvent _sess _ = keyTranslate `fmap` C.getKey C.refresh++-- | Display a prompt, wait for any key.+promptGetAnyKey :: FrontendSession -> SingleFrame+             -> IO (K.Key, K.Modifier)+promptGetAnyKey sess frame = do+  display sess True True $ Just frame+  nextEvent sess Nothing++keyTranslate :: C.Key -> (K.Key, K.Modifier)+keyTranslate e =+  case e of+    C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)+    C.KeyExit        -> (K.Esc,     K.NoModifier)+    C.KeyChar '\n'   -> (K.Return,  K.NoModifier)+    C.KeyChar '\r'   -> (K.Return,  K.NoModifier)+    C.KeyEnter       -> (K.Return,  K.NoModifier)+    C.KeyChar ' '    -> (K.Space,   K.NoModifier)+    C.KeyChar '\t'   -> (K.Tab,     K.NoModifier)+    C.KeyBTab        -> (K.BackTab, K.NoModifier)+    C.KeyUp          -> (K.Up,      K.NoModifier)+    C.KeyDown        -> (K.Down,    K.NoModifier)+    C.KeyLeft        -> (K.Left,    K.NoModifier)+    C.KeySLeft       -> (K.Left,    K.NoModifier)+    C.KeyRight       -> (K.Right,   K.NoModifier)+    C.KeySRight      -> (K.Right,   K.NoModifier)+    C.KeyHome        -> (K.Home,    K.NoModifier)+    C.KeyPPage       -> (K.PgUp,    K.NoModifier)+    C.KeyEnd         -> (K.End,     K.NoModifier)+    C.KeyNPage       -> (K.PgDn,    K.NoModifier)+    C.KeyBeg         -> (K.Begin,   K.NoModifier)+    C.KeyB2          -> (K.Begin,   K.NoModifier)+    C.KeyClear       -> (K.Begin,   K.NoModifier)+    -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10+    -- TODO: try to get the Control modifier for keypad keys from the escape+    -- gibberish and use Control-keypad for KP_ movement.+    C.KeyChar c+      -- This case needs to be considered after Tab, since, apparently,+      -- on some terminals ^i == Tab and Tab is more important for us.+      | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than hero selection,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)+    _                       -> (K.Unknown (show e),  K.NoModifier)++toFColor :: Color.Color -> C.ForegroundColor+toFColor Color.Black     = C.BlackF+toFColor Color.Red       = C.DarkRedF+toFColor Color.Green     = C.DarkGreenF+toFColor Color.Brown     = C.BrownF+toFColor Color.Blue      = C.DarkBlueF+toFColor Color.Magenta   = C.PurpleF+toFColor Color.Cyan      = C.DarkCyanF+toFColor Color.White     = C.WhiteF+toFColor Color.BrBlack   = C.GreyF+toFColor Color.BrRed     = C.RedF+toFColor Color.BrGreen   = C.GreenF+toFColor Color.BrYellow  = C.YellowF+toFColor Color.BrBlue    = C.BlueF+toFColor Color.BrMagenta = C.MagentaF+toFColor Color.BrCyan    = C.CyanF+toFColor Color.BrWhite   = C.BrightWhiteF++toBColor :: Color.Color -> C.BackgroundColor+toBColor Color.Black     = C.BlackB+toBColor Color.Red       = C.DarkRedB+toBColor Color.Green     = C.DarkGreenB+toBColor Color.Brown     = C.BrownB+toBColor Color.Blue      = C.DarkBlueB+toBColor Color.Magenta   = C.PurpleB+toBColor Color.Cyan      = C.DarkCyanB+toBColor Color.White     = C.WhiteB+toBColor _               = C.BlackB  -- a limitation of curses
+ Game/LambdaHack/Action/Frontend/Gtk.hs view
@@ -0,0 +1,460 @@+-- | Text frontend based on Gtk.+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Game.LambdaHack.Action.Frontend.Gtk+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent, promptGetAnyKey+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Control.Monad+import Control.Monad.Reader+import Control.Concurrent+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.Utils.Assert+import Game.LambdaHack.Utils.LQueue+import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate, Modifier(..))+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (SingleFrame(..))++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 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"++-- | 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+  mv <- newEmptyMVar+  -- Fork the gtk input and output thread.+  -- TODO: when GHC changes, make sure GTK is still faster on its own 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+  -- Text attributes.+  ttt <- textTagTableNew+  stags <- fmap M.fromList $+             mapM (\ ak -> do+                      tt <- textTagNew Nothing+                      textTagTableAdd ttt tt+                      doAttr tt ak+                      return (ak, tt))+               [ Color.Attr{fg, bg}+               | fg <- [minBound..maxBound], bg <- Color.legalBG ]+  -- Text buffer.+  tb <- textBufferNew (Just ttt)+  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?+  sview <- textViewNewWithBuffer tb+  textViewSetEditable sview False+  textViewSetCursorVisible sview False+  -- 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. When logic ends, game exits.+  -- TODO: is postGUIAsync needed here?+  forkIO $ k sess >> postGUIAsync mainQuit+  -- 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+  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 main window.+  w <- windowNew+  containerAdd w sview+  onDestroy w mainQuit+  widgetShowAll w+  -- Wait until the other thread draws something and show the window.+  yield+  mainGUI++-- | Output to the screen via the frontend.+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 -> TextTag -> Int -> (Int, [TextTag]) -> IO ()+setTo _  _   _  (_,  [])         = return ()+setTo tb defaultAttr lx (ly, attr:attrs) = do+  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx+  ie <- textIterCopy ib+  let setIter :: TextTag -> Int -> [TextTag] -> IO ()+      setIter previous repetitions [] = do+        textIterForwardChars ie repetitions+        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 /= defaultAttr) $+              textBufferApplyTag tb previous ib ie+            textIterForwardChars ib repetitions+            setIter a 1 as+  setIter attr 1 attrs++-- 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++-- | 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 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 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 -> SingleFrame -> GtkFrame+evalFrame FrontendSession{stags} 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 -> 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 key.+-- 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.+promptGetAnyKey :: FrontendSession -> SingleFrame+                -> IO (K.Key, K.Modifier)+promptGetAnyKey sess@FrontendSession{sframeState} 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+  nextEvent sess (Just doPush)++-- | 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}+  | attr == Color.defaultAttr = return ()+  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]+  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]+  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,+                                textTagBackground := Color.colorToRGB bg]
+ Game/LambdaHack/Action/Frontend/Std.hs view
@@ -0,0 +1,106 @@+-- | Text frontend based on stdin/stdout, intended for bots.+module Game.LambdaHack.Action.Frontend.Std+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent, promptGetAnyKey+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import qualified Data.List as L+import qualified Data.ByteString.Char8 as BS+import qualified System.IO as SIO++import qualified Game.LambdaHack.Key as K (Key(..),  Modifier(..))+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (SingleFrame(..))++-- | No session data needs to be maintained by this frontend.+type FrontendSession = ()++-- | The name of the frontend.+frontendName :: String+frontendName = "std"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = k ()++-- | Output to the screen via the frontend.+display :: FrontendSession          -- ^ frontend session data+        -> Bool+        -> Bool+        -> Maybe SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display _ _ _ Nothing = return ()+display _ _ _ (Just 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 -> 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 mb+    else return (keyTranslate c, K.NoModifier)++-- | Display a prompt, wait for any key.+promptGetAnyKey :: FrontendSession -> SingleFrame+             -> IO (K.Key, K.Modifier)+promptGetAnyKey sess frame = do+  display sess True True $ Just frame+  nextEvent sess Nothing++-- HACK: Special translation that block commands the bots should not use+-- and multiplies some other commands.+keyTranslate :: Char -> K.Key+keyTranslate e =+  case e of+    -- Translate some special keys (use vi keys to move).+    '\ESC' -> K.Esc+    '\n'   -> K.Return+    '\r'   -> K.Return+    '\t'   -> K.Tab+    --  For bots: disable purely UI commands.+    'P'    -> K.Char 'U'+    'V'    -> K.Char 'Y'+    'O'    -> K.Char 'J'+    'I'    -> K.Char 'L'+    'R'    -> K.Char 'K'+    '?'    -> K.Char 'N'+    -- For bots: don't let them give up, write files, procrastinate.+    'Q'    -> K.Char 'H'+    'X'    -> K.Char 'B'+    'D'    -> K.Return+    '.'    -> K.Return+    -- For bots (assuming they go from '0' to 'z'): major commands.+    '<'    -> K.Char 'q'  -- ban ascending to speed up descending+    '>'    -> K.Char '>'+    'c'    -> K.Char 'c'+    'd'    -> K.Char 'r'  -- don't let bots drop stuff+    'g'    -> K.Char 'g'+    'i'    -> K.Char 'i'+    'o'    -> K.Char 'o'+    'q'    -> K.Char 'q'+    'r'    -> K.Char 'r'+    't'    -> K.Char 'g'  -- tagetting is too hard, so don't throw+    'z'    -> K.Char 'g'  -- and don't zap+    'p'    -> K.Char 'g'  -- and don't project+    'a'    -> K.Esc       -- and don't apply+    -- For bots: minor commands. Targeting is too hard, so don't do it.+    '*'    -> K.Char 'c'+    '/'    -> K.Char 'c'+    '['    -> K.Char 'g'+    ']'    -> K.Char 'g'+    '{'    -> K.Char 'g'+    '}'    -> K.Char 'g'+    -- Hack for bots: dump config at the start.+    ' '    -> K.Char 'D'+    -- Movement and hero selection.+    c | c `elem` "kjhlyubnKJHLYUBN" -> K.Char c+    c | c `elem` ['0'..'9'] -> K.Char c+    _      -> K.Char '>'  -- try hard to descend
+ Game/LambdaHack/Action/Frontend/Vty.hs view
@@ -0,0 +1,128 @@+-- | Text frontend based on Vty.+module Game.LambdaHack.Action.Frontend.Vty+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent, promptGetAnyKey+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Graphics.Vty+import qualified Graphics.Vty as Vty+import qualified Data.List as L+import qualified Data.ByteString.Char8 as BS++import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..))+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (SingleFrame(..))++-- | Session data maintained by the frontend.+type FrontendSession = Vty++-- | The name of the frontend.+frontendName :: String+frontendName = "vty"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = do+  fs <- mkVty+  k fs+  Vty.shutdown fs++-- | Output to the screen via the frontend.+display :: FrontendSession          -- ^ frontend session data+        -> Bool+        -> Bool+        -> Maybe SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display _ _ _ Nothing = return ()+display vty _ _ (Just 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 sfTop)+              <-> img <->+              utf8_bytestring (setAttr Color.defaultAttr) (BS.pack sfBottom)+  in update vty pic++-- | Input key via the frontend.+nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)+nextEvent sess mb = do+  e <- next_event sess+  case e of+    EvKey n mods -> do+      let key = keyTranslate n+          modifier = modifierTranslate mods+      return (key, modifier)+    _ -> nextEvent sess mb++-- | Display a prompt, wait for any key.+promptGetAnyKey :: FrontendSession -> SingleFrame+             -> IO (K.Key, K.Modifier)+promptGetAnyKey sess frame = do+  display sess True True $ Just frame+  nextEvent sess Nothing++keyTranslate :: Key -> K.Key+keyTranslate n =+  case n of+    KEsc          -> K.Esc+    KEnter        -> K.Return+    (KASCII ' ')  -> K.Space+    (KASCII '\t') -> K.Tab+    KBackTab      -> K.BackTab+    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.+-- HSCurses does this by default, but in Vty you have to request the hack.+hack :: Color.Color -> Attr -> Attr+hack c a = if Color.isBright c then with_style a bold else a++setAttr :: Color.Attr -> Attr+setAttr Color.Attr{fg, bg} =+-- This optimization breaks display for white background terminals:+--  if (fg, bg) == Color.defaultAttr+--  then def_attr+--  else+  hack fg $ hack bg $+    def_attr { attr_fore_color = SetTo (aToc fg)+             , attr_back_color = SetTo (aToc bg) }++aToc :: Color.Color -> Color+aToc Color.Black     = black+aToc Color.Red       = red+aToc Color.Green     = green+aToc Color.Brown     = yellow+aToc Color.Blue      = blue+aToc Color.Magenta   = magenta+aToc Color.Cyan      = cyan+aToc Color.White     = white+aToc Color.BrBlack   = bright_black+aToc Color.BrRed     = bright_red+aToc Color.BrGreen   = bright_green+aToc Color.BrYellow  = bright_yellow+aToc Color.BrBlue    = bright_blue+aToc Color.BrMagenta = bright_magenta+aToc Color.BrCyan    = bright_cyan+aToc Color.BrWhite   = bright_white
+ Game/LambdaHack/Action/HighScore.hs view
@@ -0,0 +1,151 @@+-- | High score table operations.+module Game.LambdaHack.Action.HighScore+  ( register+  ) where++import System.Directory+import Control.Monad+import Text.Printf+import System.Time+import Data.Binary+import qualified Data.List as L++import Game.LambdaHack.Utils.File+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Action.ConfigIO as ConfigIO+import Game.LambdaHack.Dungeon+import Game.LambdaHack.Misc+import Game.LambdaHack.Time+import Game.LambdaHack.Msg+import Game.LambdaHack.State++-- | A single score record. Records are ordered in the highscore table,+-- from the best to the worst, in lexicographic ordering wrt the fields below.+data ScoreRecord = ScoreRecord+  { points  :: !Int        -- ^ the score+  , negTime :: !Time       -- ^ game time spent (negated, so less better)+  , date    :: !ClockTime  -- ^ date of the last game interruption+  , status  :: !Status     -- ^ reason of the game interruption+  }+  deriving (Eq, Ord)++instance Binary ScoreRecord where+  put (ScoreRecord p n (TOD cs cp) s) = do+    put p+    put n+    put cs+    put cp+    put s+  get = do+    p <- get+    n <- get+    cs <- get+    cp <- get+    s <- get+    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 (pos, score) =+  let died = case status score of+        Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ ","+        Camping -> "is camping somewhere,"+        Victor -> "emerged victorious"+        Restart -> "resigned prematurely"+      curDate = calendarTimeToString . toUTCTime . date $ score+      big   = "                                                 "+      lil   = "              "+      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]++-- | Empty score table+empty :: ScoreTable+empty = []++-- | Name of the high scores file.+scoresFile :: Config.CP -> IO String+scoresFile config = ConfigIO.getFile config "files" "scoresFile"++-- | Save a simple serialized version of the high scores table.+save :: Config.CP -> ScoreTable -> IO ()+save config scores = do+  f <- scoresFile config+  encodeEOF f scores++-- | Read the high scores table. Return the empty table if no file.+restore :: Config.CP -> IO ScoreTable+restore config = do+  f <- scoresFile config+  b <- doesFileExist f+  if not b+    then return empty+    else strictDecodeEOF f++-- | Insert a new score into the table, Return new table and the ranking.+insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)+insertPos s h =+  let (prefix, suffix) = L.span (> s) h+  in (prefix ++ [s] ++ suffix, L.length prefix + 1)++-- | Show a screenful of the high scores table.+-- Parameter height is the number of (3-line) scores to be shown.+showTable :: ScoreTable -> Int -> Int -> Overlay+showTable h start height =+  let zipped    = zip [1..] h+      screenful = take height . drop (start - 1) $ zipped+  in concatMap showScore screenful++-- | Produce a couple of renderings of the high scores table.+slideshow :: Int -> ScoreTable -> Int -> [Overlay]+slideshow pos h height =+  if pos <= height+  then [showTable h 1 height]+  else [showTable h 1 height,+        showTable h (max (height + 1) (pos - height `div` 2)) height]++-- | Take care of saving a new score to the table+-- and return a list of messages to display.+register :: Config.CP  -- ^ the config file+         -> Bool       -- ^ whether to write or only render+         -> Int        -- ^ the total score. not halved yet+         -> Time       -- ^ game time spent+         -> ClockTime  -- ^ date of the last game interruption+         -> Status     -- ^ reason of the game interruption+         -> IO (String, [Overlay])+register config write total time date status = do+  h <- restore config+  let points = case status of+                 Killed _ -> (total + 1) `div` 2+                 _        -> total+      negTime = timeNegate time+      score = ScoreRecord{..}+      (h', pos) = insertPos score h+      (_, nlines) = normalLevelBound  -- TODO: query terminal size instead+      height = nlines `div` 3+      (msgCurrent, msgUnless) =+        case status of+          Killed _ -> ("short-lived", " (score halved)")+          Camping  -> ("current", " (unless you are slain)")+          Victor   -> ("glorious",+                        if pos <= height+                        then " among the greatest heroes"+                        else "")+          Restart  -> ("abortive", " (score halved)")+      msg = printf "Your %s exploits award you place >> %d <<%s."+              msgCurrent pos msgUnless+  when write $ save config h'+  return (msg, slideshow pos h' height)
+ Game/LambdaHack/Action/Save.hs view
@@ -0,0 +1,164 @@+-- | Saving and restoring games and player diaries.+module Game.LambdaHack.Action.Save+  ( saveGameFile, restoreGame, rmBkpSaveDiary, saveGameBkp+  ) where++import System.Directory+import System.FilePath+import qualified Control.Exception as Ex hiding (handle)+import Control.Monad+import Control.Concurrent+import System.IO.Unsafe (unsafePerformIO)  -- horrors++import Game.LambdaHack.Utils.File+import Game.LambdaHack.State+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Action.ConfigIO as ConfigIO+import Game.LambdaHack.Msg++-- | Name of the save game.+saveFile :: Config.CP -> IO FilePath+saveFile config = ConfigIO.getFile config "files" "saveFile"++-- | Name of the backup of the save game.+bkpFile :: Config.CP -> IO FilePath+bkpFile config = do+  sfile <- saveFile config+  return $ sfile ++ ".bkp"++-- | Name of the persistent player diary.+diaryFile :: Config.CP -> IO FilePath+diaryFile config = ConfigIO.getFile config "files" "diaryFile"++-- | Save a simple serialized version of the current player diary.+saveDiary :: Config.CP -> Diary -> IO ()+saveDiary config diary = do+  dfile <- diaryFile config+  encodeEOF dfile diary++saveLock :: MVar ()+{-# NOINLINE saveLock #-}+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+  takeMVar saveLock++-- | Try to create a directory. Hide errors due to,+-- e.g., insufficient permissions, because the game can run+-- in the current directory just as well.+tryCreateDir :: FilePath -> IO ()+tryCreateDir dir =+  Ex.catch+    (createDirectory dir)+    (\ e -> case e :: Ex.IOException of _ -> return ())++-- TODO: perhaps take the target "scores" file name from config.+-- TODO: perhaps source and "config", too, to be able to change all+-- in one place.+-- | Try to copy over data files. Hide errors due to,+-- e.g., insufficient permissions, because the game can run+-- without data files just as well.+tryCopyDataFiles :: (FilePath -> IO FilePath) -> FilePath -> IO ()+tryCopyDataFiles pathsDataFile dirNew = do+  configFile <- pathsDataFile "config.default"+  scoresFile <- pathsDataFile "scores"+  let configNew = combine dirNew "config"+      scoresNew = combine dirNew "scores"+  Ex.catch+    (copyFile configFile configNew >>+     copyFile scoresFile scoresNew)+    (\ e -> case e :: Ex.IOException of _ -> return ())++-- | Restore a saved game, if it exists. Initialize directory structure,+-- if needed.+restoreGame :: (FilePath -> IO FilePath) -> Config.CP -> String+            -> IO (Either (State, Diary, Msg) (Diary, Msg))+restoreGame pathsDataFile config title = do+  appData <- ConfigIO.appDataDir+  ab <- doesDirectoryExist appData+  -- If the directory can't be created, the current directory will be used.+  unless ab $ do+    tryCreateDir appData+    -- 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+       if db+         then strictDecodeEOF dfile+         else defaultDiary+  -- If the savefile exists but we get IO errors, we show them,+  -- back up the savefile and move it out of the way and start a new game.+  -- If the savefile was randomly corrupted or made read-only,+  -- that should solve the problem. If the problems are more serious,+  -- the other functions will most probably also throw exceptions,+  -- this time without trying to fix it up.+  sfile <- saveFile config+  bfile <- bkpFile config+  sb <- doesFileExist sfile+  bb <- doesFileExist bfile+  Ex.catch+    (if sb+       then do+         mvBkp config+         state <- strictDecodeEOF bfile+         let msg = "Welcome back to " ++ title ++ "."+         return $ Left (state, diary, msg)+       else+         if bb+           then do+             state <- strictDecodeEOF bfile+             let msg = "No savefile found. Restoring from a backup savefile."+             return $ Left (state, diary, msg)+           else return $ Right (diary, "Welcome to " ++ title ++ "!"))+    (\ e -> case e :: Ex.SomeException of+              _ -> let msg = "Starting a new game, because restore failed. "+                             ++ "The error message was: "+                             ++ (unwords . lines) (show e)+                   in return $ Right (diary, msg))++-- | Move the savegame file to a backup slot.+mvBkp :: Config.CP -> IO ()+mvBkp config = do+  sfile <- saveFile config+  bfile <- bkpFile config+  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+  b <- tryPutMVar saveLock ()+  let config = sconfig state+  when b $+    void $ forkIO $ do+      saveDiary config diary  -- save the diary often in case of crashes+      sfile <- saveFile config+      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 :: Config.CP -> Diary -> IO ()+rmBkpSaveDiary config diary = do+  putMVar saveLock ()+  saveDiary config diary  -- save the diary often in case of crashes+  bfile <- bkpFile config+  bb <- doesFileExist bfile+  when bb $ removeFile bfile+  takeMVar saveLock
Game/LambdaHack/Actions.hs view
@@ -3,12 +3,18 @@ -- TODO: Add an export list and document after it's rewritten according to #17. module Game.LambdaHack.Actions where +-- Cabal+import qualified Paths_LambdaHack as Self (version)+ import Control.Monad import Control.Monad.State hiding (State, state) import qualified Data.List as L import qualified Data.IntMap as IM+import qualified Data.Map as M import Data.Maybe+import Data.Version import qualified Data.IntSet as IS+import Data.Ratio  import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Action@@ -16,7 +22,6 @@ import Game.LambdaHack.Vector import Game.LambdaHack.Grammar import qualified Game.LambdaHack.Dungeon as Dungeon-import qualified Game.LambdaHack.HighScore as H import Game.LambdaHack.Item import qualified Game.LambdaHack.Key as K import Game.LambdaHack.Level@@ -33,29 +38,36 @@ import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Random+import Game.LambdaHack.Misc import Game.LambdaHack.Msg import Game.LambdaHack.Binding import Game.LambdaHack.Time-import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (swapPlaces, blockMiss) import Game.LambdaHack.Draw+import qualified Game.LambdaHack.Command as Command -saveGame :: Action ()-saveGame = do-  b <- displayYesNo "Really save?"-  if b-    then modify (\ s -> s {squit = Just (True, H.Camping)})-    else abortWith "Game resumed."+gameSave :: Action ()+gameSave = do+  saveGameBkp+  msgAdd "Game progress saved to a backup file." -quitGame :: Action ()-quitGame = do-  b <- displayYesNo "Really quit?"+gameExit :: Action ()+gameExit = do+  b <- displayYesNo "Really save and exit?"   if b-    then let status = H.Killed $ Dungeon.levelDefault 0-         -- No highscore display for quitters.-         in modify (\ s -> s {squit = Just (False, status)})+    then modify (\ s -> s {squit = Just (True, Camping)})     else abortWith "Game resumed." +gameRestart :: Action ()+gameRestart = do+  b1 <- displayMore ColorFull "You just requested a new game."+  when (not b1) $ neverMind True+  b2 <- displayYesNo "Current progress will be lost! Really restart the game?"+  when (not b2) $ abortWith "Yea, so much still to do."+  modify (\ s -> s {squit = Just (False, Restart)})+ moveCursor :: Vector -> Int -> ActionFrame () moveCursor dir n = do   lxsize <- gets (lxsize . slevel)@@ -79,7 +91,7 @@     then do       frs <- moveCursor dir 1       -- Mark that unexpectedly it does not take time.-      modify (\ s -> s {snoTime = True})+      modify (\ s -> s {stakeTime = Just False})       return frs     else       inFrame $ moveOrAttack True pl dir@@ -126,7 +138,7 @@   lvl <- gets slevel   let f (F.Cause effect) = do         pl <- gets splayer-        void $ effectToAction effect 0 pl pl 0+        void $ effectToAction effect 0 pl pl 0 False  -- no block against tile         return ()       f (F.ChangeTo group) = do         Level{lactor} <- gets slevel@@ -244,20 +256,38 @@     modify (updateCursor upd)   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+heroesAfterPl :: Action [ActorId]+heroesAfterPl = do   pl <- gets splayer   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+  return $ catMaybes gt ++ catMaybes lt++-- | Switches current hero to the next hero on the level, if any, wrapping.+-- We cycle through at most 10 heroes (\@, 1--9).+cycleHero :: Action ()+cycleHero = do+  pl <- gets splayer+  s  <- get+  hs <- heroesAfterPl+  case L.filter (flip memActor s) hs of     [] -> abortWith "Cannot select any other hero on this level."     ni : _ -> selectPlayer ni                 >>= assert `trueM` (pl, ni, "hero duplicated") +-- | Switches current hero to the previous hero in the whole dungeon,+-- if any, wrapping. We cycle through at most 10 heroes (\@, 1--9).+backCycleHero :: Action ()+backCycleHero = do+  pl <- gets splayer+  hs <- heroesAfterPl+  case reverse hs of+    [] -> abortWith "No other hero in the party."+    ni : _ -> selectPlayer ni+                >>= assert `trueM` (pl, ni, "hero duplicated")+ -- | Search for hidden doors. search :: Action () search = do@@ -326,7 +356,7 @@             msgAdd $ lookAt cops False True state lvl tloc ""       | allowAttacks && actor == pl         && Tile.canBeHidden cotile (okind $ lvl `rememberAt` tloc) -> do-          msgAdd "You search your surroundings."  -- TODO: proper msg+          msgAdd "You search all adjacent walls for half a second."           search       | otherwise ->           actorOpenDoor actor dir  -- try to open a door, TODO: bumpTile tloc F.Openable@@ -340,28 +370,39 @@ -- and not using up the weapon. actorAttackActor :: ActorId -> ActorId -> Action () actorAttackActor source target = do-  sm <- gets (getActor source)-  tm <- gets (getActor target)-  if bparty sm == heroParty && bparty tm == heroParty+  smRaw <- gets (getActor source)+  tmRaw <- gets (getActor target)+  per   <- getPerception+  time  <- gets stime+  sfaction <- gets sfaction+  let sloc = bloc smRaw+      tloc = bloc tmRaw+      svisible = sloc `IS.member` totalVisible per+      tvisible = tloc `IS.member` totalVisible per+      sm | svisible  = smRaw+         | otherwise = smRaw {bname = Just "somebody"}+      tm | tvisible  = tmRaw+         | otherwise = tmRaw {bname = Just "somebody"}+  if bfaction sm == sfaction && not (bproj sm) &&+     bfaction tm == sfaction && not (bproj tm)     then do       -- Select adjacent hero by bumping into him. Takes no time, so rewind.       selectPlayer target-        >>= assert `trueM` (source, target, "player bumps into himself")+        >>= assert `trueM` (source, target, "heroes attack each other")       -- Mark that unexpectedly it does not take time.-      modify (\ s -> s {snoTime = True})+      modify (\ s -> s {stakeTime = Just False})     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+            if isProjectile state source+            then case bitems of+              [bitem] -> (bitem, False, 10, "hit")       -- projectile+              _ -> assert `failure` bitems             else case strongestSword cops bitems of               Nothing -> (h2hItem, False, 0,                           iverbApply $ okind $ h2hKind)  -- hand-to-hand@@ -376,10 +417,30 @@                   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+          msgMiss = init (actorVerb coactor sm ("try to " ++ verb) "")+                    ++ ", but "+                    ++ let tmSubject = objectActor coactor tm+                       in tmSubject ++ " "+                          ++ conjugate tmSubject "block" ++ "."+      let performHit block = do+            when (svisible || tvisible) $ msgAdd msg+            -- Msgs inside itemEffectAction describe the target part.+            itemEffectAction verbosity source target single block+      -- Projectiles can't be blocked, can be sidestepped.+      if braced tm time && not (bproj sm)+        then do+          blocked <- rndToAction $ chance $ 1%2+          if blocked+            then do+              when (svisible || tvisible) $ msgAdd msgMiss+              diary <- getDiary+              let locs = (breturn tvisible tloc,+                          breturn svisible sloc)+                  anim = blockMiss locs+                  animFrs = animate state diary cops per anim+              mapM_ displayFramePush $ Nothing : animFrs+            else performHit True+        else performHit False  -- | Resolves the result of an actor running (not walking) into another. -- This involves switching positions of the two actors.@@ -400,18 +461,8 @@   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+  let locs = (Just tloc, Just sloc)+      animFrs = animate s diary cops per $ swapPlaces locs   when visible $ mapM_ displayFramePush $ Nothing : animFrs   if source == pl    then stopRunning  -- do not switch positions repeatedly@@ -419,7 +470,10 @@  -- | 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+rollMonster Kind.COps{ cotile+                     , coactor=Kind.Ops{opick, okind}+                     , cofact=Kind.Ops{opick=fopick, oname=foname}+                     } per state = do   let lvl@Level{lactor} = slevel state       ms = hostileList state       hs = heroList state@@ -433,18 +487,18 @@       loc <-         findLocTry 20 (lmap lvl)  -- 20 only, for unpredictability           [ \ _ t -> not (isLit t)-          , distantAtLeast 30-          , distantAtLeast 20-          , \ l t -> not (isLit t) || distantAtLeast 20 l t+          , distantAtLeast 15+          , \ l t -> not (isLit t) || distantAtLeast 15 l t           , distantAtLeast 10           , \ l _ -> not $ l `IS.member` totalVisible per           , distantAtLeast 5           , \ l t -> Tile.hasFeature cotile F.Walkable t                      && unoccupied (IM.elems lactor) l           ]-      mk <- opick "monster" (const True)+      bfaction <- fopick "spawn" (const True)+      mk <- opick (foname bfaction) (const True)       hp <- rollDice $ ahp $ okind mk-      return $ addMonster cotile mk hp loc state+      return $ addMonster cotile mk hp loc bfaction False state  -- | Generate a monster, possibly. generateMonster :: Action ()@@ -486,17 +540,63 @@ displayHelp :: ActionFrame () displayHelp = do   keyb <- getBinding-  displayOverlays "Basic keys. [press SPACE or ESC]" $ keyHelp keyb+  displayOverlays "Basic keys." "[press SPACE to advance]" $ keyHelp keyb +-- | Display the main menu.+displayMainMenu :: ActionFrame ()+displayMainMenu = do+  Kind.COps{corule} <- getCOps+  Binding{krevMap} <- getBinding+  let stripFrame ('\n' : art) =+        let interior = tail . init+        in map interior $ interior $ lines art+      stripFrame art = assert `failure` "displayMainMenu: " ++ art+      pasteVersion art =+        let pathsVersion = rpathsVersion $ Kind.stdRuleset corule+            version = " Version " ++ showVersion pathsVersion+                      ++ " (frontend: " ++ frontendName+                      ++ ", engine: LambdaHack " ++ showVersion Self.version+                      ++ ") "+            versionLen = length version+        in init art ++ [take (80 - versionLen) (last art) ++ version]+      kds =  -- key-description pairs+        let showKD cmd key = (show key, Command.cmdDescription cmd)+            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd krevMap+            cmds = [Command.GameSave, Command.GameExit,+                   Command.GameRestart, Command.Help]+        in map revLookup cmds ++ [(fst (revLookup Command.Clear), "continue")]+      bindings =  -- key bindings to display+        let bindingLen = 25+            fmt (k, d) =+              let gapLen = (8 - length k) `max` 1+                  padLen = bindingLen - length k - gapLen - length d+              in k ++ replicate gapLen ' ' ++ d ++ replicate padLen ' '+        in map fmt kds+      overwrite =  -- overwrite the art with key bindings+        let over [] line = ([], line)+            over bs@(binding : bsRest) line =+              let (prefix, lineRest) = break (=='{') line+                  (braces, suffix)   = span  (=='{') lineRest+              in if length braces == 25+                 then (bsRest, prefix ++ binding ++ suffix)+                 else (bs, line)+        in snd . L.mapAccumL over bindings+      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule+      menuOverlay = overwrite $ pasteVersion $ stripFrame mainMenuArt+  case menuOverlay of+    [] -> assert `failure` "empty Main Menu overlay"+    hd : tl -> displayOverlays hd "" [tl]+ 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+      msg = "You survived for " ++ turn             ++ " half-second turns. Past messages:"-  displayOverlays msg $ splitOverlay lysize $ renderHistory shistory+  displayOverlays msg "" $+    splitOverlay lysize $ renderHistory shistory  dumpConfig :: Action () dumpConfig = do@@ -506,9 +606,6 @@   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@@ -519,3 +616,16 @@       upd = IM.insert ploc $ timeAdd time $ smellTimeout s   when (isAHero s pl) $     modify $ updateLevel $ updateSmell upd++-- | Update the wait/block count.+setWaitBlock :: ActorId -> Action ()+setWaitBlock actor = do+  Kind.COps{coactor} <- getCOps+  time <- gets stime+  updateAnyActor actor $ \ m -> m {bwait = timeAddFromSpeed coactor m time}++-- | Player waits a turn (and blocks, etc.).+waitBlock :: Action ()+waitBlock = do+  pl <- gets splayer+  setWaitBlock pl
Game/LambdaHack/Actor.hs view
@@ -3,12 +3,9 @@ module Game.LambdaHack.Actor   ( -- * Actor identifiers and related operations     ActorId, findHeroName, monsterGenChance-    -- * Party identifiers-  , PartyId, heroParty, enemyParty, animalParty-  , heroProjectiles, enemyProjectiles, animalProjectiles, allProjectiles     -- * The@ Acto@r type-  , Actor(..), template, addHp, unoccupied, heroKindId-  , projectileKindId, actorSpeed+  , Actor(..), template, addHp, timeAddFromSpeed, braced+  , unoccupied, heroKindId, projectileKindId, actorSpeed     -- * Type of na actor target   , Target(..)   ) where@@ -22,53 +19,33 @@ import Game.LambdaHack.Vector import Game.LambdaHack.Point import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.FactionKind 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 -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor-  { bkind   :: !(Kind.Id ActorKind)    -- ^ the kind of the actor-  , bsymbol :: !(Maybe Char)           -- ^ individual map symbol-  , bname   :: !(Maybe String)         -- ^ individual name-  , bcolor  :: !(Maybe Color.Color)    -- ^ individual map color-  , bspeed  :: !(Maybe Speed)          -- ^ individual speed-  , bhp     :: !Int                    -- ^ current hit points-  , bdir    :: !(Maybe (Vector, Int))  -- ^ direction and distance of running-  , btarget :: Target                  -- ^ target for ranged attacks and AI-  , bloc    :: !Point                  -- ^ current location-  , bletter :: !Char                   -- ^ next inventory letter-  , btime   :: !Time                   -- ^ absolute time of next action-  , bparty  :: !PartyId                -- ^ to which party the actor belongs+  { 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                   -- ^ absolute time of next action+  , bwait    :: !Time                   -- ^ last bracing expires at this time+  , bfaction :: !(Kind.Id FactionKind)  -- ^ to which faction the actor belongs+  , bproj    :: !Bool                   -- ^ is a projectile? (shorthand only,+                                        -- ^ this can be deduced from bkind)   }   deriving Show @@ -85,7 +62,9 @@     put bloc     put bletter     put btime-    put bparty+    put bwait+    put bfaction+    put bproj   get = do     bkind   <- get     bsymbol <- get@@ -98,7 +77,9 @@     bloc    <- get     bletter <- get     btime   <- get-    bparty  <- get+    bwait   <- get+    bfaction <- get+    bproj    <- get     return Actor{..}  -- ActorId operations@@ -120,24 +101,21 @@ -- will also depend on the cave kind used to build the level. monsterGenChance :: Int -> Int -> Rnd Bool monsterGenChance depth numMonsters =-  chance $ 1%(fromIntegral (25 + 20 * (numMonsters - depth)) `max` 5)+  chance $ 1%(fromIntegral (30 * (numMonsters - depth)) `max` 5)  -- Actor operations --- TODO: Setting the time of new monsters to 0 makes them able to--- move immediately after generation. This does not seem like--- a bad idea, but it would certainly be "more correct" to set--- the time to the creation time instead.--- | A template for a new actor. The initial target is invalid+-- | A template for a new non-projectile actor. The initial target is invalid -- to force a reset ASAP. template :: Kind.Id ActorKind -> Maybe Char -> Maybe String -> Int -> Point-         -> Time -> PartyId -> Actor-template bkind bsymbol bname bhp bloc btime bparty =+         -> Time -> Kind.Id FactionKind -> Bool -> Actor+template bkind bsymbol bname bhp bloc btime bfaction bproj =   let bcolor  = Nothing       bspeed  = Nothing       btarget = invalidTarget       bdir    = Nothing       bletter = 'a'+      bwait   = timeZero   in Actor{..}  -- | Increment current hit points of an actor.@@ -150,6 +128,23 @@      then m      else m {bhp = min maxHP (currentHP + extra)} +-- | 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++-- | Add time taken by a single step at the actor's current speed.+timeAddFromSpeed :: Kind.Ops ActorKind -> Actor -> Time -> Time+timeAddFromSpeed coactor m time =+  let speed = actorSpeed coactor m+      delta = ticksPerMeter speed+  in timeAdd time delta++-- | Whether an actor is braced for combat this turn.+braced :: Actor -> Time -> Bool+braced m time = time < bwait m+ -- | Checks for the presence of actors in a location. -- Does not check if the tile is walkable. unoccupied :: [Actor] -> Point -> Bool@@ -163,12 +158,6 @@ -- | 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
Game/LambdaHack/ActorState.hs view
@@ -1,7 +1,14 @@ -- | Operations on the 'Actor' type that need the 'State' type, -- but not the 'Action' type.--- TODO: Add an export list and document after it's rewritten according to #17.-module Game.LambdaHack.ActorState where+-- TODO: Document an export list after it's rewritten according to #17.+module Game.LambdaHack.ActorState+  ( isProjectile, isAHero, getPlayerBody, findActorAnyLevel, calculateTotal+  , smellTimeout, initialHeroes, deletePlayer, allHeroesAnyLevel+  , locToActor, deleteActor, addHero, addMonster, updateAnyActorItem+  , insertActor, heroList, memActor, getActor, updateAnyActorBody+  , hostileList, getActorItem, getPlayerItem, tryFindHeroK, dangerousList+  , factionList, addProjectile, foesAdjacent, targetToLoc, hostileAssocs+  ) where  import Control.Monad import qualified Data.List as L@@ -12,6 +19,7 @@  import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Point+import Game.LambdaHack.PointXY import Game.LambdaHack.Vector import Game.LambdaHack.Actor import Game.LambdaHack.Level@@ -20,6 +28,7 @@ import Game.LambdaHack.Grammar import Game.LambdaHack.Item import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Content.ItemKind import qualified Game.LambdaHack.Config as Config@@ -28,19 +37,19 @@ import qualified Game.LambdaHack.Feature as F import Game.LambdaHack.Time +-- | Checks whether an actor identifier represents a hero.+isProjectile :: State -> ActorId -> Bool+isProjectile s a =+  let (_, actor, _) = findActorAnyLevel a s+  in bproj actor+ -- 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+  in bfaction actor == sfaction s && not (bproj actor)  -- TODO: move to TileState if ever created. -- | How long until an actor's smell vanishes from a tile.@@ -84,8 +93,10 @@  -- | The list of actors and their levels for all heroes in the dungeon. allHeroesAnyLevel :: State -> [ActorId]-allHeroesAnyLevel State{slid, sdungeon} =-  let one (_, lvl) = L.map fst (heroAssocs lvl)+allHeroesAnyLevel State{slid, sdungeon, sfaction} =+  let one (_, lvl) =+        [ a | (a, m) <- IM.toList $ lactor lvl+            , bfaction m == sfaction && not (bproj m) ]   in L.concatMap one (currentFirst slid sdungeon)  updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State@@ -152,43 +163,30 @@ deletePlayer :: State -> State deletePlayer s@State{splayer} = deleteActor splayer s --- TODO: unify-heroAssocs, hostileAssocs, dangerousAssocs, friendlyAssocs, allButHeroesAssocs-  :: Level -> [(ActorId, Actor)]-heroAssocs lvl =-  filter (\ (_, m) -> bparty m == heroParty) $ IM.toList $ lactor lvl-hostileAssocs lvl =-  filter (\ (_, m) -> bparty m `elem` [enemyParty, animalParty]) $-  IM.toList $ lactor lvl-dangerousAssocs lvl =-  filter (\ (_, m) -> bparty m `elem`-                        [enemyParty, animalParty,-                         enemyProjectiles, animalProjectiles]) $-  IM.toList $ lactor lvl-friendlyAssocs lvl =-  filter (\ (_, m) -> bparty m `elem` [heroParty, heroProjectiles]) $-  IM.toList $ lactor lvl-allButHeroesAssocs lvl =-    filter (\ (_, m) -> bparty m `elem`-                        [heroProjectiles, enemyParty, animalParty,-                         enemyProjectiles, animalProjectiles]) $-  IM.toList $ lactor lvl+-- TODO: unify, rename+hostileAssocs :: Kind.Id FactionKind -> Level -> [(ActorId, Actor)]+hostileAssocs faction lvl =+  filter (\ (_, m) -> bfaction m /= faction && not (bproj m)) $+    IM.toList $ lactor lvl+heroList, hostileList, dangerousList :: State -> [Actor]+heroList state@State{sfaction} =+  filter (\ m -> bfaction m == sfaction && not (bproj m)) $+    IM.elems $ lactor $ slevel state+hostileList state@State{sfaction} =+  filter (\ m -> bfaction m /= sfaction && not (bproj m)) $+    IM.elems $ lactor $ slevel state+dangerousList state@State{sfaction} =+  filter (\ m -> bfaction m /= sfaction) $+    IM.elems $ lactor $ slevel state -heroList, hostileList, dangerousList, friendlyList :: State -> [Actor]-heroList state =-  filter (\ m -> bparty m == heroParty) $ IM.elems $ lactor $ slevel state-hostileList state =-  filter (\ m -> bparty m `elem` [enemyParty, animalParty]) $-  IM.elems $ lactor $ slevel state-dangerousList state =-  filter (\ m -> bparty m `elem`-                   [enemyParty, animalParty,-                    enemyProjectiles, animalProjectiles]) $-  IM.elems $ lactor $ slevel state-friendlyList state =-  filter (\ m -> bparty m `elem` [heroParty, heroProjectiles]) $-  IM.elems $ lactor $ slevel state+factionAssocs :: [Kind.Id FactionKind] -> Level -> [(ActorId, Actor)]+factionAssocs l lvl =+  filter (\ (_, m) -> bfaction m `elem` l) $ IM.toList $ lactor lvl +factionList :: [Kind.Id FactionKind] -> State -> [Actor]+factionList l s =+  filter (\ m -> bfaction m `elem` l) $ IM.elems $ lactor $ slevel s+ -- | Finds an actor at a location on the current level. Perception irrelevant. locToActor :: Point -> State -> Maybe ActorId locToActor loc state =@@ -213,11 +211,17 @@ -- | 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+  let ha = factionAssocs [sfaction s] $ 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) +foesAdjacent :: X -> Y -> Point -> [Actor] -> Bool+foesAdjacent lxsize lysize loc foes =+  let vic = IS.fromList $ vicinity lxsize lysize loc+      lfs = IS.fromList $ L.map bloc foes+  in not $ IS.null $ IS.intersection vic lfs+ -- Adding heroes  tryFindHeroK :: State -> Int -> Maybe ActorId@@ -229,17 +233,17 @@  -- | 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@State{scounter} =+addHero Kind.COps{coactor, cotile} ploc state@State{scounter, sfaction} =   let config = sconfig state       bHP = Config.get config "heroes" "baseHP"       loc = nearbyFreeLoc cotile ploc state       freeHeroK = L.elemIndex Nothing $ map (tryFindHeroK state) [0..9]-      n = fromMaybe 10 freeHeroK+      n = fromMaybe 100 freeHeroK       symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n       name = findHeroName config n-      startHP = bHP `div` min 5 (n + 1)+      startHP = bHP - (bHP `div` 5) * min 3 n       m = template (heroKindId coactor) (Just symbol) (Just name)-                   startHP loc (stime state) heroParty+                   startHP loc (stime state) sfaction False       cstate = state { scounter = scounter + 1 }   in updateLevel (updateActorDict (IM.insert scounter m)) cstate @@ -253,21 +257,21 @@  -- | Create a new monster in the level, at a given position -- 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} = do+addMonster :: Kind.Ops TileKind -> Kind.Id ActorKind -> Int -> Point+           -> Kind.Id FactionKind -> Bool -> State -> State+addMonster cotile mk hp ploc bfaction bproj state@State{scounter} = do   let loc = nearbyFreeLoc cotile ploc state-      m = template mk Nothing Nothing hp loc (stime state) enemyParty+      m = template mk Nothing Nothing hp loc (stime state) bfaction bproj       cstate = state {scounter = scounter + 1}   updateLevel (updateActorDict (IM.insert scounter m)) cstate  -- Adding projectiles  -- | Create a projectile actor containing the given missile.-addProjectile :: Kind.COps -> Item -> Point -> PartyId -> [Point] -> Time-              -> State -> State+addProjectile :: Kind.COps -> Item -> Point -> Kind.Id FactionKind+              -> [Point] -> Time -> State -> State addProjectile Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}}-              item loc bparty path btime state@State{scounter} =+              item loc bfaction path btime state@State{scounter} =   let ik = okind (jkind item)       object = objectItem coitem state item       name = "a flying " ++ unwords (tail (words object))@@ -286,7 +290,9 @@         , bloc    = loc         , bletter = 'a'         , btime-        , bparty+        , bwait   = timeZero+        , bfaction+        , bproj   = True         }       cstate = state { scounter = scounter + 1 }       upd = updateActorDict (IM.insert scounter m)
+ Game/LambdaHack/Animation.hs view
@@ -0,0 +1,127 @@+-- | Screen frames and animations.+module Game.LambdaHack.Animation+  ( Attr(..), defaultAttr, AttrChar(..)+  , SingleFrame(..), Animation, rederAnim+  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces+  ) where++import qualified Data.IntMap as IM+import Data.Maybe+import qualified Data.List as L+import Data.Monoid++import Game.LambdaHack.PointXY+import Game.LambdaHack.Point+import Game.LambdaHack.Color++-- | 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.+newtype Animation = Animation [IM.IntMap AttrChar]++instance Monoid Animation where+  mempty = Animation []+  mappend (Animation a1) (Animation a2) = Animation (a1 ++ a2)++-- | Render animations on top of a screen frame.+rederAnim :: X -> Y -> SingleFrame -> Animation+          -> [Maybe SingleFrame]+rederAnim lxsize lysize basicFrame (Animation anim) =+  let modifyFrame 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 SingleFrame{..}+  in map (modifyFrame basicFrame) anim++blank :: Maybe AttrChar+blank = Nothing++coloredSymbol :: Color -> Char -> Maybe AttrChar+coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol++mzipPairs :: (Maybe Point, Maybe Point) -> (Maybe AttrChar, Maybe AttrChar)+          -> [(Point, AttrChar)]+mzipPairs (mloc1, mloc2) (mattr1, mattr2) =+  let mzip (Just loc, Just attr) = Just (loc, attr)+      mzip _ = Nothing+  in if mloc1 /= mloc2+     then catMaybes [mzip (mloc1, mattr1), mzip (mloc2, mattr2)]+     else -- If actor affects himself, show only the effect, not the action.+          catMaybes [mzip (mloc1, mattr1)]++-- | Attack animation. A part of it also reused for self-damage and healing.+twirlSplash :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation+twirlSplash locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)+  [ (coloredSymbol BrWhite '*', blank)+  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')+  , (coloredSymbol c1      '-', blank)+  , (coloredSymbol c1      '\\',blank)+  , (coloredSymbol c1      '|', blank)+  , (coloredSymbol c2      '/', blank)+  , (coloredSymbol c2      '%', coloredSymbol BrCyan '^')+  , (coloredSymbol c2      '%', blank)+  , (blank                    , blank)+  ]++-- | Attack that hits through a block.+blockHit :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation+blockHit locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)+  [ (coloredSymbol BrWhite '*', blank)+  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')+  , (coloredSymbol BrBlue  '{', blank)+  , (coloredSymbol c1      '}', blank)+  , (coloredSymbol c1      '}', coloredSymbol BrCyan '^')+  , (coloredSymbol c2      '/', blank)+  , (coloredSymbol c2      '%', blank)+  , (coloredSymbol c2      '%', blank)+  , (blank                    , blank)+  ]++-- | Attack that is blocked.+blockMiss :: (Maybe Point, Maybe Point) -> Animation+blockMiss locs = Animation $ map (IM.fromList . mzipPairs locs)+  [ (coloredSymbol BrWhite '*', blank)+  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')+  , (coloredSymbol BrBlue  '}', blank)+  , (coloredSymbol BrBlue  '}', blank)+  , (blank                    , blank)+  ]++-- | Death animation for an organic body.+deathBody :: Point -> Animation+deathBody loc = Animation $ map (maybe IM.empty (IM.singleton loc))+  [ coloredSymbol BrRed '\\'+  , coloredSymbol BrRed '\\'+  , coloredSymbol BrRed '|'+  , coloredSymbol BrRed '|'+  , coloredSymbol BrRed '%'+  , coloredSymbol BrRed '%'+  , coloredSymbol Red   '%'+  , coloredSymbol Red   '%'+  , coloredSymbol Red   ';'+  , coloredSymbol Red   ';'+  , coloredSymbol Red   ','+  ]++-- | Swap-places animation, both hostile and friendly.+swapPlaces :: (Maybe Point, Maybe Point) -> Animation+swapPlaces locs = Animation $ map (IM.fromList . mzipPairs locs)+  [ (coloredSymbol BrMagenta '.', coloredSymbol Magenta   'o')+  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')+  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')+  , (coloredSymbol Magenta   'o', blank)+  ]
Game/LambdaHack/Binding.hs view
@@ -12,6 +12,7 @@ import Game.LambdaHack.Utils.Assert import qualified Game.LambdaHack.Key as K import Game.LambdaHack.Msg+import qualified Game.LambdaHack.Command as Command  -- | Bindings and other information about player commands. data Binding a = Binding@@ -20,6 +21,8 @@   , 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+  , krevMap :: M.Map Command.Cmd K.Key+                                     -- ^ map from cmds to their main keys   }  -- | Produce the macro map from a macro association list@@ -59,7 +62,7 @@       , "               1 2 3          b j n"       , ""       ,"Run ahead until anything disturbs you, with SHIFT (or CTRL) and a key."-      , "Press keypad '5' or '.' to skip a turn."+      , "Press keypad '5' or '.' to wait a turn, bracing for blows next turn."       , "In targeting mode the same keys move the targeting cursor."       , ""       , "Search, open and attack, by bumping into walls, doors and monsters."@@ -74,7 +77,7 @@     minorBlurb =       [ ""       , "For more playing instructions see file PLAYING.md."-      , "Press SPACE to clear the messages and go back to the game."+      , "Press SPACE to clear the messages and see the map again."       ]     fmt k h = replicate 16 ' ' ++ k ++ replicate ((15 - length k) `max` 1) ' '                                ++ h ++ replicate ((41 - length h) `max` 1) ' '
Game/LambdaHack/BindingAction.hs view
@@ -7,12 +7,12 @@ import qualified Data.List as L import qualified Data.Map as M import qualified Data.Char as Char+import Data.Tuple (swap)  import Game.LambdaHack.Action import Game.LambdaHack.State import qualified Game.LambdaHack.Config as Config import Game.LambdaHack.Level-import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Actions import Game.LambdaHack.Running import Game.LambdaHack.EffectAction@@ -20,40 +20,7 @@ import qualified Game.LambdaHack.Key as K import Game.LambdaHack.ActorState import Game.LambdaHack.Command--configCmd :: Config.CP -> [(K.Key, Cmd)]-configCmd config =-  let section = Config.getItems config "commands"-      mkKey s =-        case K.keyTranslate s of-          K.Unknown _ -> assert `failure` ("unknown command key " ++ s)-          key -> key-      mkCmd s = read s :: Cmd-      mkCommand (key, def) = (mkKey key, mkCmd def)-  in L.map mkCommand section--semanticsCmd :: [(K.Key, Cmd)]-             -> (Cmd -> ActionFrame ())-             -> (Cmd -> String)-             -> [((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, 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 :: ActionFrame () -> ActionFrame ()-checkCursor h = do-  cursor <- gets scursor-  slid <- gets slid-  if creturnLn cursor == slid-    then h-    else abortWith "this command does not work on remote levels"+import Game.LambdaHack.CommandAction  heroSelection :: [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))] heroSelection =@@ -70,14 +37,12 @@ -- | Binding of keys to movement and other standard commands, -- as well as commands defined in the config file. 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 =+stdBinding config =   let section = Config.getItems config "macros"       !kmacro = macroKey section-      cmdList = configCmd config-      semList = semanticsCmd cmdList cmdS cmdD+      cmdList = configCmds config+      semList = semanticsCmds cmdList       moveWidth f = do         lxsize <- gets (lxsize . slevel)         move $ f lxsize@@ -103,4 +68,5 @@   , kmacro   , kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList   , kdir   = L.map fst cmdDir+  , krevMap = M.fromList $ map swap cmdList   }
+ Game/LambdaHack/CDefs.hs view
@@ -0,0 +1,21 @@+-- | A game requires the engine provided by the library, perhaps customized,+-- and game content, defined completely afresh for the particular game.+-- The general type of the content is @CDefs@ and it has instances+-- for all content kinds, such as items kinds+-- (@Game.LambdaHack.Content.ItemKind@).+-- The possible kinds are fixed in the library and all defined in the same+-- directory. On the other hand, game content, that is all elements+-- of @CDefs@ instances, are defined in a directory+-- of the game code proper, with names corresponding to their kinds.+module Game.LambdaHack.CDefs (CDefs(..)) where++import Game.LambdaHack.Misc++-- | The general type of a particular game content, e.g., item kinds.+data CDefs a = CDefs+  { getSymbol :: a -> Char    -- ^ symbol, e.g., to print on the map+  , getName   :: a -> String  -- ^ name, e.g., to show to the player+  , getFreq   :: a -> Freqs   -- ^ frequency within groups+  , validate  :: [a] -> [a]   -- ^ validate and catch some offenders, if any+  , content   :: [a]          -- ^ all the defined content of this type+  }
Game/LambdaHack/Color.hs view
@@ -3,11 +3,10 @@   ( -- * Colours     Color(..), defBG, defFG, isBright, legalBG, colorToRGB     -- * Text attributes and the screen-  , Attr(..), defaultAttr, AttrChar(..), SingleFrame(..), Animation+  , Attr(..), defaultAttr, AttrChar(..)   ) where  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@@ -77,18 +76,6 @@     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
@@ -1,20 +1,16 @@--- | Abstract syntax of player commands and their semantics.+-- | Abstract syntax of player commands. module Game.LambdaHack.Command-  ( Cmd, majorCmd, timedCmd, cmdSemantics, cmdDescription+  ( Cmd(..), majorCmd, timedCmd, cmdDescription   ) where -import Game.LambdaHack.Action-import Game.LambdaHack.Actions-import Game.LambdaHack.ItemAction+import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Grammar-import Game.LambdaHack.EffectAction-import Game.LambdaHack.State import qualified Game.LambdaHack.Feature as F  -- | Abstract syntax of player commands. The type is abstract, but the values -- are created outside this module via the Read class (from config file) . data Cmd =-    -- These take time:+    -- 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 }@@ -22,23 +18,24 @@   | Pickup   | Drop   | Wait-    -- These do not take time:+  | GameExit+  | GameRestart+    -- These do not take time, or not quite.+  | GameSave   | Inventory   | TgtFloor   | TgtEnemy   | TgtAscend Int   | EpsIncr Bool-  | GameSave-  | GameQuit   | Cancel   | Accept+  | Clear   | History   | CfgDump   | HeroCycle-  | Version+  | HeroBack   | Help-  | Redraw-  deriving (Show, Read)+  deriving (Show, Read, Eq, Ord)  -- | Major commands land on the first page of command help. majorCmd :: Cmd -> Bool@@ -49,9 +46,10 @@   TriggerTile{} -> True   Pickup        -> True   Drop          -> True-  Inventory     -> True+  GameExit      -> True+  GameRestart   -> True   GameSave      -> True-  GameQuit      -> True+  Inventory     -> True   Help          -> True   _             -> False @@ -66,38 +64,11 @@   TriggerTile{} -> True   Pickup        -> True   Drop          -> True-  GameSave      -> True-  GameQuit      -> True   Wait          -> True+  GameExit      -> True  -- takes time, then rewinds time+  GameRestart   -> True  -- takes time, then resets state   _             -> False --- | The semantics of player commands in terms of the @Action@ monad.-cmdSemantics :: Cmd -> ActionFrame ()-cmdSemantics cmd = case cmd of-  Apply{..}       -> inFrame $ playerApplyGroupItem verb object syms-  Project{..}     -> playerProjectGroupItem verb object syms-  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-  EpsIncr b -> inFrame $ epsIncr b-  GameSave ->  inFrame $ saveGame-  GameQuit ->  inFrame $ quitGame-  Cancel ->    inFrame $ cancelCurrent-  Accept ->    acceptCurrent displayHelp-  History ->   displayHistory-  CfgDump ->   inFrame $ dumpConfig-  HeroCycle -> inFrame $ cycleHero-  Version ->   inFrame $ gameVersion-  Help ->      displayHelp-  Redraw ->    inFrame $ redraw- -- | Description of player commands. cmdDescription :: Cmd -> String cmdDescription cmd = case cmd of@@ -105,27 +76,29 @@   Project{..}     -> verb ++ " " ++ addIndefinite object   TriggerDir{..}  -> verb ++ " " ++ addIndefinite object   TriggerTile{..} -> verb ++ " " ++ addIndefinite object-  Pickup ->    "get an object"-  Drop ->      "drop an object"-  Wait ->      ""+  Pickup    -> "get an object"+  Drop      -> "drop an object"+  Wait      -> ""+  GameExit  -> "save and exit"+  GameRestart -> "restart game"+  GameSave  -> "save game"    Inventory -> "display inventory"-  TgtFloor ->  "target location"-  TgtEnemy ->  "target monster"+  TgtFloor  -> "target location"+  TgtEnemy  -> "target monster"   TgtAscend k | k == 1  -> "target next shallower level"   TgtAscend k | k >= 2  -> "target " ++ show k    ++ " levels shallower"   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"+  TgtAscend _ ->+    assert `failure` "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"-  Accept ->    "accept choice"-  History ->   "display previous messages"-  CfgDump ->   "dump current configuration"+  Cancel    -> "cancel action"+  Accept    -> "accept choice"+  Clear     -> "clear messages"+  History   -> "display previous messages"+  CfgDump   -> "dump current configuration"   HeroCycle -> "cycle among heroes on level"-  Version ->   "display game version"-  Help ->      "display help"-  Redraw ->    "clear messages"+  HeroBack  -> "cycle among heroes in the dungeon"+  Help      -> "display help"
+ Game/LambdaHack/CommandAction.hs view
@@ -0,0 +1,78 @@+-- | Semantics of player commands.+module Game.LambdaHack.CommandAction+  ( configCmds, semanticsCmds+  ) where++import Control.Monad.State hiding (State, state)+import qualified Data.List as L++import Game.LambdaHack.Action+import Game.LambdaHack.Actions+import Game.LambdaHack.ItemAction+import Game.LambdaHack.State+import Game.LambdaHack.Command+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Utils.Assert++-- | The semantics of player commands in terms of the @Action@ monad.+cmdAction :: Cmd -> ActionFrame ()+cmdAction cmd = case cmd of+  Apply{..}       -> inFrame $ playerApplyGroupItem verb object syms+  Project{..}     -> playerProjectGroupItem verb object syms+  TriggerDir{..}  -> inFrame $ playerTriggerDir feature verb+  TriggerTile{..} -> inFrame $ playerTriggerTile feature+  Pickup    -> inFrame $ pickupItem+  Drop      -> inFrame $ dropItem+  Wait      -> inFrame $ waitBlock+  GameExit  -> inFrame $ gameExit+  GameRestart -> inFrame $ gameRestart+  GameSave  -> inFrame $ gameSave++  Inventory -> inventory+  TgtFloor  -> targetFloor   TgtExplicit+  TgtEnemy  -> targetMonster TgtExplicit+  TgtAscend k -> tgtAscend k+  EpsIncr b -> inFrame $ epsIncr b+  Cancel    -> cancelCurrent displayMainMenu+  Accept    -> acceptCurrent displayHelp+  Clear     -> inFrame $ clearCurrent+  History   -> displayHistory+  CfgDump   -> inFrame $ dumpConfig+  HeroCycle -> inFrame $ cycleHero+  HeroBack  -> inFrame $ backCycleHero+  Help      -> displayHelp++-- | The associaction of commands to keys defined in config.+configCmds :: Config.CP -> [(K.Key, Cmd)]+configCmds config =+  let section = Config.getItems config "commands"+      mkKey s =+        case K.keyTranslate s of+          K.Unknown _ -> assert `failure` ("unknown command key <" ++ s ++ ">")+          key -> key+      mkCmd s = read s :: Cmd+      mkCommand (key, def) = (mkKey key, mkCmd def)+  in L.map mkCommand section++-- | The list of semantics and other info for all commands from config.+semanticsCmds :: [(K.Key, Cmd)]+              -> [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))]+semanticsCmds cmdList =+  let mkDescribed cmd =+        let semantics = if timedCmd cmd+                        then checkCursor $ cmdAction cmd+                        else cmdAction cmd+        in (cmdDescription 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 :: ActionFrame () -> ActionFrame ()+checkCursor h = do+  cursor <- gets scursor+  slid <- gets slid+  if creturnLn cursor == slid+    then h+    else abortWith "this command does not work on remote levels"
Game/LambdaHack/Config.hs view
@@ -1,18 +1,13 @@ -- | Personal game configuration file support. module Game.LambdaHack.Config-  ( CP, mkConfig, appDataDir-  , getOption, get, getItems, getFile, dump, getSetGen+  ( CP(..), toCP, forceEither, getOption, get, getItems   ) where -import System.Directory-import System.FilePath-import System.Environment import qualified Data.ConfigFile as CF import qualified Data.Binary as Binary-import qualified Data.Char as Char-import qualified Data.List as L-import qualified System.Random as R +import Game.LambdaHack.Utils.Assert+ -- | The content of the configuration file. It's parsed -- in a case sensitive way (unlike by default in ConfigFile). newtype CP = CP CF.ConfigParser@@ -27,54 +22,15 @@ instance Show CP where   show (CP conf) = show $ CF.to_string conf --- | In case of corruption, just fail.-forceEither :: Show a => Either a b -> b-forceEither (Left a)  = error (show a)-forceEither (Right b) = b- -- | Switches all names to case sensitive (unlike by default in -- the "ConfigFile" library) and wraps in the constructor. toCP :: CF.ConfigParser -> CP toCP cf = CP $ cf {CF.optionxform = id} -overrideCP :: CP -> FilePath -> IO CP-overrideCP (CP defCF) cfile = do-  c <- CF.readfile defCF cfile-  return $ toCP $ forceEither c---- | Read the player configuration file and use it to override--- any default config options. Currently we can't unset options, only override.------ The default config, passed in argument @configDefault@,--- is expected to come from the default configuration file included via CPP--- in file @ConfigDefault.hs@.-mkConfig :: String -> IO CP-mkConfig configDefault = do-  let delFileMarker = L.init $ L.drop 3 $ lines configDefault-      delComment = L.map (L.drop 2) delFileMarker-      unConfig = unlines delComment-      -- Evaluate, to catch config errors ASAP.-      !defCF = forceEither $ CF.readstring CF.emptyCP unConfig-      !defConfig = toCP defCF-  cfile <- configFile-  b <- doesFileExist cfile-  if not b-    then return defConfig-    else overrideCP defConfig cfile---- | Personal data directory for the game. Depends on the OS and the game,--- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.-appDataDir :: IO FilePath-appDataDir = do-  progName <- getProgName-  let name = L.takeWhile Char.isAlphaNum progName-  getAppUserDataDirectory name---- | Path to the user configuration file in the personal data directory.-configFile :: IO FilePath-configFile = do-  appData <- appDataDir-  return $ combine appData "config"+-- | In case of corruption, just fail.+forceEither :: Show a => Either a b -> b+forceEither (Left a)  = assert `failure` a+forceEither (Right b) = b  -- | A simplified access to an option in a given section, -- with simple error reporting (no internal errors are caught nor hidden).@@ -91,56 +47,11 @@ get (CP conf) s o =   if CF.has_option conf s o   then forceEither $ CF.get conf s o-  else error $ "Unknown config option: " ++ s ++ "." ++ o+  else assert `failure` "Unknown config option: " ++ s ++ "." ++ o  -- | An association list corresponding to a section. Fails if no such section. getItems :: CP -> CF.SectionSpec -> [(String, String)] getItems (CP conf) s =   if CF.has_section conf s   then forceEither $ CF.items conf s-  else error $ "Unknown config section: " ++ s---- | Looks up a file path in the config file and makes it absolute.--- If the game's configuration directory exists,--- the file path is appended to it; otherwise, it's appended--- to the current directory.-getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath-getFile conf s o = do-  current <- getCurrentDirectory-  appData <- appDataDir-  let path    = get conf s o-      appPath = combine appData path-      curPath = combine current path-  b <- doesDirectoryExist appData-  return $ if b then appPath else curPath---- | Dumps the current configuration to a file.-dump :: FilePath -> CP -> IO ()-dump fn (CP conf) = do-  current <- getCurrentDirectory-  let path  = combine current fn-      sdump = CF.to_string conf-  writeFile path sdump---- | Simplified setting of an option in a given section. Overwriting forbidden.-set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP-set (CP conf) s o v =-  if CF.has_option conf s o-  then error $ "Overwritten config option: " ++ s ++ "." ++ o-  else CP $ forceEither $ CF.set conf s o v---- | Gets a random generator from the config or,--- if not present, generates one and updates the config with it.-getSetGen :: CP  -- ^ config-          -> String     -- ^ name of the generator-          -> IO (R.StdGen, CP)-getSetGen config option =-  case getOption config "engine" option of-    Just sg -> return (read sg, config)-    Nothing -> do-      -- Pick the randomly chosen generator from the IO monad-      -- and record it in the config for debugging (can be 'D'umped).-      g <- R.newStdGen-      let gs = show g-          c = set config "engine" option gs-      return (g, c)+  else assert `failure` "Unknown config section: " ++ s
− Game/LambdaHack/Content.hs 
@@ -1,21 +0,0 @@--- | A game requires the engine provided by the library, perhaps customized,--- and game content, defined completely afresh for the particular game.--- The general type of the content is @CDefs@ and it has instances--- for all content kinds, such as items kinds--- (@Game.LambdaHack.Content.ItemKind@).--- The possible kinds are fixed in the library and all defined in the same--- directory. On the other hand, game content, that is all elements--- of @CDefs@ instances, are defined in a directory--- of the game code proper, with names corresponding to their kinds.-module Game.LambdaHack.Content (CDefs(..)) where--import Game.LambdaHack.Misc---- | The general type of a particular game content, e.g., item kinds.-data CDefs a = CDefs-  { getSymbol :: a -> Char    -- ^ symbol, e.g., to print on the map-  , getName   :: a -> String  -- ^ name, e.g., to show to the player-  , getFreq   :: a -> Freqs   -- ^ frequency within groups-  , validate  :: [a] -> [a]   -- ^ validate and catch some offenders, if any-  , content   :: [a]          -- ^ all the defined content of this type-  }
Game/LambdaHack/Content/ActorKind.hs view
@@ -6,6 +6,7 @@ import qualified Data.List as L import qualified Data.Ord as Ord +import Game.LambdaHack.Ability import Game.LambdaHack.Color import qualified Game.LambdaHack.Random as Random import Game.LambdaHack.Misc@@ -25,6 +26,7 @@   , asmell  :: !Bool             -- ^ can it smell?   , aiq     :: !Int              -- ^ intelligence   , aregen  :: !Int              -- ^ number of turns to regenerate 1 HP+  , acanDo  :: ![Ability]        -- ^ the set of supported abilities   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53
+ Game/LambdaHack/Content/FactionKind.hs view
@@ -0,0 +1,23 @@+-- | The type of kinds of game factions (heroes, enemies, NPCs, etc.).+module Game.LambdaHack.Content.FactionKind+  ( FactionKind(..), fvalidate+  ) where++import Game.LambdaHack.Misc++-- | Faction properties that are fixed for a given kind of factions.+data FactionKind = FactionKind+  { fsymbol     :: !Char      -- ^ a symbol+  , fname       :: !String    -- ^ short description+  , ffreq       :: !Freqs     -- ^ frequency within groups+  , fAiSelected :: !String    -- ^ Ai to use for the selected actor+  , fAiIdle     :: !String    -- ^ Ai to use for idle actors+  , fenemy      :: ![String]  -- ^ initially in war with these factions+  , fally       :: ![String]  -- ^ initially allied with these factions+  }+  deriving Show++-- | No specific possible problems for the content of this kind, so far,+-- so the validation function always returns the empty list of offending kinds.+fvalidate :: [FactionKind] -> [FactionKind]+fvalidate _ = []
Game/LambdaHack/Content/RuleKind.hs view
@@ -35,6 +35,8 @@   , rpathsVersion     :: Version  -- ^ the version of the game   , ritemMelee        :: [Char]   -- ^ symbols of melee weapons   , ritemProject      :: [Char]   -- ^ symbols of items AI can project+  , rconfigDefault    :: String   -- ^ the default config file of the game+  , rmainMenuArt      :: String   -- ^ the ASCII art for the Main Menu   }  -- | A dummy instance of the 'Show' class, to satisfy general requirments@@ -43,7 +45,6 @@ instance Show RuleKind where   show _ = "The game ruleset specification." --- | No specific possible problems for the content of this kind, so far,--- so the validation function always returns the empty list of offending kinds.+-- | Validates the ASCII art format (TODO). ruvalidate :: [RuleKind] -> [RuleKind] ruvalidate _ = []
+ Game/LambdaHack/Content/StrategyKind.hs view
@@ -0,0 +1,21 @@+-- | The type of kinds of AI strategies.+module Game.LambdaHack.Content.StrategyKind+  ( StrategyKind(..), svalidate+  ) where++import Game.LambdaHack.Ability+import Game.LambdaHack.Misc++-- | Strategy properties that are fixed for a given kind of strategies.+data StrategyKind = StrategyKind+  { ssymbol    :: !Char       -- ^ a symbol+  , sname      :: !String     -- ^ short description+  , sfreq      :: !Freqs      -- ^ frequency within groups+  , sabilities :: ![Ability]  -- ^ abilities to pick from in roughly that order+  }+  deriving Show++-- | No specific possible problems for the content of this kind, so far,+-- so the validation function always returns the empty list of offending kinds.+svalidate :: [StrategyKind] -> [StrategyKind]+svalidate _ = []
Game/LambdaHack/Content/TileKind.hs view
@@ -6,6 +6,7 @@ import qualified Data.List as L import qualified Data.Map as M +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Color import Game.LambdaHack.Feature import Game.LambdaHack.Misc@@ -37,8 +38,10 @@   let listFov f = L.map (\ kt -> ((tsymbol kt, f kt), [kt])) lt       mapFov :: (TileKind -> Color) -> M.Map (Char, Color) [TileKind]       mapFov f = M.fromListWith (++) $ listFov f-      namesUnequal l = let name = tname (L.head l)-                       in L.any (/= name) (L.map tname l)+      namesUnequal [] = assert `failure` lt+      namesUnequal (hd : tl) = let name = tname hd+                               -- Check that at least one is different.+                               in L.any (/= name) (L.map tname tl)       confusions f = L.filter namesUnequal $ M.elems $ mapFov f   in case confusions tcolor ++ confusions tcolor2 of     [] -> []
− Game/LambdaHack/Display.hs 
@@ -1,27 +0,0 @@--- | Display game data on the screen using one of the available frontends--- (determined at compile time with cabal flags).-{-# LANGUAGE CPP #-}-module Game.LambdaHack.Display-  ( -- * Re-exported frontend-    FrontendSession, startup, shutdown, frontendName, nextEvent, promptGetKey-    -- * Derived operations-  , displayFrame-  ) where---- Wrapper for selected Display frontend.--#ifdef CURSES-import Game.LambdaHack.Display.Curses as D-#elif VTY-import Game.LambdaHack.Display.Vty as D-#elif STD-import Game.LambdaHack.Display.Std as D-#else-import Game.LambdaHack.Display.Gtk as D-#endif--import qualified Game.LambdaHack.Color as Color---- | 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 
@@ -1,159 +0,0 @@--- | Text frontend based on HSCurses.-module Game.LambdaHack.Display.Curses-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetKey-    -- * Frontend administration tools-  , frontendName, startup, shutdown-  ) where--import qualified UI.HSCurses.Curses as C-import qualified UI.HSCurses.CursesHelper as C-import qualified Data.List as L-import qualified Data.Map as M-import Control.Monad--import qualified Game.LambdaHack.Key as K (Key(..),  Modifier(..))-import qualified Game.LambdaHack.Color as Color---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { swin    :: C.Window  -- ^ the window to draw to-  , sstyles :: M.Map Color.Attr C.CursesStyle-      -- ^ map from fore/back colour pairs to defined curses styles-  }---- | The name of the frontend.-frontendName :: String-frontendName = "curses"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = do-  C.start---  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.-            bg <- Color.legalBG ]-  nr <- C.colorPairs-  when (nr < L.length s) $-    C.end >>-    error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")-  let (ks, vs) = unzip s-  ws <- C.convertStyles vs-  let styleMap = M.fromList (zip ks ws)-  k (FrontendSession C.stdScr styleMap)---- | Shuts down the frontend cleanly.-shutdown :: FrontendSession -> IO ()-shutdown _ = C.end---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe Color.SingleFrame  -- ^ the screen frame to draw-        -> IO ()-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 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.-  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 -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent _sess _ = do-  e <- C.getKey C.refresh-  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-    C.KeyChar '\ESC' -> K.Esc-    C.KeyExit        -> K.Esc-    C.KeyChar '\n'   -> K.Return-    C.KeyChar '\r'   -> K.Return-    C.KeyEnter       -> K.Return-    C.KeyChar ' '    -> K.Space-    C.KeyChar '\t'   -> K.Tab-    C.KeyUp          -> K.Up-    C.KeyDown        -> K.Down-    C.KeyLeft        -> K.Left-    C.KeySLeft       -> K.Left-    C.KeyRight       -> K.Right-    C.KeySRight      -> K.Right-    C.KeyHome        -> K.Home-    C.KeyPPage       -> K.PgUp-    C.KeyEnd         -> K.End-    C.KeyNPage       -> K.PgDn-    C.KeyBeg         -> K.Begin-    C.KeyB2          -> K.Begin-    C.KeyClear       -> K.Begin-    -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10-    -- 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-    _                       -> K.Unknown (show e)--toFColor :: Color.Color -> C.ForegroundColor-toFColor Color.Black     = C.BlackF-toFColor Color.Red       = C.DarkRedF-toFColor Color.Green     = C.DarkGreenF-toFColor Color.Brown     = C.BrownF-toFColor Color.Blue      = C.DarkBlueF-toFColor Color.Magenta   = C.PurpleF-toFColor Color.Cyan      = C.DarkCyanF-toFColor Color.White     = C.WhiteF-toFColor Color.BrBlack   = C.GreyF-toFColor Color.BrRed     = C.RedF-toFColor Color.BrGreen   = C.GreenF-toFColor Color.BrYellow  = C.YellowF-toFColor Color.BrBlue    = C.BlueF-toFColor Color.BrMagenta = C.MagentaF-toFColor Color.BrCyan    = C.CyanF-toFColor Color.BrWhite   = C.BrightWhiteF--toBColor :: Color.Color -> C.BackgroundColor-toBColor Color.Black     = C.BlackB-toBColor Color.Red       = C.DarkRedB-toBColor Color.Green     = C.DarkGreenB-toBColor Color.Brown     = C.BrownB-toBColor Color.Blue      = C.DarkBlueB-toBColor Color.Magenta   = C.PurpleB-toBColor Color.Cyan      = C.DarkCyanB-toBColor Color.White     = C.WhiteB-toBColor _               = C.BlackB  -- a limitation of curses
− Game/LambdaHack/Display/Gtk.hs 
@@ -1,469 +0,0 @@--- | 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, promptGetKey-    -- * Frontend administration tools-  , frontendName, startup, shutdown-  ) where--import Control.Monad-import Control.Monad.Reader-import Control.Concurrent-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.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 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"---- | 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-  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-  -- Text attributes.-  ttt <- textTagTableNew-  stags <- fmap M.fromList $-             mapM (\ ak -> do-                      tt <- textTagNew Nothing-                      textTagTableAdd ttt tt-                      doAttr tt ak-                      return (ak, tt))-               [ Color.Attr{fg, bg}-               | fg <- [minBound..maxBound], bg <- Color.legalBG ]-  -- Text buffer.-  tb <- textBufferNew (Just ttt)-  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?-  sview <- textViewNewWithBuffer tb-  textViewSetEditable sview False-  textViewSetCursorVisible sview False-  -- 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-  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 main window.-  w <- windowNew-  containerAdd w sview-  onDestroy w mainQuit-  widgetShowAll w-  -- Wait until the other thread draws something and show the window.-  yield-  mainGUI---- | Shuts down the frontend cleanly.-shutdown :: FrontendSession -> IO ()-shutdown _ = mainQuit---- | Output to the screen via the frontend.-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 -> TextTag -> Int -> (Int, [TextTag]) -> IO ()-setTo _  _   _  (_,  [])         = return ()-setTo tb defaultAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx-  ie <- textIterCopy ib-  let setIter :: TextTag -> Int -> [TextTag] -> IO ()-      setIter previous repetitions [] = do-        textIterForwardChars ie repetitions-        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 /= defaultAttr) $-              textBufferApplyTag tb previous ib ie-            textIterForwardChars ib repetitions-            setIter a 1 as-  setIter attr 1 attrs---- 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---- | 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}-  | attr == Color.defaultAttr = return ()-  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]-  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,-                                textTagBackground := Color.colorToRGB bg]
− Game/LambdaHack/Display/Std.hs 
@@ -1,117 +0,0 @@--- | Text frontend based on stdin/stdout, intended for bots.-module Game.LambdaHack.Display.Std-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetKey-    -- * Frontend administration tools-  , frontendName, startup, shutdown-  ) where--import qualified Data.List as L-import qualified Data.ByteString.Char8 as BS-import qualified System.IO as SIO--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.-type FrontendSession = ()---- | The name of the frontend.-frontendName :: String-frontendName = "std"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = k ()---- | Shuts down the frontend cleanly. Nothing to be done in this case.-shutdown :: FrontendSession -> IO ()-shutdown _ = return ()---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe Color.SingleFrame  -- ^ the screen frame to draw-        -> IO ()-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 -> 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 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.-keyTranslate :: Char -> K.Key-keyTranslate e =-  case e of-    -- Translate some special keys (use vi keys to move).-    '\ESC' -> K.Esc-    '\n'   -> K.Return-    '\r'   -> K.Return-    '\t'   -> K.Tab-    --  For bots: disable purely UI commands.-    'P'    -> K.Char 'U'-    'V'    -> K.Char 'Y'-    'O'    -> K.Char 'J'-    'I'    -> K.Char 'L'-    'R'    -> K.Char 'K'-    '?'    -> K.Char 'N'-    -- For bots: don't let them give up, write files, procrastinate.-    'Q'    -> K.Char 'H'-    'X'    -> K.Char 'B'-    'D'    -> K.Return-    '.'    -> K.Return-    -- For bots (assuming they go from '0' to 'z'): major commands.-    '<'    -> K.Char 'q'  -- ban ascending to speed up descending-    '>'    -> K.Char '>'-    'c'    -> K.Char 'c'-    'd'    -> K.Char 'r'  -- don't let bots drop stuff-    'g'    -> K.Char 'g'-    'i'    -> K.Char 'i'-    'o'    -> K.Char 'o'-    'q'    -> K.Char 'q'-    'r'    -> K.Char 'r'-    't'    -> K.Char 'g'  -- tagetting is too hard, so don't throw-    'z'    -> K.Char 'g'  -- and don't zap-    'p'    -> K.Char 'g'  -- and don't project-    'a'    -> K.Esc       -- and don't apply-    -- For bots: minor commands. Targeting is too hard, so don't do it.-    '*'    -> K.Char 'c'-    '/'    -> K.Char 'c'-    '['    -> K.Char 'g'-    ']'    -> K.Char 'g'-    '{'    -> K.Char 'g'-    '}'    -> K.Char 'g'-    -- Hack for bots: dump config at the start.-    ' '    -> K.Char 'D'-    -- Movement and hero selection.-    c | c `elem` "kjhlyubnKJHLYUBN" -> K.Char c-    c | c `elem` ['0'..'9'] -> K.Char c-    _      -> K.Char '>'  -- try hard to descend
− Game/LambdaHack/Display/Vty.hs 
@@ -1,135 +0,0 @@--- | Text frontend based on Vty.-module Game.LambdaHack.Display.Vty-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetKey-    -- * Frontend administration tools-  , frontendName, startup, shutdown-  ) where--import Graphics.Vty hiding (shutdown)-import qualified Graphics.Vty as Vty-import qualified Data.List as L-import qualified Data.ByteString.Char8 as BS--import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..))-import qualified Game.LambdaHack.Color as Color---- | Session data maintained by the frontend.-type FrontendSession = Vty---- | The name of the frontend.-frontendName :: String-frontendName = "vty"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = mkVty >>= k---- | Shuts down the frontend cleanly.-shutdown :: FrontendSession -> IO ()-shutdown = Vty.shutdown---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe Color.SingleFrame  -- ^ the screen frame to draw-        -> IO ()-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 sfTop)-              <-> img <->-              utf8_bytestring (setAttr Color.defaultAttr) (BS.pack sfBottom)-  in update vty pic---- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent sess mb = do-  e <- next_event sess-  case e of-    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.--- HSCurses does this by default, but in Vty you have to request the hack.-hack :: Color.Color -> Attr -> Attr-hack c a = if Color.isBright c then with_style a bold else a--setAttr :: Color.Attr -> Attr-setAttr Color.Attr{fg, bg} =--- This optimization breaks display for white background terminals:---  if (fg, bg) == Color.defaultAttr---  then def_attr---  else-  hack fg $ hack bg $-    def_attr { attr_fore_color = SetTo (aToc fg)-             , attr_back_color = SetTo (aToc bg) }--aToc :: Color.Color -> Color-aToc Color.Black     = black-aToc Color.Red       = red-aToc Color.Green     = green-aToc Color.Brown     = yellow-aToc Color.Blue      = blue-aToc Color.Magenta   = magenta-aToc Color.Cyan      = cyan-aToc Color.White     = white-aToc Color.BrBlack   = bright_black-aToc Color.BrRed     = bright_red-aToc Color.BrGreen   = bright_green-aToc Color.BrYellow  = bright_yellow-aToc Color.BrBlue    = bright_blue-aToc Color.BrMagenta = bright_magenta-aToc Color.BrCyan    = bright_cyan-aToc Color.BrWhite   = bright_white
Game/LambdaHack/Draw.hs view
@@ -12,9 +12,11 @@  import Game.LambdaHack.Msg import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (SingleFrame(..), Animation, rederAnim) import Game.LambdaHack.State import Game.LambdaHack.PointXY import Game.LambdaHack.Point+import Game.LambdaHack.Vector import Game.LambdaHack.Level import Game.LambdaHack.Effect import Game.LambdaHack.Perception@@ -40,7 +42,7 @@ -- | 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+     -> SingleFrame draw dm cops per s@State{ scursor=Cursor{..}                         , sflavour, slid, splayer, sdebug                         } overlay =@@ -48,12 +50,13 @@                , 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+      lvl@Level{lxsize, lysize, lsmell, ldesc, lactor, ltime, lclear, lseen} =+        slevel s+      (_, mpl@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+      (msgTop, over, msgBottom) = stringByLocation lxsize lysize overlay       (sSml, sVis) = case smarkVision of         Just Blind -> (True, True)         Just _  -> (False, True)@@ -80,8 +83,8 @@             tile = lvl `lAt` loc0             tk = tokind tile             items = lvl `liAt` loc0-            sm = IM.findWithDefault timeZero loc0 lsmell-            sml = sm `timeAdd` timeNegate ltime+            sml = IM.findWithDefault timeZero loc0 lsmell+            smlt = sml `timeAdd` timeNegate ltime             viewActor loc Actor{bkind = bkind2, bsymbol, bcolor}               | loc == bloc && slid == creturnLn =                   (symbol, Color.defBG)  -- highlight player@@ -91,11 +94,19 @@               color  = fromMaybe acolor  bcolor               symbol = fromMaybe asymbol bsymbol             rainbow loc = toEnum $ loc `rem` 14 + 1+            actorsHere = IM.elems lactor             (char, fg0) =-              case L.find (\ m -> loc0 == Actor.bloc m) (IM.elems lactor) of-                _ | ctargeting /= TgtOff-                    && slid == creturnLn-                    && L.elem loc0 bl ->+              case ( L.find (\ m -> loc0 == Actor.bloc m) actorsHere+                   , L.find (\ m -> clocation == Actor.bloc m) actorsHere ) of+                (_, actorTgt) | ctargeting /= TgtOff+                                && (slid == creturnLn+                                    && L.elem loc0 bl+                                    || (case actorTgt of+                                           Just (Actor{ btarget=TPath p+                                                      , bloc=prLoc }) ->+                                             L.elem loc0 $ shiftPath prLoc p+                                           _ -> False))+                    ->                       let unknownId = ouniqGroup "unknown space"                       in ('*', case (vis, F.Walkable `elem` tfeature tk) of                                  _ | tile == unknownId -> Color.BrBlack@@ -103,9 +114,9 @@                                  (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)+                (Just m, _) | somniscient || vis -> viewActor loc0 m+                _ | sSml && smlt > timeZero ->+                  (timeToDigit (smellTimeout s) smlt, rainbow loc0)                   | otherwise ->                   case items of                     [] -> (tsymbol tk, if vis then tcolor tk else tcolor2 tk)@@ -129,12 +140,22 @@         in case over pxy of              Just c -> Color.AttrChar Color.defaultAttr c              _      -> Color.AttrChar a char+      seenN = 100 * lseen `div` lclear+      seenTxt | seenN == 100 = "all"+              | otherwise = (reverse $ take 2 $ reverse $ " " ++ show seenN)+                            ++ "%"+      -- Indicate the actor is braced (was waiting last move).+      -- It's a useful feedback for the otherwise hard to observe+      -- 'wait' command.+      braceSign | braced mpl ltime = "{"+                | otherwise = " "       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 +++        take 31 (take 3 (show (Dungeon.levelNumber slid) ++ "  ")+                 ++ ldesc ++ repeat ' ') +++        take 12 ("[" ++ seenTxt ++ " seen]  ") +++        take 10 ("$: " ++ show wealth ++ repeat ' ') +++        take 12 ("Dmg: " ++ damage ++ repeat ' ') +++        take 14 (braceSign ++ "HP: " ++ show bhp ++                  " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ')       toWidth :: Int -> String -> String       toWidth n x = take n (x ++ repeat ' ')@@ -145,33 +166,15 @@         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{..}+      sfBottom = toWidth lxsize $ fromMaybe status msgBottom+  in SingleFrame{..}  -- | Render animations on top of the current screen frame.-animate :: State -> Diary -> Kind.COps -> Perception -> Color.Animation-        -> [Maybe Color.SingleFrame]+animate :: State -> Diary -> Kind.COps -> Perception -> Animation+        -> [Maybe SingleFrame] animate s Diary{sreport} cops per anim =-  let xsize = lxsize $ slevel s+  let Level{lxsize, lysize} = slevel s       over = renderReport sreport-      topLineOnly = padMsg xsize over+      topLineOnly = padMsg lxsize 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+  in rederAnim lxsize lysize basicFrame anim
Game/LambdaHack/DungeonState.hs view
@@ -101,6 +101,9 @@     placeStairs cotile cmap kc dplaces   let stairs = (su, upId) : if ln == depth then [] else [(sd, downId)]       lmap = cmap Kind.// stairs+      f !n !tk | Tile.isExplorable cotile tk = n + 1+               | otherwise = n+      lclear = Kind.foldlArray f 0 lmap   is <- rollItems cops ln depth kc lmap su   -- TODO: split this into Level.defaultLevel   let itemMap = mapToIMap cxsize ditem `IM.union` IM.fromList is@@ -120,6 +123,8 @@         , lmeta = dmeta         , lstairs = (su, sd)         , ltime = timeAdd timeTurn timeTurn  -- just stepped into the dungeon+        , lclear+        , lseen = 0         }   return level @@ -152,7 +157,7 @@             res = MState.evalState (findGenerator cops config k depth) g1         in (g2, (Dungeon.levelDefault k, res))       con :: R.StdGen -> (FreshDungeon, R.StdGen)-      con g =+      con g = assert (depth >= 1 `blame` depth) $         let (gd, levels) = L.mapAccumL gen g [1..depth]             entryLevel = Dungeon.levelDefault 1             entryLoc = fst (lstairs (snd (head levels)))
Game/LambdaHack/EffectAction.hs view
@@ -3,33 +3,28 @@ -- TODO: Add an export list and document after it's rewritten according to #17. module Game.LambdaHack.EffectAction where --- Cabal-import qualified Paths_LambdaHack as Self (version)- import Control.Monad import Control.Monad.State hiding (State, state) import Data.Function-import Data.Version import Data.Maybe import qualified Data.List as L import qualified Data.IntMap as IM import qualified Data.Set as S import qualified Data.IntSet as IS+import Data.Monoid  import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Action import Game.LambdaHack.Actor import Game.LambdaHack.ActorState 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 import Game.LambdaHack.Item import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Level+import Game.LambdaHack.Misc import Game.LambdaHack.Msg import Game.LambdaHack.Perception import Game.LambdaHack.Random@@ -40,8 +35,27 @@ import qualified Game.LambdaHack.Kind as Kind import Game.LambdaHack.DungeonState import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Animation (twirlSplash, blockHit, deathBody) import qualified Game.LambdaHack.Dungeon as Dungeon +-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: Rnd a -> Action a+rndToAction r = do+  g <- gets srandom+  let (a, ng) = runState r g+  modify (\ state -> state {srandom = ng})+  return a++-- | Update actor stats. Works for actors on other levels, too.+updateAnyActor :: ActorId -> (Actor -> Actor) -> Action ()+updateAnyActor actor f = modify (updateAnyActorBody actor f)++-- | Update player-controlled actor stats.+updatePlayerBody :: (Actor -> Actor) -> Action ()+updatePlayerBody f = do+  pl <- gets splayer+  updateAnyActor pl f+ -- TODO: instead of verbosity return msg components and tailor them outside? -- TODO: separately define messages for the case when source == target -- and for the other case; then use the messages outside of effectToAction,@@ -53,9 +67,9 @@ -- 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+effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int -> Bool                -> Action (Bool, Bool)-effectToAction effect verbosity source target power = do+effectToAction effect verbosity source target power block = do   oldTm <- gets (getActor target)   let oldHP = bhp oldTm   (b, msg) <- eff effect verbosity source target power@@ -69,8 +83,10 @@     tm  <- gets (getActor target)     per <- getPerception     pl  <- gets splayer-    let tloc = bloc tm-        sloc = bloc sm+    let sloc = bloc sm+        tloc = bloc tm+        svisible = sloc `IS.member` totalVisible per+        tvisible = tloc `IS.member` totalVisible per         newHP = bhp $ getActor target s     bb <-      if isAHero s source ||@@ -78,36 +94,23 @@         pl == source ||         pl == target ||         -- Target part of message shown below, so target visibility checked.-        tloc `IS.member` totalVisible per+        tvisible      then do       -- Party sees the effect or is affected by it.       msgAdd msg-      -- Try to show an animation.+      -- Try to show an animation. Sometimes, e.g., when HP is unchaged,+      -- the animation will not be shown.       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     = []+      let locs = (breturn tvisible tloc,+                  breturn svisible sloc)+          anim | newHP > oldHP =+            twirlSplash locs Color.BrBlue Color.Blue+               | newHP < oldHP && block =+            blockHit    locs Color.BrRed  Color.Red+               | newHP < oldHP && not block =+            twirlSplash locs Color.BrRed  Color.Red+               | otherwise = mempty           animFrs = animate s diary cops per anim       mapM_ displayFramePush $ Nothing : animFrs       return (b, True)@@ -116,7 +119,7 @@       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@.+    -- is shown below. It should have been shown in @eff@.     when (newHP <= 0) $ do       -- Place the actor's possessions on the map.       bitems <- gets (getActorItem target)@@ -147,7 +150,8 @@       return (True, actorVerb coactor tm "feel" "better") eff (Effect.Wound nDm) verbosity source target power = do   Kind.COps{coactor} <- getCOps-  n  <- rndToAction $ rollDice nDm+  s <- get+  n <- rndToAction $ rollDice nDm   if n + power <= 0 then nullEffect else do     void $ focusIfOurs target     pl <- gets splayer@@ -159,7 +163,7 @@             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+              if isProjectile s target               then actorVerb coactor tm "drop" "down"               else actorVerb coactor tm "die" ""           | source == target =  -- a potion of wounding, etc.@@ -175,10 +179,10 @@   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.+      -- Sync the monster with the hero move time for better display+      -- of missiles and for the domination to actually take one player's turn.       updatePlayerBody (\ m -> m { btime = stime s})       -- Display status line and FOV for the newly controlled actor.       fr <- drawPrompt ColorBW ""@@ -197,7 +201,7 @@ eff Effect.SummonFriend _ source target power = do   tm <- gets (getActor target)   s <- get-  if not $ isAMonster s source+  if isAHero s source     then summonHeroes (1 + power) (bloc tm)     else summonMonsters (1 + power) (bloc tm)   return (True, "")@@ -205,9 +209,9 @@   tm <- gets (getActor target)   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)+  if isAHero s source+    then summonMonsters (1 + power) (bloc tm)+    else summonHeroes (1 + power) (bloc tm)   return (True, "") eff Effect.ApplyPerfume _ source target _ =   if source == target@@ -231,7 +235,7 @@   -- 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+  return $ if maybe Camping snd (squit s2) == Victor     then (True, "")     else (True, actorVerb coactor tm "find" "a way upstairs") eff Effect.Descend _ source target power = do@@ -243,7 +247,7 @@     then squashActor source target     else effLvlGoUp (- (power + 1))   s2 <- get-  return $ if maybe H.Camping snd (squit s2) == H.Victor+  return $ if maybe Camping snd (squit s2) == Victor     then (True, "")     else (True, actorVerb coactor tm "find" "a way downstairs") @@ -262,7 +266,7 @@       verb = iverbApply $ okind h2hKind       msg = actorVerbActor coactor sm verb tm "in a staircase accident"   msgAdd msg-  itemEffectAction 0 source target h2h+  itemEffectAction 0 source target h2h False   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")) $@@ -318,9 +322,8 @@         modify (updateCursor (\ c -> c { creturnLn = nln }))         -- The invariant "at most one actor on a tile" restored.         -- Create a backup of the savegame.+        saveGameBkp         state <- get-        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.@@ -351,40 +354,40 @@   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)})+  modify (\ st -> st {squit = Just (False, Victor)})   if total == 0   then do     -- The player can back off at each of these steps.-    go1 <- displayMore ColorFull "Coward!"+    go1 <- displayMore ColorBW+             "Afraid of the challenge? Leaving so soon and empty-handed?"     when (not go1) $ abortWith "Brave soul!"-    go2 <- displayMore ColorFull-            "Next time try to grab some loot before escape!"+    go2 <- displayMore ColorBW+            "This 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+    let winMsg = "Congratulations, you won! Here's your loot, worth " +++                 show total ++ " gold."  -- 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)})+    tryIgnore $ displayOverAbort winMsg io+    modify (\ st -> st {squit = Just (True, 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 ()-itemEffectAction verbosity source target item = do+itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Bool -> Action ()+itemEffectAction verbosity source target item block = do   Kind.COps{coitem=Kind.Ops{okind}} <- getCOps-  sm <- gets (getActor source)+  st <- get   slidOld <- gets slid   let effect = ieffect $ okind $ jkind item   -- The msg describes the target part of the action.-  (b1, b2) <- effectToAction effect verbosity source target (jpower item)+  (b1, b2) <- effectToAction effect verbosity source target (jpower item) block   -- 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) $+  when (isProjectile st source) $     modify (deleteActor source)   modify (\ s -> s {slid = slidNew}) @@ -404,8 +407,9 @@     state2 <- get     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.+-- | Make the actor controlled by the player. Switch level, if needed.+-- False, if nothing to do. Should only be invoked as a direct result+-- of a player action or the selected player actor death. selectPlayer :: ActorId -> Action Bool selectPlayer actor = do   Kind.COps{coactor} <- getCOps@@ -430,20 +434,14 @@       msgAdd $ lookAt cops False True state lvl (bloc pbody) ""       return True +-- TODO: center screen, flash the background, etc. Perhaps wait for SPACE.+-- | Focus on the hero being wounded/displaced/etc. 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+    then return True     else return False  summonHeroes :: Int -> Point -> Action ()@@ -458,11 +456,17 @@  summonMonsters :: Int -> Point -> Action () summonMonsters n loc = do-  Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} <- getCOps-  mk <- rndToAction $ opick "summon" (const True)+  Kind.COps{ cotile+           , coactor=Kind.Ops{opick, okind}+           , cofact=Kind.Ops{opick=fopick, oname=foname}} <- getCOps+  bfaction <- rndToAction $ fopick "spawn" (const True)+  -- Spawn frequency required greater than zero, but otherwise ignored.+  let inFaction m = isJust $ lookup (foname bfaction) (afreq m)+  -- Summon frequency used for picking the actor.+  mk <- rndToAction $ opick "summon" inFaction   hp <- rndToAction $ rollDice $ ahp $ okind mk-  modify (\ state ->-           iterate (addMonster cotile mk hp loc) state !! n)+  modify (\ s -> iterate (addMonster cotile mk hp loc+                            bfaction False) s !! n)  -- | Remove dead heroes (or dead dominated monsters). Check if game is over. -- For now we only check the selected hero and at current level,@@ -470,7 +474,8 @@ -- on any level. checkPartyDeath :: Action () checkPartyDeath = do-  Kind.COps{coactor} <- getCOps+  cops@Kind.COps{coactor} <- getCOps+  per    <- getPerception   ahs    <- gets allHeroesAnyLevel   pl     <- gets splayer   pbody  <- gets getPlayerBody@@ -480,12 +485,23 @@     go <- displayMore ColorBW ""     recordHistory  -- Prevent repeating the "die" msgs.     let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"+        bodyToCorpse = updateAnyActor pl $ \ body -> body {bsymbol = Just '%'}+        animateDeath = do+          diary  <- getDiary+          s <- get+          let animFrs = animate s diary cops per $ deathBody (bloc pbody)+          mapM_ displayFramePush $ animFrs+        animateGameOver = do+          animateDeath+          bodyToCorpse+          gameOver go     if firstDeathEnds-      then gameOver go+      then animateGameOver       else case L.filter (/= pl) ahs of-             [] -> gameOver go+             [] -> animateGameOver              actor : _ -> do                msgAdd "The survivors carry on."+               animateDeath                -- One last look at the beautiful world.                remember                -- Remove the dead player.@@ -503,7 +519,7 @@ gameOver :: Bool -> Action () gameOver showEndingScreens = do   slid <- gets slid-  modify (\ st -> st {squit = Just (False, H.Killed slid)})+  modify (\ st -> st {squit = Just (False, Killed slid)})   when showEndingScreens $ do     Kind.COps{coitem} <- getCOps     s <- get@@ -524,15 +540,15 @@           "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+        loseMsg = failMsg ++ " You left " +++                  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)})+      then modify (\ st -> st {squit = Just (True, Killed slid)})       else do         io <- itemOverlay True True items         tryIgnore $ do           displayOverAbort loseMsg io-          modify (\ st -> st {squit = Just (True, H.Killed slid)})+          modify (\ st -> st {squit = Just (True, Killed slid)})  -- | Create a list of item names, split into many overlays. itemOverlay ::Bool -> Bool -> [Item] -> Action [Overlay]@@ -550,7 +566,6 @@ stopRunning :: Action () stopRunning = updatePlayerBody (\ p -> p { bdir = Nothing }) --- TODO: depending on tgt, show extra info about tile or monster or both -- | Perform look around in the current location of the cursor. doLook :: ActionFrame () doLook = do@@ -565,12 +580,10 @@   targeting <- gets (ctargeting . scursor)   assert (targeting /= TgtOff) $ do     let canSee = IS.member loc (totalVisible per)+        ihabitant | canSee = L.find (\ m -> bloc m == loc) (IM.elems hms)+                  | otherwise = Nothing         monsterMsg =-          if canSee-          then case L.find (\ m -> bloc m == loc) (IM.elems hms) of-                 Just m  -> actorVerb coactor m "be" "here" ++ " "-                 Nothing -> ""-          else ""+          maybe "" (\ m -> actorVerb coactor m "be" "here" ++ " ") ihabitant         vis | not $ loc `IS.member` totalVisible per =                 " (not visible)"  -- by party             | actorReachesLoc pl loc per (Just pl) = ""@@ -580,22 +593,13 @@                  TLoc _     -> "[targeting location" ++ vis ++ "] "                  TPath _    -> "[targeting path" ++ vis ++ "] "                  TCursor    -> "[targeting current" ++ vis ++ "] "-        -- general info about current loc+        -- Show 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+        -- 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+      then displayOverlays lookMsg "" io       else do         fr <- drawPrompt ColorFull lookMsg-        return ((), [Just fr])--gameVersion :: Action ()-gameVersion = do-  Kind.COps{corule} <- getCOps-  let pathsVersion = rpathsVersion $ Kind.stdRuleset corule-      msg = "Version " ++ showVersion pathsVersion-            ++ " (frontend: " ++ frontendName-            ++ ", engine: LambdaHack " ++ showVersion Self.version ++ ")"-  abortWith msg+        returnFrame fr
Game/LambdaHack/FOV/Digital.hs view
@@ -1,7 +1,9 @@ -- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>. -- This fast version of the algorithm, based on "PFOV", has AFAIK -- never been described nor implemented before.-module Game.LambdaHack.FOV.Digital (scan) where+module Game.LambdaHack.FOV.Digital+  ( scan, dline, dsteeper, intersect, debugSteeper, debugLine+  ) where  import Game.LambdaHack.Misc import Game.LambdaHack.Utils.Assert
Game/LambdaHack/FOV/Permissive.hs view
@@ -3,7 +3,9 @@ -- as implemented in Shadow.hs. In the result, this algorithm is much faster -- than the original algorithm on dense maps, since it does not scan -- areas blocked by shadows.-module Game.LambdaHack.FOV.Permissive (scan) where+module Game.LambdaHack.FOV.Permissive+  ( scan, dline, dsteeper, intersect, debugSteeper, debugLine+  ) where  import Game.LambdaHack.Misc import Game.LambdaHack.Utils.Assert
Game/LambdaHack/FOV/Shadow.hs view
@@ -69,7 +69,7 @@ -- is to be scanned. type Interval = (Rational, Rational) --- TODO: if every used, apply static argument transformation to isClear.+-- TODO: if ever used, apply static argument transformation to isClear. -- | Calculates the list of tiles, in @SBump@ coordinates, visible from (0, 0). scan :: (SBump -> Bool)  -- ^ clear tile predicate      -> Distance         -- ^ the current distance from (0, 0)
Game/LambdaHack/Feature.hs view
@@ -25,6 +25,6 @@    | Boring             -- ^ items and stairs can be generated there   | Exit               -- ^ is a (not hidden) door, stair, etc.-  | Path               -- ^ used for distinct paths throughout the level+  | Path               -- ^ used for visible paths throughout the level   | Secret !RollDice   -- ^ discovering the secret will require this many turns   deriving (Show, Read, Eq, Ord)
Game/LambdaHack/Grammar.hs view
@@ -3,7 +3,7 @@   ( -- * Grammar types     Verb, Object     -- * General operations-  , capitalize, pluralise, addIndefinite+  , capitalize, pluralise, addIndefinite, conjugate     -- * Objects from content   , objectItemCheat, objectItem, objectActor, capActor     -- * Sentences@@ -91,35 +91,45 @@ vowel :: Char -> Bool vowel l = l `elem` "aeio" +compound :: Bool -> (String -> String) -> String -> String+compound modifyFirst f phrase =+  let rev | modifyFirst = reverse+          | otherwise   = id+  in case rev $ words phrase of+       [] -> assert `failure` "compound: no words"+       word : rest -> unwords $ rev $ f word : rest+ -- | 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"+suffixS = compound False singleSuffixS --- TODO: a suffix tree would be best, to catch ableman, seaman, etc.+singleSuffixS :: String -> String+singleSuffixS 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"+ 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+pluralise = compound True singlePluralise +-- TODO: a suffix tree would be best, to catch ableman, seaman, etc.+singlePluralise :: Object -> Object+singlePluralise word =+  if word `S.member` noPlural+  then word+  else case M.lookup word irregularPlural of+    Just plural -> plural+    Nothing -> suffixS word+ conjugate :: String -> Verb -> Verb conjugate "you" "be" = "are" conjugate "You" "be" = "are"@@ -183,7 +193,7 @@ capActor coactor x = capitalize $ objectActor coactor x  -- | Sentences such as \"Dog barks loudly.\"-actorVerb :: Kind.Ops ActorKind -> Actor -> Verb  -> String-> String+actorVerb :: Kind.Ops ActorKind -> Actor -> Verb -> String -> String actorVerb coactor a v extra =   let cactor = capActor coactor a       verb = conjugate cactor v
− Game/LambdaHack/HighScore.hs 
@@ -1,161 +0,0 @@--- | High score table operations.-module Game.LambdaHack.HighScore-  ( Status(..), ScoreRecord(..), register-  ) where--import System.Directory-import Control.Monad-import Text.Printf-import System.Time-import Data.Binary-import qualified Data.List as L--import Game.LambdaHack.Utils.File-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,--- including build problems and opaque types that make serialization difficult,--- and I couldn't use Datetime because it needs old base (and is under GPL).--- TODO: When we finally move to Date.Time, let's take timezone into account,--- at least while displaying.--- | A single score record. Records are ordered in the highscore table,--- from the best to the worst, in lexicographic ordering wrt the fields below.-data ScoreRecord = ScoreRecord-  { points  :: !Int        -- ^ the score-  , negTime :: !Time       -- ^ game time spent (negated, so less better)-  , date    :: !ClockTime  -- ^ date of the last game interruption-  , status  :: !Status     -- ^ reason of the game interruption-  }-  deriving (Eq, Ord)---- | Current result of the game.-data Status =-    Killed !LevelId  -- ^ the player lost the game on the given level-  | Camping          -- ^ game is supended-  | Victor           -- ^ the player won-  deriving (Show, Eq, Ord)--instance Binary Status where-  put (Killed ln) = putWord8 0 >> put ln-  put Camping     = putWord8 1-  put Victor      = putWord8 2-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM Killed  get-      1 -> return Camping-      2 -> return Victor-      _ -> fail "no parse (Status)"--instance Binary ScoreRecord where-  put (ScoreRecord p n (TOD cs cp) s) = do-    put p-    put n-    put cs-    put cp-    put s-  get = do-    p <- get-    n <- get-    cs <- get-    cp <- get-    s <- get-    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 (pos, score) =-  let died = case status score of-        Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ ","-        Camping -> "is camping somewhere,"-        Victor -> "emerged victorious"-      curDate = calendarTimeToString . toUTCTime . date $ score-      big   = "                                                 "-      lil   = "              "-      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]---- | Empty score table-empty :: ScoreTable-empty = []---- | Name of the high scores file.-scoresFile :: Config.CP -> IO String-scoresFile config = Config.getFile config "files" "scoresFile"---- | Save a simple serialized version of the high scores table.-save :: Config.CP -> ScoreTable -> IO ()-save config scores = do-  f <- scoresFile config-  encodeEOF f scores---- | Read the high scores table. Return the empty table if no file.-restore :: Config.CP -> IO ScoreTable-restore config = do-  f <- scoresFile config-  b <- doesFileExist f-  if not b-    then return empty-    else strictDecodeEOF f---- | Insert a new score into the table, Return new table and the ranking.-insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)-insertPos s h =-  let (prefix, suffix) = L.span (> s) h-  in (prefix ++ [s] ++ suffix, L.length prefix + 1)---- | Show a screenful of the high scores table.--- Parameter height is the number of (3-line) scores to be shown.-showTable :: ScoreTable -> Int -> Int -> Overlay-showTable h start height =-  let zipped    = zip [1..] h-      screenful = take height . drop (start - 1) $ zipped-  in concatMap showScore screenful---- | Produce a couple of renderings of the high scores table.-slideshow :: Int -> ScoreTable -> Int -> [Overlay]-slideshow pos h height =-  if pos <= height-  then [showTable h 1 height]-  else [showTable h 1 height,-        showTable h (max (height + 1) (pos - height `div` 2)) height]---- | 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, [Overlay])-register config write s = do-  h <- restore config-  let (h', pos) = insertPos s h-      (_, nlines) = normalLevelBound  -- TODO: query terminal size instead-      height = nlines `div` 3-      (msgCurrent, msgUnless) =-        case status s of-          Killed _ -> (" short-lived", " (score halved)")-          Camping  -> (" current", " (unless you are slain)")-          Victor   -> (" glorious",-                        if pos <= height-                        then " among the greatest heroes"-                        else "")-      msg = printf "Your%s exploits award you place >> %d <<%s."-              msgCurrent pos msgUnless-  when write $ save config h'-  return (msg, slideshow pos h' height)
Game/LambdaHack/Item.hs view
@@ -88,9 +88,9 @@ -- | The type of already discovered items. type Discoveries = S.Set (Kind.Id ItemKind) +-- TODO: rewrite and move elsewhere -- Could be optimized to IntMap and IntSet, but won't ever be a bottleneck, -- unless we have thousands of item kinds.--- TODO: rewrite and move elsewhere -- | Flavours assigned to items in this game. type FlavourMap = M.Map (Kind.Id ItemKind) Flavour
Game/LambdaHack/ItemAction.hs view
@@ -28,15 +28,19 @@ import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Time +-- TODO: When inventory is displayed, let TAB switch the player (without+-- announcing that) and show the inventory of the new player. -- | Display inventory inventory :: ActionFrame () inventory = do+  Kind.COps{coactor} <- getCOps+  pbody <- gets getPlayerBody   items <- gets getPlayerItem   if L.null items-    then abortWith "Not carrying anything."+    then abortWith $ actorVerb coactor pbody "be" "not carrying anything"     else do       io <- itemOverlay True False items-      displayOverlays "Carrying:" io+      displayOverlays (init $ actorVerb coactor pbody "be" "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,@@ -68,7 +72,7 @@       loc = bloc body   removeFromInventory actor consumed loc   when (loc `IS.member` totalVisible per) $ msgAdd msg-  itemEffectAction 5 actor actor consumed+  itemEffectAction 5 actor actor consumed False  playerApplyGroupItem :: Verb -> Object -> [Char] -> Action () playerApplyGroupItem verb object syms = do@@ -95,14 +99,14 @@   ceps  <- gets (ceps . scursor)   lxsize <- gets (lxsize . slevel)   lysize <- gets (lysize . slevel)+  sfaction <- gets sfaction   let consumed = item { jcount = 1 }       sloc = bloc sm-      sourceVis = sloc `IS.member` totalVisible per+      svisible = sloc `IS.member` totalVisible per       subject =-        if sourceVis+        if svisible         then sm-        else template (heroKindId coactor)-               Nothing (Just "somebody") 99 sloc timeZero animalParty+        else sm {bname = Just "somebody"}       -- 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.@@ -114,14 +118,15 @@       -- 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.+      -- When the monster faction has its selected player, hero 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)+      btimeDelta = timeAddFromSpeed coactor sm btime+      time =+        if bfaction sm == sfaction || source == pl+        then btimeDelta `timeAdd` timeNegate timeClip+        else btime       bl = bla lxsize lysize eps sloc tloc   case bl of     Nothing -> abortWith "cannot zap oneself"@@ -132,18 +137,18 @@       inhabitants <- gets (locToActor loc)       if accessible cops lvl sloc loc && isNothing inhabitants         then-          modify $ addProjectile cops consumed loc party path time+          modify $ addProjectile cops consumed loc (bfaction sm) path time         else           abortWith "blocked"-      when (sourceVis || projVis) $ msgAdd msg+      when (svisible || projVis) $ msgAdd msg  playerProjectGroupItem :: Verb -> Object -> [Char] -> ActionFrame () playerProjectGroupItem verb object syms = do   ms     <- gets hostileList   lxsize <- gets (lxsize . slevel)+  lysize <- gets (lysize . slevel)   ploc   <- gets (bloc . getPlayerBody)-  if L.any (adjacent lxsize ploc) $ L.map bloc $-       L.filter (\ m -> bparty m `notElem` allProjectiles) ms+  if foesAdjacent lxsize lysize ploc ms     then abortWith "You can't aim in melee."     else playerProjectGI verb object syms @@ -159,7 +164,7 @@         modify (updateCursor upd)         frs <- targetMonster TgtAuto         -- Mark that unexpectedly it does not take time.-        modify (\ s -> s {snoTime = True})+        modify (\ s -> s {stakeTime = Just False})         return frs   case targetToLoc (totalVisible per) state ploc of     Just loc -> do@@ -178,7 +183,8 @@ targetMonster tgtMode = do   pl        <- gets splayer   ploc      <- gets (bloc . getPlayerBody)-  ms        <- gets (hostileAssocs . slevel)+  sfaction <- gets sfaction+  ms        <- gets (hostileAssocs sfaction . slevel)   per       <- getPerception   lxsize    <- gets (lxsize . slevel)   target    <- gets (btarget . getPlayerBody)@@ -255,7 +261,8 @@   target   <- gets (btarget . getPlayerBody)   per      <- getPerception   cloc     <- gets (clocation . scursor)-  ms       <- gets (hostileAssocs . slevel)+  sfaction <- gets sfaction+  ms       <- gets (hostileAssocs sfaction . 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.@@ -297,12 +304,12 @@  -- | Cancel something, e.g., targeting mode, resetting the cursor -- to the position of the player. Chosen target is not invalidated.-cancelCurrent :: Action ()-cancelCurrent = do+cancelCurrent :: ActionFrame () -> ActionFrame ()+cancelCurrent h = do   targeting <- gets (ctargeting . scursor)   if targeting /= TgtOff-    then endTargeting False-    else abortWith "Press Q to quit."+    then inFrame $ endTargeting False+    else h  -- nothing to cancel right now, treat this as a command invocation  -- | Accept something, e.g., targeting mode, keeping cursor where it was. -- Or perform the default action, if nothing needs accepting.@@ -311,7 +318,11 @@   targeting <- gets (ctargeting . scursor)   if targeting /= TgtOff     then inFrame $ endTargeting True-    else h  -- nothing to accept right now+    else h  -- nothing to accept right now, treat this as a command invocation++-- | Clear current messages, show the next screen if any.+clearCurrent :: Action ()+clearCurrent = return ()  -- | Drop a single item. dropItem :: Action ()
Game/LambdaHack/Key.hs view
@@ -19,6 +19,7 @@   | Return   | Space   | Tab+  | BackTab   | PgUp   | PgDn   | Left@@ -39,22 +40,24 @@   | NoModifier   deriving (Ord, Eq) +-- Common and terse names for keys. showKey :: Key -> String showKey (Char c) = [c]-showKey Esc      = "ESC"  -- these three are common and terse abbreviations+showKey Esc      = "ESC" showKey Return   = "RET" showKey Space    = "SPACE" showKey Tab      = "TAB"-showKey PgUp     = "<page-up>"-showKey PgDn     = "<page-down>"-showKey Left     = "<left>"-showKey Right    = "<right>"-showKey Up       = "<up>"-showKey Down     = "<down>"-showKey End      = "<end>"-showKey Begin    = "<begin>"-showKey Home     = "<home>"-showKey (KP c)   = "<KeyPad " ++ [c] ++ ">"+showKey BackTab  = "SHIFT-TAB"+showKey PgUp     = "PGUP"+showKey PgDn     = "PGDOWN"+showKey Left     = "LEFT"+showKey Right    = "RIGHT"+showKey Up       = "UP"+showKey Down     = "DOWN"+showKey End      = "END"+showKey Begin    = "BEGIN"+showKey Home     = "HOME"+showKey (KP c)   = "KEYPAD(" ++ [c] ++ ")" showKey (Unknown s) = s  -- | Show a key with a modifier, if any.@@ -145,6 +148,7 @@ keyTranslate "Return"        = Return keyTranslate "space"         = Space keyTranslate "Tab"           = Tab+keyTranslate "ISO_Left_Tab"  = BackTab keyTranslate "KP_Up"         = Up keyTranslate "KP_Down"       = Down keyTranslate "KP_Left"       = Left
Game/LambdaHack/Kind.hs view
@@ -4,27 +4,30 @@   ( -- * General content types     Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset     -- * Arrays of content identifiers-  , Array, (!), (//), listArray, array, bounds+  , Array, (!), (//), listArray, array, bounds, foldlArray   ) where  import Data.Binary import qualified Data.List as L import qualified Data.IntMap as IM+import qualified Data.Map as M import qualified Data.Word as Word import qualified Data.Array.Unboxed as A import qualified Data.Ix as Ix-import Data.Maybe  import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.Frequency import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.StrategyKind import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Content+import Game.LambdaHack.CDefs import Game.LambdaHack.Random+import Game.LambdaHack.Misc  -- | Content identifiers for the content type @c@. newtype Id c = Id Word8 deriving (Show, Eq, Ord, Ix.Ix)@@ -48,10 +51,10 @@   , oname :: Id a -> String       -- ^ the name of a content element at id   , okind :: Id a -> a            -- ^ the content element at given id   , ouniqGroup :: String -> Id a  -- ^ the id of the unique member of-                                  -- a singleton content group+                                  --   a singleton content group   , opick :: String -> (a -> Bool) -> Rnd (Id a)                                   -- ^ pick a random id belonging to a group-                                  -- and satisfying a predicate+                                  --   and satisfying a predicate   , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b                                   -- ^ fold over all content elements of @a@   , obounds :: (Id a, Id a)       -- ^ bounds of identifiers of content @a@@@ -66,12 +69,15 @@       kindAssocs = L.zip [0..] content       kindMap :: IM.IntMap a       kindMap = IM.fromDistinctAscList $ L.zip [0..] content-      groupFreq group k = fromMaybe 0 (L.lookup group $ getFreq k)-      kindFreq :: String -> Frequency (Id a, a)-      kindFreq group =-        toFreq ("kindFreq ('" ++ group ++ "')")-               [ (n, (Id i, k))-               | (i, k) <- kindAssocs, let n = groupFreq group k, n > 0 ]+      kindFreq :: M.Map String (Frequency (Id a, a))+      kindFreq =+        let tuples = [ (group, (n, (Id i, k)))+                     | (i, k) <- kindAssocs+                     , (group, n) <- getFreq k, n > 0 ]+            f m (group, nik) = M.insertWith (++) group [nik] m+            lists =  L.foldl' f M.empty tuples+            nameFreq group = toFreq $ "opick ('" ++ group ++ "')"+        in M.mapWithKey nameFreq lists       okind (Id i) = kindMap IM.! fromEnum i       correct a = not (L.null (getName a)) && L.all ((> 0) . snd) (getFreq a)       offenders = validate content@@ -82,11 +88,15 @@        , oname = getName . okind        , okind = okind        , ouniqGroup = \ group ->-           case [Id i | (i, k) <- kindAssocs, groupFreq group k > 0] of-             [i] -> i+           case runFrequency $ kindFreq M.! group of+             [(n, (i, _))] | n > 0 -> i              l -> assert `failure` l-       , opick = \ group p ->-           fmap fst $ frequency $ filterFreq (p . snd) $ kindFreq group+       , opick = \ group p -> frequency $ do+           (i, k) <- kindFreq M.! group+           breturn (p k) i+           {- with MonadComprehensions:+           frequency [ i | (i, k) <- kindFreq M.! group, p k ]+           -}        , ofoldrWithKey = \ f z -> L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs        , obounds =          let limits = let (i1, a1) = IM.findMin kindMap@@ -100,9 +110,11 @@ data COps = COps   { coactor :: !(Ops ActorKind)   , cocave  :: !(Ops CaveKind)+  , cofact  :: !(Ops FactionKind)   , coitem  :: !(Ops ItemKind)   , coplace :: !(Ops PlaceKind)   , corule  :: !(Ops RuleKind)+  , costrat :: !(Ops StrategyKind)   , cotile  :: !(Ops TileKind)   } @@ -113,9 +125,10 @@ instance Show COps where   show _ = "Game content." --- | Arrays, indexed by type @i@ of content identifiers pointing to--- content type @c@, where the identifiers are represented as @Word8@+-- | Arrays of content identifiers pointing to the content type @c@,+-- where the identifiers are represented as @Word8@ -- (and so content of type @c@ can have at most 256 elements).+-- The arrays are indexed by type @i@, e.g., a dungeon tile location. newtype Array i c = Array (A.UArray i Word.Word8) deriving Show  -- TODO: save/restore is still too slow, but we are already past@@ -144,3 +157,9 @@ -- | Content identifiers array bounds. bounds :: Ix.Ix i => Array i c -> (i, i) bounds (Array a) = A.bounds a++-- | Fold left strictly over an array.+foldlArray :: Ix.Ix i => (a -> Id c -> a) -> a -> Array i c -> a+foldlArray f z0 (Array a) = lgo z0 $ A.elems a+ where lgo z []       = z+       lgo z (x : xs) = let fzx = f z (Id x) in fzx `seq` lgo fzx xs
Game/LambdaHack/Level.hs view
@@ -61,6 +61,8 @@   , 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+  , lclear    :: Int             -- ^ total number of clear tiles+  , lseen     :: Int             -- ^ number of clear tiles already seen   }   deriving Show @@ -96,7 +98,8 @@   in  updateIMap (IM.alter adj loc)  instance Binary Level where-  put (Level ad ia sx sy ls le li lm lrm ld lme lstairs ltime) = do+  put (Level ad ia sx sy ls le li lm lrm ld+             lme lstairs ltime lclear lseen) = do     put ad     put ia     put sx@@ -113,6 +116,8 @@     put lme     put lstairs     put ltime+    put lclear+    put lseen   get = do     ad <- get     ia <- get@@ -127,7 +132,10 @@     lme <- get     lstairs <- get     ltime <- get-    return (Level ad ia sx sy ls le li lm lrm ld lme lstairs ltime)+    lclear <- get+    lseen <- get+    return (Level ad ia sx sy ls le li lm lrm ld+                  lme lstairs ltime lclear lseen)  -- | Query for actual and remembered tile kinds on the map. at, rememberAt :: Level -> Point -> Kind.Id TileKind@@ -180,9 +188,10 @@            -> TileMap                              -- ^ look up in this map            -> [Point -> Kind.Id TileKind -> Bool]  -- ^ predicates to satisfy            -> Rnd Point-findLocTry _        lmap [p] = findLoc lmap p-findLocTry numTries lmap l   = assert (numTries > 0) $-  let search 0 = findLocTry numTries lmap (L.tail l)+findLocTry _        lmap []        = findLoc lmap (const (const True))+findLocTry _        lmap [p]       = findLoc lmap p+findLocTry numTries lmap l@(_ : tl) = assert (numTries > 0) $+  let search 0 = findLocTry numTries lmap tl       search k = do         loc <- randomR $ Kind.bounds lmap         let tile = lmap Kind.! loc
Game/LambdaHack/Misc.hs view
@@ -1,8 +1,10 @@ -- | Hacks that haven't found their home yet. module Game.LambdaHack.Misc-  ( normalLevelBound, divUp, Freqs+  ( normalLevelBound, divUp, Freqs, breturn   ) where +import Control.Monad+ -- | Level bounds. TODO: query terminal size instead and scroll view. normalLevelBound :: (Int, Int) normalLevelBound = (79, 21)@@ -15,3 +17,8 @@ -- in the first component of a pair, the second component of a pair shows -- how common the kind is within the group. type Freqs = [(String, Int)]++-- | @breturn b a = [a | b]@+breturn :: MonadPlus m => Bool -> a -> m a+breturn True a  = return a+breturn False _ = mzero
Game/LambdaHack/Msg.hs view
@@ -22,11 +22,11 @@  -- | The \"press something to see more\" mark. moreMsg :: Msg-moreMsg = " --more--  "+moreMsg = "--more--  "  -- | The confirmation request message. yesnoMsg :: Msg-yesnoMsg = " [yn]"+yesnoMsg = "[yn]"  -- | Add spaces at the message end, for display overlayed over the level map. -- Also trims (does not wrap!) too long lines.@@ -153,13 +153,18 @@                          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)+-- string by location. Takes the width and height of the display plus+-- the string. Returns also the message to print at the top and bottom.+stringByLocation :: X -> Y -> Overlay+                 -> (String, PointXY -> Maybe Char, Maybe String)+stringByLocation _ _ [] = ("", const Nothing, 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)+      msgBottom = case drop lysize ls of+                  [] -> Nothing+                  s : _ -> Just s+  in (msgTop,+      \ (PointXY (x, y)) -> IM.lookup y m >>= \ n -> IM.lookup x n,+      msgBottom)
Game/LambdaHack/Perception.hs view
@@ -2,7 +2,7 @@ module Game.LambdaHack.Perception   ( DungeonPerception, Perception   , totalVisible, debugTotalReachable, dungeonPerception-  , actorReachesLoc, actorReachesActor, monsterSeesHero+  , actorReachesLoc, actorReachesActor, actorSeesActor   ) where  import qualified Data.IntSet as IS@@ -11,6 +11,7 @@ import Data.Maybe import Control.Monad +import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Point import Game.LambdaHack.State import Game.LambdaHack.Level@@ -98,6 +99,15 @@   in sloc `IS.member` preachable      && isVisible cotile reachable lvl IS.empty tloc +-- | Whether an actor can see another. An approximation.+actorSeesActor :: Kind.Ops TileKind -> Perception -> Level+               -> ActorId -> ActorId -> Point -> Point -> ActorId -> Bool+actorSeesActor cotile per lvl source target sloc tloc pl =+  let heroReaches = actorReachesLoc source tloc per (Just pl)+      visByHeroes = tloc `IS.member` totalVisible per+      monsterSees = monsterSeesHero cotile per lvl source target sloc tloc+  in  heroReaches && visByHeroes || monsterSees+ -- | Calculate the perception of all actors on the level. dungeonPerception :: Kind.COps -> State -> DungeonPerception dungeonPerception cops s@State{slid, sdungeon} =@@ -109,13 +119,15 @@ levelPerception cops@Kind.COps{cotile}                        state@State{ splayer                                   , sconfig+                                  , sfaction                                   , 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"+                  then assert `failure`+                         "FOV radius is " ++ show r ++ ", should be >= 1"                   else r       -- Perception for a player-controlled monster on the current level.       mLocPer =@@ -125,7 +137,7 @@                       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+      hs = IM.filter (\ m -> bfaction m == sfaction && not (bproj m)) lactor       pers = IM.map (\ h ->                       computeReachable cops radius mode smarkVision h lvl) hs       locs = map bloc $ IM.elems hs@@ -185,7 +197,7 @@             "shadow"     -> Shadow             "permissive" -> Permissive             "digital"    -> Digital radius-            _            -> error $ "Unknown FOV mode: " ++ show mode+            _            -> assert `failure` "Unknown FOV mode: " ++ show mode       ploc = bloc actor   in PerceptionReachable $        IS.insert ploc $ IS.fromList $ fullscan cotile (fovMode actor) ploc lvl
Game/LambdaHack/Place.hs view
@@ -147,7 +147,7 @@ tilePlace :: Area                           -- ^ the area to fill           -> PlaceKind                      -- ^ the place kind to construct           -> M.Map PointXY Char-tilePlace (x0, y0, x1, y1) PlaceKind{..} =+tilePlace (x0, y0, x1, y1) pl@PlaceKind{..} =   let dx = x1 - x0 + 1       dy = y1 - y0 + 1       fromX (x, y) = L.map PointXY $ L.zip [x..] (repeat y)@@ -164,11 +164,13 @@       interior = case pcover of         CAlternate ->           let tile :: Int -> [a] -> [a]+              tile _ []  = assert `failure` pl               tile d pat =                 L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat))           in fillInterior tile         CStretch ->           let stretch :: Int -> [a] -> [a]+              stretch _ []  = assert `failure` pl               stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat))           in fillInterior stretch         CReflect ->
Game/LambdaHack/Point.hs view
@@ -24,7 +24,7 @@ -- mainly as keys and not constructed often, so the performance will improve -- due to smaller save files, the use of @IntMap@ and cheaper array indexing, -- including cheaper bounds checks.--- We don't defin @Point@ as a newtype to avoid the trouble+-- We don't define @Point@ as a newtype to avoid the trouble -- with using @EnumMap@ in place of @IntMap@, etc. type Point = Int
Game/LambdaHack/Running.hs view
@@ -9,6 +9,7 @@  import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Action+import Game.LambdaHack.EffectAction import Game.LambdaHack.Actions import Game.LambdaHack.Point import Game.LambdaHack.Vector@@ -39,7 +40,7 @@     then do       frs <- moveCursor dir 10       -- Mark that unexpectedly it does not take time.-      modify (\ s -> s {snoTime = True})+      modify (\ s -> s {stakeTime = Just False})       return frs     else do       let accessibleDir loc d = accessible cops lvl loc (loc `shift` d)@@ -160,7 +161,8 @@   per <- getPerception   Diary{sreport} <- getDiary   ms  <- gets dangerousList-  hs  <- gets friendlyList+  sfaction <- gets sfaction+  hs <- gets (factionList [sfaction])   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
− Game/LambdaHack/Save.hs 
@@ -1,152 +0,0 @@--- | Saving and restoring games and player diaries.-module Game.LambdaHack.Save-  ( 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-import qualified Game.LambdaHack.Config as Config---- | Name of the save game.-saveFile :: Config.CP -> IO FilePath-saveFile config = Config.getFile config "files" "saveFile"---- | Name of the backup of the save game.-bkpFile :: Config.CP -> IO FilePath-bkpFile config = do-  sfile <- saveFile config-  return $ sfile ++ ".bkp"---- | Name of the persistent player diary.-diaryFile :: Config.CP -> IO FilePath-diaryFile config = Config.getFile config "files" "diaryFile"---- | Save a simple serialized version of the current player diary.-saveDiary :: State -> Diary -> IO ()-saveDiary state diary = do-  dfile <- diaryFile (sconfig state)-  encodeEOF dfile diary--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-  takeMVar saveLock---- | Try to create a directory. Hide errors due to,--- e.g., insufficient permissions, because the game can run--- in the current directory just as well.-tryCreateDir :: FilePath -> IO ()-tryCreateDir dir =-  E.catch-    (createDirectory dir)-    (\ e -> case e :: E.IOException of _ -> return ())---- TODO: perhaps take the target "scores" file name from config.--- TODO: perhaps source and "config", too, to be able to change all--- in one place.--- | Try to copy over data files. Hide errors due to,--- e.g., insufficient permissions, because the game can run--- without data files just as well.-tryCopyDataFiles :: (FilePath -> IO FilePath) -> FilePath -> IO ()-tryCopyDataFiles pathsDataFile dirNew = do-  configFile <- pathsDataFile "config.default"-  scoresFile <- pathsDataFile "scores"-  let configNew = combine dirNew "config"-      scoresNew = combine dirNew "scores"-  E.catch-    (copyFile configFile configNew >>-     copyFile scoresFile scoresNew)-    (\ e -> case e :: E.IOException of _ -> return ())---- | Restore a saved game, if it exists. Initialize directory structure,--- if needed.-restoreGame :: (FilePath -> IO FilePath) -> Config.CP -> String-            -> IO (Either (State, Diary) (String, Diary))-restoreGame pathsDataFile config title = do-  appData <- Config.appDataDir-  ab <- doesDirectoryExist appData-  -- If the directory can't be created, the current directory will be used.-  unless ab $ do-    tryCreateDir appData-    -- 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-       if db-         then strictDecodeEOF dfile-         else defaultDiary-  -- If the savefile exists but we get IO errors, we show them,-  -- back up the savefile and move it out of the way and start a new game.-  -- If the savefile was randomly corrupted or made read-only,-  -- that should solve the problem. If the problems are more serious,-  -- the other functions will most probably also throw exceptions,-  -- this time without trying to fix it up.-  sfile <- saveFile config-  sb <- doesFileExist sfile-  if sb-    then E.catch-      (do mvBkp config-          bfile <- bkpFile config-          state <- strictDecodeEOF bfile-          return $ Left (state, diary))-      (\ e -> case e :: E.SomeException of-                _ -> let msg = "Starting a new game, because restore failed. "-                               ++ "The error message was: "-                               ++ (unwords . lines) (show e)-                     in return $ Right (msg, diary))-    else-      return $ Right ("Welcome to " ++ title ++ "!", diary)---- | Move the savegame file to a backup slot.-mvBkp :: Config.CP -> IO ()-mvBkp config = do-  sfile <- saveFile config-  bfile <- bkpFile config-  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-  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 
@@ -1,67 +0,0 @@--- | Setting up game data and restoring or starting a game.-module Game.LambdaHack.Start ( start ) where--import qualified Control.Monad.State as MState-import qualified Data.Array.Unboxed as A--import Game.LambdaHack.Action-import Game.LambdaHack.State-import qualified Game.LambdaHack.DungeonState as DungeonState-import qualified Game.LambdaHack.Save as Save-import Game.LambdaHack.Turn-import qualified Game.LambdaHack.Config as Config-import Game.LambdaHack.ActorState-import Game.LambdaHack.Item-import qualified Game.LambdaHack.Feature as F-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Tile-import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Msg--speedup :: Kind.Ops TileKind -> Kind.Speedup TileKind-speedup Kind.Ops{ofoldrWithKey, obounds} =-  let createTab :: (TileKind -> Bool) -> A.UArray (Kind.Id TileKind) Bool-      createTab p =-        let f _ k acc = p k : acc-            clearAssocs = ofoldrWithKey f []-        in A.listArray obounds clearAssocs-      tabulate :: (TileKind -> Bool) -> Kind.Id TileKind -> Bool-      tabulate p = (createTab p A.!)-      isClearTab = tabulate $ kindHasFeature F.Clear-      isLitTab   = tabulate $ kindHasFeature F.Lit-  in Kind.TileSpeedup {isClearTab, isLitTab}---- | Compute and insert auxiliary optimized components into game content,--- to be used in time-critical sections of the code.-speedupCops :: Session -> Session-speedupCops sess@Session{scops = cops@Kind.COps{cotile=tile}} =-  let ospeedup = speedup tile-      cotile = tile {Kind.ospeedup}-      scops = cops {Kind.cotile}-  in sess {scops}---- | Either restore a saved game, or setup a new game.--- Then call the main game loop.-start :: Config.CP -> Session -> IO ()-start config1 slowSess = do-  let sess@Session{scops = cops@Kind.COps{corule}} = speedupCops slowSess-      title = rtitle $ Kind.stdRuleset corule-      pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule-  restored <- Save.restoreGame pathsDataFile config1 title-  case restored of-    Right (msg, diary) -> do  -- Starting a new game.-      (g2, config2) <- Config.getSetGen config1 "dungeonRandomGenerator"-      let (DungeonState.FreshDungeon{..}, ag) =-            MState.runState (DungeonState.generate cops config2) g2-          sflavour = MState.evalState (dungeonFlavourMap (Kind.coitem cops)) ag-      (g3, config3) <- Config.getSetGen config2 "startingRandomGenerator"-      let state = defaultState-                    config3 sflavour freshDungeon entryLevel entryLoc g3-          hstate = initialHeroes cops entryLoc state-      handlerToIO sess hstate diary{sreport = singletonReport msg} handleTurn-    Left (state, diary) ->  -- Running a restored a game.-      handlerToIO sess state-        -- This overwrites the "Really save/quit?" messages.-        diary{sreport = singletonReport $ "Welcome back to " ++ title ++ "."}-        handleTurn
Game/LambdaHack/State.hs view
@@ -1,7 +1,7 @@ -- | Game state and persistent player diary types and operations. module Game.LambdaHack.State   ( -- * Game state-    State(..), TgtMode(..), Cursor(..)+    State(..), TgtMode(..), Cursor(..), Status(..)     -- * Accessor   , slevel, stime     -- * Constructor@@ -28,21 +28,27 @@ import Game.LambdaHack.Msg import Game.LambdaHack.FOV import Game.LambdaHack.Time-import qualified Game.LambdaHack.HighScore as H+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Content.FactionKind --- | The diary contains all the player data--- that carries over from game to game.--- That includes the last message, previous messages and otherwise recorded--- history of past games. This can be used for calculating player--- achievements, unlocking advanced game features and general data mining.+-- | The diary contains all the player data that carries over+-- from game to game, even across playing sessions. That includes+-- the last message, previous messages and otherwise recorded+-- history of past games. This can be extended with other data and used for+-- calculating player achievements, unlocking advanced game features and+-- for general data mining, e.g., augmenting AI or procedural content+-- generation. data Diary = Diary-  { sreport     :: Report+  { sreport  :: Report   , shistory :: History   } --- | The state of a single game that can be save and restored.--- In practice, we maintain some extra state, but it's--- temporary for a single turn or relevant only to the current session.+-- TODO: stakeTime and squit are also temporary, move them to+-- DungeonPerception and rename it to TurnCache, if more appear, e.g. AI stuff.+-- | The state of a single game that can be saved and restored.+-- It's completely disregarded and reset when a new game is started.+-- In practice, we maintain some extra state (DungeonPerception),+-- but it's only temporary, existing for a single turn and then invalidated. data State = State   { splayer  :: ActorId      -- ^ represents the player-controlled actor   , scursor  :: Cursor       -- ^ cursor location and level to return to@@ -52,9 +58,10 @@   , slid     :: Dungeon.LevelId  -- ^ identifier of the current level   , 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+  , sconfig  :: Config.CP    -- ^ this game's config (including initial RNG)+  , stakeTime :: Maybe Bool  -- ^ last command unexpectedly took some time+  , squit    :: Maybe (Bool, Status)  -- ^ cause of game end/exit+  , sfaction :: Kind.Id FactionKind   -- ^ our faction   , sdebug   :: DebugMode    -- ^ debugging mode   }   deriving Show@@ -76,6 +83,14 @@   }   deriving Show +-- | Current result of the game.+data Status =+    Killed !Dungeon.LevelId  -- ^ the player lost the game on the given level+  | Camping                  -- ^ game is supended+  | Victor                   -- ^ the player won+  | Restart                  -- ^ the player quits and starts a new game+  deriving (Show, Eq, Ord)+ data DebugMode = DebugMode   { smarkVision :: Maybe FovMode   , somniscient :: Bool@@ -102,9 +117,10 @@     }  -- | Initial game state.-defaultState :: Config.CP -> FlavourMap -> Dungeon.Dungeon -> Dungeon.LevelId-             -> Point -> R.StdGen -> State-defaultState config flavour dng lid ploc g =+defaultState :: Config.CP -> Kind.Id FactionKind -> FlavourMap+             -> Dungeon.Dungeon -> Dungeon.LevelId -> Point -> R.StdGen+             -> State+defaultState config sfaction flavour dng lid ploc g =   State     0  -- hack: the hero is not yet alive     (Cursor TgtOff lid ploc lid 0)@@ -115,8 +131,9 @@     0     g     config-    False     Nothing+    Nothing+    sfaction     defaultDebugMode  defaultDebugMode :: DebugMode@@ -169,7 +186,7 @@  instance Binary State where   put (State player cursor flav disco dng lid ct-         g config snoTime _ _) = do+         g config stakeTime _ sfaction _) = do     put player     put cursor     put flav@@ -179,7 +196,8 @@     put ct     put (show g)     put config-    put snoTime+    put stakeTime+    put sfaction   get = do     player <- get     cursor <- get@@ -189,12 +207,25 @@     lid    <- get     ct     <- get     g      <- get-    config  <- get-    snoTime <- get+    config   <- get+    stakeTime  <- get+    sfaction <- get     return-      (State player cursor flav disco dng lid ct-         (read g) config snoTime Nothing defaultDebugMode)+      (State player cursor flav disco dng lid ct (read g) config stakeTime+         Nothing sfaction defaultDebugMode) +instance Binary TgtMode where+  put TgtOff      = putWord8 0+  put TgtExplicit = putWord8 1+  put TgtAuto     = putWord8 2+  get = do+    tag <- getWord8+    case tag of+      0 -> return TgtOff+      1 -> return TgtExplicit+      2 -> return TgtAuto+      _ -> fail "no parse (TgtMode)"+ instance Binary Cursor where   put (Cursor act cln loc rln eps) = do     put act@@ -210,14 +241,16 @@     eps <- get     return (Cursor act cln loc rln eps) -instance Binary TgtMode where-  put TgtOff      = putWord8 0-  put TgtExplicit = putWord8 1-  put TgtAuto     = putWord8 2+instance Binary Status where+  put (Killed ln) = putWord8 0 >> put ln+  put Camping     = putWord8 1+  put Victor      = putWord8 2+  put Restart     = putWord8 3   get = do     tag <- getWord8     case tag of-      0 -> return TgtOff-      1 -> return TgtExplicit-      2 -> return TgtAuto-      _ -> fail "no parse (TgtMode)"+      0 -> fmap Killed get+      1 -> return Camping+      2 -> return Victor+      3 -> return Restart+      _ -> fail "no parse (Status)"
Game/LambdaHack/Strategy.hs view
@@ -1,7 +1,8 @@ -- | AI strategies to direct actors not controlled by the player. -- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Strategy-  ( Strategy(..), liftFrequency, (.|), reject, (.=>), only+  ( Strategy, nullStrategy, liftFrequency+  , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN   ) where  import Control.Monad@@ -16,24 +17,29 @@ -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where   return x = Strategy $ return $ uniformFreq "Strategy_return" [x]-  m >>= f  = Strategy $-    filter (not . nullFreq)-    [ toFreq "Strategy_bind" [ (p * q, b)-                             | (p, a) <- runFrequency x-                             , y <- runStrategy (f a)-                             , (q, b) <- runFrequency y-                             ]-    | x <- runStrategy m ]+  m >>= f  = normalizeStrategy $ Strategy $+    [ toFreq name [ (p * q, b)+                  | (p, a) <- runFrequency x+                  , y <- runStrategy (f a)+                  , (q, b) <- runFrequency y+                  ]+    | x <- runStrategy m+    , let name = "Strategy_bind (" ++ nameFrequency x ++ ")"]  instance MonadPlus Strategy where   mzero = Strategy []   mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) +normalizeStrategy :: Strategy a -> Strategy a+normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs++nullStrategy :: Strategy a -> Bool+nullStrategy strat = null $ runStrategy strat+ -- | Strategy where only the actions from the given single frequency table -- can be picked. liftFrequency :: Frequency a -> Strategy a-liftFrequency f =-  Strategy $ filter (not . nullFreq) $ return f+liftFrequency f = normalizeStrategy $ Strategy $ return f  infixr 2 .| @@ -54,8 +60,22 @@         | otherwise  =  mzero  -- | Strategy with all actions not satisfying the predicate removed.--- The remaining action keep their original relative frequency values.+-- The remaining actions keep their original relative frequency values. only :: (a -> Bool) -> Strategy a -> Strategy a-only p s = do+only p s = normalizeStrategy $ do   x <- s   p x .=> return x++-- | When better choices are towards the start of the list,+-- this is the best frequency of the strategy.+bestVariant :: Strategy a -> Frequency a+bestVariant (Strategy []) = mzero+bestVariant (Strategy (f : _)) = f++-- | Overwrite the description of all frequencies within the strategy.+renameStrategy :: String -> Strategy a -> Strategy a+renameStrategy newName (Strategy fs) = Strategy $ map (renameFreq newName) fs++-- | Like 'return', but pick a name of the single frequency.+returN :: String -> a -> Strategy a+returN name x = Strategy $ return $ uniformFreq name [x]
Game/LambdaHack/StrategyAction.hs view
@@ -1,16 +1,19 @@ -- | AI strategy operations implemented with the 'Action' monad. module Game.LambdaHack.StrategyAction-  ( strategy, wait+  ( targetStrategy, strategy   ) where  import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe+import Data.Function import Control.Monad import Control.Monad.State hiding (State, state) import Control.Arrow  import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Ability (Ability)+import qualified Game.LambdaHack.Ability as Ability import Game.LambdaHack.Point import Game.LambdaHack.Vector import Game.LambdaHack.Level@@ -22,6 +25,7 @@ import Game.LambdaHack.Strategy import Game.LambdaHack.State import Game.LambdaHack.Action+import Game.LambdaHack.EffectAction import Game.LambdaHack.Actions import Game.LambdaHack.ItemAction import Game.LambdaHack.Content.ItemKind@@ -34,225 +38,349 @@ import Game.LambdaHack.Time import qualified Game.LambdaHack.Color as Color -{--Monster movement-------------------Not all monsters use the same algorithm to find the hero.-Some implemented and unimplemented methods are listed below:--* Random-The simplest way to have a monster move is at random.--* Sight-If a monster can see the hero (as an approximation,-we assume it is the case when the hero can see the monster,-unless either of the locations is dark),-the monster should move toward the hero.--* Smell-The hero leaves a trail when moving toward the dungeon.-For a certain timespan (100--200 moves), it is possible-for certain monsters to detect that a hero has been at a certain field.-Once a monster is following a trail, it should move to the-neighboring field where the hero has most recently visited.--* Noise-The hero makes noise. If the distance between the hero-and the monster is small enough, the monster can hear the hero-and moves into the approximate direction of the hero.--}---- 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} per =-  strat+-- | AI proposes possible targets for the actor. Never empty.+targetStrategy :: Kind.COps -> ActorId -> State -> Perception -> [Ability]+               -> Strategy Target+targetStrategy cops actor state@State{splayer = pl} per factionAbilities =+  retarget btarget  where   Kind.COps{ cotile            , coactor=coactor@Kind.Ops{okind}-           , coitem=coitem@Kind.Ops{okind=iokind}-           , corule            } = cops-  lvl@Level{lsmell, lxsize, lysize, ltime} = slevel oldState-  actorBody@Actor{ bkind = ak, bloc = me, bdir = ad, btarget, bparty } =-    getActor actor oldState-  bitems = getActorItem actor oldState-  mk = okind ak-  delState = deleteActor actor oldState+  lvl@Level{lxsize} = slevel state+  actorBody@Actor{ bkind, bloc = me, btarget, bfaction } =+    getActor actor state+  mk = okind bkind   enemyVisible a l =-    asight mk &&-    isAHero delState a &&-    monsterSeesHero cotile per lvl actor a me l+    asight mk+    && actorSeesActor cotile per lvl actor a me l pl     -- Enemy can be felt if adjacent (e. g., a player-controlled monster).     -- TODO: can this be replaced by setting 'lights' to [me]?-    || (asmell mk || asight mk)-       && adjacent lxsize me l-  -- Below, "foe" is the hero (or a monster, or loc) chased by the actor.-  chase tgt =+    || adjacent lxsize me l+       && (asmell mk || asight mk)+  actorAbilities = acanDo (okind bkind) `L.intersect` factionAbilities+  focused = actorSpeed coactor actorBody <= speedNormal+            -- Don't focus on a distant enemy, when you can't chase him.+            -- TODO: or only if another enemy adjacent? consider Flee?+            && Ability.Chase `elem` actorAbilities+  retarget :: Target -> Strategy Target+  retarget tgt =     case tgt of-      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+      TPath _ -> returN "TPath" tgt            -- don't animate missiles+      TEnemy a ll | focused+                    && memActor a state  -- present on this level+                    -- Don't hit a new player-controlled monster.+                    && not (isAHero state actor && a == pl) ->+        let l = bloc $ getActor a state+        in if enemyVisible a l         -- prefer visible foes+           then returN "TEnemy" $ TEnemy a l+           else if null visibleFoes    -- prefer visible foes+                   && me /= ll         -- not yet reached the last enemy loc+                then returN "last known" $ TLoc ll+                                       -- chase the last known loc+                else closest+      TEnemy _ _ -> closest            -- foe is gone and we forget+      TLoc loc | me == loc -> closest  -- already reached the loc+      TLoc _ | null visibleFoes -> returN "TLoc" tgt+                                       -- nothing visible, go to loc+      TLoc _ -> closest                -- prefer visible foes+      TCursor  -> closest+  hs = hostileAssocs bfaction lvl+  foes = if isAHero state actor+         then L.filter ((pl /=) . fst) hs  -- ignore player-controlled+         else if not (isAHero state pl) && memActor pl state+              then (pl, getPlayerBody state) : hs+              else hs  -- no player-controlled monster to add+  visibleFoes = L.filter (uncurry enemyVisible) (L.map (second bloc) foes)+  closest :: Strategy Target   closest =-    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-         [] -> (TCursor, Nothing, False)-         _  -> let (_, l, a) = L.minimum foeDist-               in (TEnemy a l, Just l, True)-  onlyFoe        = onlyMoves (maybe (const False) (==) floc) me-  towardsFoe     = case floc of-                     Nothing -> const mzero-                     Just loc ->-                       let foeDir = towards lxsize me loc-                       in only (\ x -> euclidDistSq lxsize foeDir x <= 1)-  lootHere x     = not $ L.null $ lvl `atI` x-  onlyLoot       = onlyMoves lootHere me-  interestHere x = let t = lvl `at` x-                       ts = map (lvl `at`) $ vicinity lxsize lysize x-                   in Tile.hasFeature cotile F.Exit t ||-                      -- Lit indirectly. E.g., a room entrance.-                      (not (Tile.hasFeature cotile F.Lit t) &&-                       L.any (Tile.hasFeature cotile F.Lit) ts)-  onlyInterest   = onlyMoves interestHere me-  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 (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      = 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 = 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 > 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}+    let foeDist = L.map (\ (_, l) -> chessDist lxsize me l) visibleFoes+        minDist = L.minimum foeDist+        minFoes =+          L.filter (\ (_, l) -> chessDist lxsize me l == minDist) visibleFoes+        minTargets = map (\ (a, l) -> TEnemy a l) minFoes+        minTgtS = liftFrequency $ uniformFreq "closest" minTargets+    in minTgtS .| noFoes .| returN "TCursor" TCursor  -- never empty+  -- TODO: set distant targets so that monsters behave as if they have+  -- a plan. We need pathfinding for that.+  noFoes :: Strategy Target+  noFoes =+    (TLoc . (me `shift`)) `liftM` moveStrategy cops actor state Nothing +-- | AI strategy based on actor's sight, smell, intelligence, etc. Never empty.+strategy :: Kind.COps -> ActorId -> State -> [Ability] -> Strategy (Action ())+strategy cops actor state factionAbilities =+  sumS prefix .| combineDistant distant .| sumS suffix+  .| waitBlockNow actor  -- wait until friends sidestep, ensures never empty+ where+  Kind.COps{coactor=Kind.Ops{okind}} = cops+  Actor{ bkind, bloc, btarget } = getActor actor state+  (floc, foeVisible) = case btarget of+     TEnemy _ l -> (l, True)+     TLoc l     -> (l, False)+     TPath _    -> (bloc, False)  -- a missile+     TCursor    -> (bloc, False)  -- an actor blocked by friends+  combineDistant = liftFrequency . sumF+  aFrequency :: Ability -> Frequency (Action ())+  aFrequency Ability.Ranged = if foeVisible+                              then rangedFreq cops actor state floc+                              else mzero+  aFrequency Ability.Tools  = if foeVisible+                              then toolsFreq cops actor state+                              else mzero+  aFrequency Ability.Chase  = if (floc /= bloc)+                              then chaseFreq+                              else mzero+  aFrequency _              = assert `failure` distant+  chaseFreq =+    scaleFreq 30 $ bestVariant $ chase cops actor state (floc, foeVisible)+  aStrategy :: Ability -> Strategy (Action ())+  aStrategy Ability.Track  = track cops actor state+  aStrategy Ability.Heal   = mzero  -- TODO+  aStrategy Ability.Flee   = mzero  -- TODO+  aStrategy Ability.Melee  = foeVisible .=> melee actor state floc+  aStrategy Ability.Pickup = not foeVisible .=> pickup actor state+  aStrategy Ability.Wander = wander cops actor state+  aStrategy _              = assert `failure` actorAbilities+  actorAbilities = acanDo (okind bkind) `L.intersect` factionAbilities+  isDistant = (`elem` [Ability.Ranged, Ability.Tools, Ability.Chase])+  (prefix, rest)    = L.break isDistant actorAbilities+  (distant, suffix) = L.partition isDistant rest+  sumS = msum . map aStrategy+  sumF = msum . map aFrequency++dirToAction :: ActorId -> Bool -> Vector -> Action ()+dirToAction actor allowAttacks dir = do+  -- set new direction+  updateAnyActor actor $ \ m -> m { bdir = Just (dir, 0) }+  -- perform action+  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.+waitBlockNow :: ActorId -> Strategy (Action ())+waitBlockNow actor = returN "wait" $ setWaitBlock actor++-- | A strategy to always just die.+dieNow :: ActorId -> Strategy (Action ())+dieNow actor = returN "die" $ do  -- TODO: explode if a potion+  bitems <- gets (getActorItem actor)+  Actor{bloc} <- gets (getActor actor)+  modify (updateLevel (dropItemsAt bitems bloc))+  modify (deleteActor actor)++-- | Strategy for dumb missiles.+track :: Kind.COps -> ActorId -> State -> Strategy (Action ())+track cops actor state =+  strat+ where+  lvl = slevel state+  Actor{ bloc, btarget, bhp } = getActor actor state+  darkenActor = updateAnyActor actor $ \ m -> m {bcolor = Just Color.BrBlack}+  dieOrReset | bhp <= 0  = dieNow actor+             | otherwise =+                 returN "reset TPath" $ updateAnyActor actor+                 $ \ m -> m {btarget = TCursor}   strat = case btarget of-    TPath [] -> dieOrSleep-    TPath (d : _) | not $ accessible cops lvl me (shift me d) -> dieOrSleep+    TPath [] -> dieOrReset+    TPath (d : _) | not $ accessible cops lvl bloc (shift bloc d) -> dieOrReset     -- 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 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 == '!']-  foeAdjacent = maybe False (adjacent lxsize me) floc+    TPath [d] -> returN "last TPath" $ do+      darkenActor+      updateAnyActor actor $ \ m -> m { btarget = TPath [] }+      dirToAction actor True d+    TPath (d : lv) -> returN "follow TPath" $ do+      updateAnyActor actor $ \ m -> m { btarget = TPath lv }+      dirToAction actor True d+    _ -> reject++pickup :: ActorId -> State -> Strategy (Action ())+pickup actor state =+  lootHere bloc .=> actionPickup+ where+  lvl = slevel state+  Actor{bloc} = getActor actor state+  lootHere x = not $ L.null $ lvl `atI` x+  actionPickup = returN "pickup" $ actorPickupItem actor++melee :: ActorId -> State -> Point -> Strategy (Action ())+melee actor state floc =+  foeAdjacent .=> (returN "melee" $ dirToAction actor True dir)+ where+  Level{lxsize} = slevel state+  Actor{bloc} = getActor actor state+  foeAdjacent = adjacent lxsize bloc floc+  dir = displacement bloc floc++rangedFreq :: Kind.COps -> ActorId -> State -> Point -> Frequency (Action ())+rangedFreq cops actor state@State{splayer = pl} floc =+  toFreq "throwFreq" $+    if not foesAdj+       && asight mk+       && accessible cops lvl bloc loc1      -- first accessible+       && isNothing (locToActor loc1 state)  -- no friends on first+    then throwFreq bitems 3 ++ throwFreq tis 6+    else []+ where+  Kind.COps{ coactor=Kind.Ops{okind}+           , coitem=Kind.Ops{okind=iokind}+           , corule+           } = cops+  lvl@Level{lxsize, lysize} = slevel state+  Actor{ bkind, bloc, bfaction } = getActor actor state+  bitems = getActorItem actor state+  mk = okind bkind+  tis = lvl `atI` bloc+  hs = hostileAssocs bfaction lvl+  foes = if isAHero state actor+         then L.filter ((pl /=) . fst) hs  -- ignore player-controlled+         else if not (isAHero state pl) && memActor pl state+              then (pl, getPlayerBody state) : hs+              else hs  -- no player-controlled monster to add+  foesAdj = foesAdjacent lxsize lysize bloc (map snd foes)   -- 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)+  bl = bla lxsize lysize eps bloc floc  -- TODO:make an arg of projectGroupItem   loc1 = case bl of-    Nothing -> me-    Just [] -> me+    Nothing -> bloc  -- TODO+    Just [] -> bloc  -- TODO     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 "throwFreq"-    [ (benefit * multi,-       projectGroupItem actor (fromJust floc) (iverbProject ik) i)+  throwFreq is multi =+    [ (benefit * multi, projectGroupItem actor floc (iverbProject ik) i)     | i <- is,       let ik = iokind (jkind i),-      let benefit =-            - (1 + jpower i) * Effect.effectToBenefit (ieffect ik),+      let benefit = - (1 + jpower i) * Effect.effectToBenefit (ieffect ik),       benefit > 0,       -- 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 =-    onlySensible $-      (if asight mk then onlyNoMs else id) $-        asmell mk .=> L.foldr ((.|) . return) reject smells-        .| onlyOpenable moveFreely-        .| moveFreely++toolsFreq :: Kind.COps -> ActorId -> State -> Frequency (Action ())+toolsFreq cops actor state =+  toFreq "quaffFreq" $ quaffFreq bitems 1 ++ quaffFreq tis 2+ where+  Kind.COps{coitem=Kind.Ops{okind=iokind}} = cops+  lvl = slevel state+  Actor{bloc} = getActor actor state+  bitems = getActorItem actor state+  tis = lvl `atI` bloc+  quaffFreq is multi =+    [ (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, isymbol ik == '!']++-- | AI finds interesting moves in the absense of visible foes.+-- This strategy can be null (e.g., if the actor is blocked by friends).+moveStrategy :: Kind.COps -> ActorId -> State -> Maybe (Point, Bool)+             -> Strategy Vector+moveStrategy cops actor state mFoe =+  case mFoe of+    -- Target set and we chase the foe or his last position or another target.+    Just (floc, foeVisible) ->+      let towardsFoe =+            let foeDir = towards lxsize bloc floc+                tolerance | isUnit lxsize foeDir = 0+                          | otherwise = 1+            in only (\ x -> euclidDistSq lxsize foeDir x <= tolerance)+      in if floc == bloc+         then reject+         else towardsFoe+              $ if foeVisible+                then moveClear  -- enemies in sight, don't waste time for doors+                     .| moveOpenable+                else moveOpenable  -- no enemy in sight, explore doors+                     .| moveClear+    Nothing ->+      let smells =+            map (map fst)+            $ L.groupBy ((==) `on` snd)+            $ L.sortBy (flip compare `on` snd)+            $ L.filter (\ (_, s) -> s > timeZero)+            $ L.map (\ x ->+                      let sml = IM.findWithDefault+                                  timeZero (bloc `shift` x) lsmell+                      in (x, sml `timeAdd` timeNegate ltime))+                sensible+      in asmell mk .=> L.foldr ((.|)+                                . liftFrequency+                                . uniformFreq "smell k") reject smells+         .| moveOpenable  -- no enemy in sight, explore doors+         .| moveClear+ where+  Kind.COps{ cotile+           , coactor=Kind.Ops{okind}+           , coitem+           } = cops+  lvl@Level{lsmell, lxsize, lysize, ltime} = slevel state+  Actor{ bkind, bloc, bdir, bfaction } = getActor actor state+  bitems = getActorItem actor state+  mk = okind bkind+  lootHere x = not $ L.null $ lvl `atI` x+  onlyLoot   = onlyMoves lootHere bloc+  interestHere x = let t = lvl `at` x+                       ts = map (lvl `at`) $ vicinity lxsize lysize x+                   in Tile.hasFeature cotile F.Exit t+                      -- Lit indirectly. E.g., a room entrance.+                      || (not (Tile.hasFeature cotile F.Lit t)+                          && L.any (Tile.hasFeature cotile F.Lit) ts)+  onlyInterest   = onlyMoves interestHere bloc+  onlyKeepsDir k =+    only (\ x -> maybe True (\ (d, _) -> euclidDistSq lxsize d x <= k) bdir)+  onlyKeepsDir_9 = only (\ x -> maybe True (\ (d, _) -> neg x /= d) bdir)   moveIQ = aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly         .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly         .| aiq mk > 5  .=> onlyKeepsDir 2 moveRandomly         .| onlyKeepsDir_9 moveRandomly-  interestFreq =  -- don't detour towards an interest if already on one-    if interestHere me-    then []-    else map (scaleFreq 3)-           (runStrategy $ onlyInterest (onlyKeepsDir 2 moveRandomly))-  interestIQFreq = interestFreq ++ runStrategy moveIQ+  interestFreq | interestHere bloc =+    -- Don't detour towards an interest if already on one.+    mzero+               | otherwise =+    -- Prefer interests, but don't exclude other focused moves.+    scaleFreq 5 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly+  interestIQFreq = interestFreq `mplus` bestVariant moveIQ+  moveClear    = onlyMoves (not . openableHere) bloc moveFreely+  moveOpenable = onlyMoves openableHere bloc moveFreely   moveFreely = onlyLoot moveRandomly-               .| liftFrequency (msum interestIQFreq)+               .| liftFrequency interestIQFreq+               .| moveIQ  -- sometimes interestIQFreq is excluded later on                .| moveRandomly   onlyMoves :: (Point -> Bool) -> Point -> Strategy Vector -> Strategy Vector   onlyMoves p l = only (\ x -> p (l `shift` x))   moveRandomly :: Strategy Vector-  moveRandomly = liftFrequency $ uniformFreq "moveRandomly" (moves lxsize)--dirToAction :: ActorId -> Target -> Bool -> Vector -> Action ()-dirToAction actor btarget allowAttacks dir = do-  -- set new direction-  updateAnyActor actor $ \ m -> m { bdir = Just (dir, 0), btarget }-  -- perform action-  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+  moveRandomly = liftFrequency $ uniformFreq "moveRandomly" sensible+  -- 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. TODO: make symmetric for playable monster faction?+  openPower      = timeScale timeTurn $+                   case strongestSearch coitem bitems of+                     Just i  -> aiq mk + jpower i+                     Nothing -> aiq mk+  openableHere   = openable cotile lvl openPower+  accessibleHere = accessible cops lvl bloc+  noFriends | asight mk = unoccupied (factionList [bfaction] state)+            | otherwise = const True+  isSensible l = noFriends l && (accessibleHere l || openableHere l)+  sensible = filter (isSensible . (bloc `shift`)) (moves lxsize) --- | A strategy to always just wait.-wait :: Strategy (Action ())-wait = return $ return ()+chase :: Kind.COps -> ActorId -> State -> (Point, Bool) -> Strategy (Action ())+chase cops actor state foe@(_, foeVisible) =+  -- Target set and we chase the foe or offer null strategy if we can't.+  -- The foe is visible, or we remember his last position.+  let mFoe = Just foe+      fight = not foeVisible  -- don't pick fights if the real foe is close+  in dirToAction actor fight `liftM` moveStrategy cops actor state mFoe --- | 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)+wander :: Kind.COps -> ActorId -> State -> Strategy (Action ())+wander cops actor state =+  -- Target set, but we don't chase the foe, e.g., because we are blocked+  -- or we cannot chase at all.+  let mFoe = Nothing+  in dirToAction actor True `liftM` moveStrategy cops actor state mFoe
Game/LambdaHack/Tile.hs view
@@ -15,10 +15,11 @@ module Game.LambdaHack.Tile   (SecretTime, SmellTime   , kindHasFeature, kindHas, hasFeature-  , isClear, isLit, similar, canBeHidden+  , isClear, isLit, isExplorable, similar, canBeHidden, speedup   ) where  import qualified Data.List as L+import qualified Data.Array.Unboxed as A  import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Feature as F@@ -58,6 +59,15 @@ isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool isLit Kind.Ops{ospeedup = Kind.TileSpeedup{isLitTab}} = isLitTab +-- | Whether a tile can be explored, possibly yielding a treasure+-- or a hidden message. We exclude doors and hidden features+-- (TODO: and features created by actors, e.g., dug out).+isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isExplorable cops tk =+  not (hasFeature cops F.Closable tk)+  && (isClear cops tk+      || hasFeature cops F.Walkable tk)+ -- | The player can't tell one tile from the other. similar :: TileKind -> TileKind -> Bool similar t u =@@ -71,3 +81,16 @@ canBeHidden Kind.Ops{ofoldrWithKey} t =   let sim _ s acc = acc || kindHasFeature F.Hidden s && similar t s   in ofoldrWithKey sim False++speedup :: Kind.Ops TileKind -> Kind.Speedup TileKind+speedup Kind.Ops{ofoldrWithKey, obounds} =+  let createTab :: (TileKind -> Bool) -> A.UArray (Kind.Id TileKind) Bool+      createTab p =+        let f _ k acc = p k : acc+            clearAssocs = ofoldrWithKey f []+        in A.listArray obounds clearAssocs+      tabulate :: (TileKind -> Bool) -> Kind.Id TileKind -> Bool+      tabulate p = (createTab p A.!)+      isClearTab = tabulate $ kindHasFeature F.Clear+      isLitTab   = tabulate $ kindHasFeature F.Lit+  in Kind.TileSpeedup {isClearTab, isLitTab}
Game/LambdaHack/Turn.hs view
@@ -18,7 +18,6 @@ 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@@ -28,15 +27,18 @@ import Game.LambdaHack.Draw import qualified Game.LambdaHack.Kind as Kind import Game.LambdaHack.Time-import qualified Game.LambdaHack.HighScore as H+import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.StrategyKind+import Game.LambdaHack.Random + -- One clip proceeds through the following functions: -- -- handleTurn -- handleActors--- handleMonster or handlePlayer+-- handleAI or handlePlayer -- handleActors--- handleMonster or handlePlayer+-- handleAI or handlePlayer -- ... -- handleTurn (again) @@ -51,13 +53,13 @@ -- handlePlayer: update perception, remember, display frames, --   get and process commmands (zero or more), update smell map ----- handleMonster: determine and process monster action+-- handleAI: determine and process actor's action  -- | 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.+-- Run the player and other actors moves. Eventually advance the time+-- and repeat. handleTurn :: Action () handleTurn = do   debug "handleTurn"@@ -71,14 +73,7 @@           ++ show ptime ++ ", time = " ++ show time   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+  endOrLoop handleTurn  -- TODO: We should replace this structure using a priority search queue/tree. -- | Perform moves for individual actors not controlled@@ -92,59 +87,89 @@ handleActors subclipStart = do   debug "handleActors"   Kind.COps{coactor} <- getCOps+  sfaction <- gets sfaction   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+  -- Older actors act earlier, the player acts first.+  lactor <- gets (((pl, pbody) :) . IM.toList . IM.delete pl . lactor . slevel)+  squitOld <- gets squit+  let mnext = if null lactor  -- 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+                       order = Ord.comparing (btime . snd &&& bfaction . snd)+                       (actor, m) = L.minimumBy order lactor                    in if btime m > time                       then Nothing  -- no actor is ready for another move                       else Just (actor, m)   case mnext of-    _ | isJust squit -> return ()+    _ | isJust squitOld -> 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+    Just (actor, _) -> do+      m <- gets (getActor actor)+      if actor == pl         then           -- Player moves always start a new subclip.           startClip $ do             handlePlayer+            squitNew <- gets squit+            plNew <- gets splayer+            -- Advance time once, after the player switched perhaps many times.+            -- Ending and especially saving does not take time.+            -- TODO: this is correct only when all heroes have the same+            -- speed and can't switch players by, e.g., aiming a wand+            -- of domination. We need to generalize by displaying+            -- "(next move in .3s [RET]" when switching players.+            -- RET waits .3s and gives back control,+            -- Any other key does the .3s wait and the action form the key+            -- at once. This requires quite a bit of refactoring+            -- and is perhaps better done when the other factions have+            -- selected players as well.+            unless (isJust squitNew) $ advanceTime plNew             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+        else do+          advanceTime actor  -- advance time while the actor still alive+          let subclipStartDelta = timeAddFromSpeed coactor m subclipStart+          if subclipStart == timeZero+                || btime m > subclipStartDelta+                || bfaction m == sfaction && not (bproj m)+            then+              -- That's the first move this clip+              -- or the actor has already moved during this subclip+              -- or it's a hero. In either case, start a new subclip.+              startClip $ do+                handleAI actor+                handleActors $ btime m+            else do+              -- The monster didn't yet move this subclip.+              handleAI actor+              handleActors subclipStart  -- | Handle the move of a single monster.-handleMonster :: ActorId -> Action ()-handleMonster actor = do-  debug "handleMonster"-  cops  <- getCOps+handleAI :: ActorId -> Action ()+handleAI actor = do+  cops@Kind.COps{ cofact=Kind.Ops{okind}+                , costrat=Kind.Ops{opick, okind=sokind}+                } <- getCOps   state <- get   per <- getPerception+  let Actor{bfaction, bloc, bsymbol} = getActor actor state+      faction = okind bfaction+  factionAi <- rndToAction $ opick (fAiIdle faction) (const True)+  let factionAbilities = sabilities (sokind factionAi)+      stratTarget = targetStrategy cops actor state per factionAbilities+  -- Choose a target from those proposed by AI for the actor.+  btarget <- rndToAction $ frequency $ bestVariant $ stratTarget+  updateAnyActor actor $ \ m -> m { btarget }+  stateNew <- get+  let stratMove = strategy cops actor stateNew factionAbilities+  debug $ "handleAI faction: " ++ fname faction+     ++          ", symbol: "  ++ show bsymbol+     ++          ", loc: "     ++ show bloc+     ++ "\nhandleAI target: "  ++ show stratTarget+     ++ "\nhandleAI move: "    ++ show stratMove   -- Run the AI: choses an action from those given by the AI strategy.-  join $ rndToAction $-           frequency (head (runStrategy (strategy cops actor state per-                                         .| wait)))+  join $ rndToAction $ frequency $ bestVariant $ stratMove  -- | Handle the move of the hero. handlePlayer :: Action ()@@ -165,7 +190,7 @@   Binding.Binding{kcmd} <- getBinding   kmPush <- case msgRunAbort of     "" -> getKeyCommand (Just True)-    _  -> drawPrompt ColorFull msgRunAbort >>= getKeyChoice []+    _  -> drawPrompt ColorFull msgRunAbort >>= getKeyFrameCommand   -- 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 ()@@ -181,9 +206,9 @@               -- 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})+              stakeTime <- gets stakeTime+              let timed = fromMaybe declaredTimed stakeTime+              modify (\ s -> s {stakeTime = Nothing})               -- 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)@@ -209,7 +234,7 @@             -- 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+              Just fr | b -> getKeyFrameCommand fr               _           -> getKeyCommand Nothing             -- Look up and perform the next command.             loop kmNext@@ -221,24 +246,11 @@   loop kmPush  -- | Advance (or rewind) the move time for the given actor.-advanceTime :: Bool -> ActorId -> Action ()-advanceTime forward actor = do+advanceTime :: ActorId -> Action ()+advanceTime 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}+  let upd m@Actor{btime} = m {btime = timeAddFromSpeed coactor m btime}   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
Game/LambdaHack/Utils/Assert.hs view
@@ -33,7 +33,8 @@   let s = "Internal failure occured and the following is to blame:\n" ++           "  " ++ show blamed   in trace s $-     asrt False (error "Assert.failure: no error location (upgrade to GHC 7.4)")+     asrt False+       (error "Assert.failure: no error location (upgrade to GHC >= 7.4)")  -- | Like 'List.all', but if the predicate fails, blame all the list elements -- and especially those for which it fails. To be used as in:@@ -56,7 +57,7 @@             "  " ++ show blamed     in trace s $        asrt False-         (error "Assert.checkM: no error location (upgrade to GHC 7.4)")+         (error "Assert.checkM: no error location (upgrade to GHC >= 7.4)")  -- | Verifies that the returned value is true (respectively, false). Used as in: --
Game/LambdaHack/Utils/Frequency.hs view
@@ -5,9 +5,9 @@     -- * Construction   , uniformFreq, toFreq     -- * Transformation-  , scaleFreq, filterFreq+  , scaleFreq, renameFreq     -- * Consumption-  , rollFreq, nullFreq, runFrequency+  , rollFreq, nullFreq, runFrequency, nameFrequency   ) where  import Control.Monad@@ -18,8 +18,8 @@ -- TODO: do not expose runFrequency -- | The frequency distribution type. data Frequency a = Frequency-  { _name        :: String      -- ^ short description for debug, etc.-  , runFrequency :: [(Int, a)]  -- ^ give acces to raw frequency values+  { nameFrequency :: String      -- ^ short description for debug, etc.+  , runFrequency  :: [(Int, a)]  -- ^ give acces to raw frequency values   }   deriving Show @@ -27,14 +27,18 @@   return x = Frequency "return" [(1, x)]   Frequency name xs >>= f =     Frequency ("bind (" ++ name ++ ")")-              [(p * q, y) | (p, x) <- xs,-                            (q, y) <- runFrequency (f x) ]+              [(p * q, y) | (p, x) <- xs+                          , (q, y) <- runFrequency (f x) ]  instance MonadPlus Frequency where   mplus (Frequency xname xs) (Frequency yname ys) =-    Frequency ("mplus (" ++ xname ++ ") (" ++ yname ++ ")")-              (xs ++ ys)-  mzero = Frequency "mzero" []+    let name = case (xs, ys) of+          ([], []) -> []+          ([], _ ) -> yname+          (_,  []) -> xname+          _ -> "(" ++ xname ++ ") ++ (" ++ yname ++ ")"+    in Frequency name (xs ++ ys)+  mzero = Frequency "[]" []  instance Functor Frequency where   fmap f (Frequency name xs) = Frequency name (map (\ (p, x) -> (p, f x)) xs)@@ -52,14 +56,12 @@ -- 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)) $+  assert (n > 0 `blame` ("non-positive 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 name l) =-  Frequency ("filterFreq (" ++ name ++ ")")-            (filter (p . snd) l)+-- | Change the description of the frequency.+renameFreq :: String -> Frequency a -> Frequency a+renameFreq newName fr = fr {nameFrequency = newName}  -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)@@ -81,4 +83,4 @@  -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool-nullFreq fr = null $ runFrequency fr+nullFreq = null . runFrequency
Game/LambdaHack/Vector.hs view
@@ -2,7 +2,8 @@ -- but not unique, way. module Game.LambdaHack.Vector   ( Vector, toVector, shift, shiftBounded, moves, movesWidth-  , euclidDistSq, diagonal, neg, towards, displacement, displacePath+  , isUnit, euclidDistSq, diagonal, neg, towards, displacement+  , displacePath, shiftPath   ) where  import Data.Binary@@ -18,7 +19,7 @@ -- -- A newtype is used to prevent mixing up the type with @Point@ itself. -- Note that the offset representations of a vector is usually not unique.--- E.g., for vectors of lenth 1 in the chessboard metric, used to denote+-- E.g., for vectors of length 1 in the chessboard metric, used to denote -- geographical directions, the representations are pairwise distinct -- if and only if the level width and height are at least 3. newtype Vector = Vector Int@@ -33,10 +34,17 @@ toVector lxsize (VectorXY (x, y)) =   Vector $ x + y * lxsize +isUnitXY :: VectorXY -> Bool+isUnitXY v = chessDistXY v == 1++-- | Tells if a vector has length 1 in the chessboard metric.+isUnit ::  X -> Vector -> Bool+isUnit lxsize = isUnitXY . fromDir lxsize+ -- | Converts a unit vector in cartesian representation into @Vector@. toDir :: X -> VectorXY -> Vector toDir lxsize v@(VectorXY (x, y)) =-  assert (lxsize >= 3 && chessDistXY v == 1 `blame` (lxsize, v)) $+  assert (lxsize >= 3 && isUnitXY v `blame` (lxsize, v)) $   Vector $ x + y * lxsize  -- | Converts a unit vector in the offset representation@@ -44,7 +52,7 @@ -- converted uniquely. fromDir :: X -> Vector -> VectorXY fromDir lxsize (Vector dir) =-  assert (lxsize >= 3 && chessDistXY res == 1 &&+  assert (lxsize >= 3 && isUnitXY res &&           fst len1 + snd len1 * lxsize == dir           `blame` (lxsize, dir, res)) $   res@@ -82,7 +90,7 @@ euclidDistSq lxsize dir0 dir1   | VectorXY (x0, y0) <- fromDir lxsize dir0   , VectorXY (x1, y1) <- fromDir lxsize dir1 =-  euclidDistSqXY $ VectorXY (y1 - y0, x1 - x0)+  euclidDistSqXY $ VectorXY (x1 - x0, y1 - y0)  -- | Checks whether a unit vector is a diagonal direction, -- as opposed to cardinal.@@ -100,7 +108,7 @@ -- Of several equally good directions it picks one of those that visually -- (in the euclidean metric) maximally align with the original vector. normalize :: X -> VectorXY -> Vector-normalize lxsize (VectorXY (dx, dy)) =+normalize lxsize v@(VectorXY (dx, dy)) =   assert (dx /= 0 || dy /= 0 `blame` (dx, dy)) $   let angle :: Double       angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)@@ -110,9 +118,12 @@           | angle <= 0.75  = (1, 1)           | angle <= 1.25  = (0, 1)           | otherwise = assert `failure` (lxsize, dx, dy, angle)-  in if dx >= 0-     then toDir lxsize $ VectorXY dxy-     else neg (toDir lxsize $ VectorXY dxy)+      rxy = if dx >= 0+            then VectorXY dxy+            else negXY $ VectorXY dxy+  in assert ((if isUnitXY v then v == rxy else True)+             `blame` (v, rxy))+     $ toDir lxsize rxy  -- TODO: Perhaps produce all acceptable directions and let AI choose. -- That would also eliminate the Doubles. Or only directions from bla?@@ -138,8 +149,15 @@ displacement :: Point -> Point -> Vector displacement loc1 loc2 = Vector $ loc2 - loc1 --- | A vector from a point to another. W have+-- | A list of vectors between a list of points. displacePath :: [Point] -> [Vector] displacePath []  = [] displacePath lp1@(_ : lp2) =   map (uncurry displacement) $ zip lp1 lp2++-- | A list of points that a list of vectors leads to.+shiftPath :: Point -> [Vector] -> [Point]+shiftPath _     [] = []+shiftPath start (v : vs) =+  let next = shift start v+  in next : shiftPath next vs
LambdaHack.cabal view
@@ -1,9 +1,9 @@ cabal-version: >= 1.10 name:          LambdaHack-version:       0.2.1+version:       0.2.6 license:       BSD3 license-file:  LICENSE-tested-with:   GHC == 7.2.2, GHC == 7.4.1+tested-with:   GHC == 7.2.2, GHC == 7.4.1, GHC == 7.6.1 data-files:    LICENSE, CREDITS, PLAYING.md, README.md,                config.default, config.bot, scores author:        Andres Loeh, Mikolaj Konarski@@ -12,7 +12,7 @@                a game engine library for roguelike games                of arbitrary theme, size and complexity,                packaged together with a small example dungeon crawler.-               When completed, it will let you specify content+               When completed, the engine will let you specify content                to be procedurally generated, define the AI behaviour                on top of the generic content-independent rules                and compile a ready-to-play game binary, using either@@ -22,22 +22,29 @@                but the fundamental source of flexibility lies                in the strict and type-safe separation of code and content.                .-               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.+               New in this release are the Main Menu and the improved+               and configurable mode of squad combat.+               Upcoming new features: playable monsters faction, more than+               two factions inhabiting the dungeon, AIvAI, PvP, improved+               ranged combat AI, dynamic light sources, explosions+               player action undo/redo, completely redesigned UI. Long term+               goals are focused around procedural content generation+               and include in-game content creation, auto-balancing+               and persistent content modification based on player behaviour.                .                A larger game that depends on the LambdaHack library                is Allure of the Stars, available from                <http://hackage.haskell.org/package/Allure>.-synopsis:      A roguelike game engine in early and very active development+               .+               Note: All modules in the library are kept visible,+               to let games override each, but reuse as many as possible.+               OTOH, to reflect that some modules are implementation details+               relative to others, the source code adheres to the following+               convention. If a module has the same name as a directory,+               the module is the exclusive interface to the directory.+               No references to the modules in the directory are allowed+               except from the interface module.+synopsis:      A roguelike game engine in early and active development homepage:      http://github.com/kosmikus/LambdaHack bug-reports:   http://github.com/kosmikus/LambdaHack/issues category:      Game Engine@@ -60,26 +67,36 @@   default:         False  library-  exposed-modules: Game.LambdaHack.Action,+  exposed-modules: Game.LambdaHack.Ability,+                   Game.LambdaHack.Action,+                   Game.LambdaHack.Action.ActionLift+                   Game.LambdaHack.Action.ConfigIO+                   Game.LambdaHack.Action.Frontend,+                   Game.LambdaHack.Action.Frontend.Chosen,+                   Game.LambdaHack.Action.HighScore,+                   Game.LambdaHack.Action.Save,                    Game.LambdaHack.Actions,                    Game.LambdaHack.Actor,                    Game.LambdaHack.ActorState,+                   Game.LambdaHack.Animation,                    Game.LambdaHack.Area,                    Game.LambdaHack.AreaRnd,                    Game.LambdaHack.Binding,                    Game.LambdaHack.BindingAction,+                   Game.LambdaHack.CDefs,                    Game.LambdaHack.Cave,                    Game.LambdaHack.Color,                    Game.LambdaHack.Command,+                   Game.LambdaHack.CommandAction,                    Game.LambdaHack.Config,-                   Game.LambdaHack.Content,                    Game.LambdaHack.Content.ActorKind,                    Game.LambdaHack.Content.CaveKind,+                   Game.LambdaHack.Content.FactionKind,                    Game.LambdaHack.Content.ItemKind,                    Game.LambdaHack.Content.PlaceKind,                    Game.LambdaHack.Content.RuleKind,+                   Game.LambdaHack.Content.StrategyKind,                    Game.LambdaHack.Content.TileKind,-                   Game.LambdaHack.Display,                    Game.LambdaHack.Draw,                    Game.LambdaHack.Dungeon,                    Game.LambdaHack.DungeonState,@@ -93,7 +110,6 @@                    Game.LambdaHack.FOV.Permissive,                    Game.LambdaHack.FOV.Shadow,                    Game.LambdaHack.Grammar,-                   Game.LambdaHack.HighScore,                    Game.LambdaHack.Item,                    Game.LambdaHack.ItemAction,                    Game.LambdaHack.Key,@@ -107,8 +123,6 @@                    Game.LambdaHack.PointXY,                    Game.LambdaHack.Random,                    Game.LambdaHack.Running,-                   Game.LambdaHack.Save,-                   Game.LambdaHack.Start,                    Game.LambdaHack.State,                    Game.LambdaHack.Strategy,                    Game.LambdaHack.StrategyAction,@@ -144,34 +158,35 @@   ghc-options:     -fno-ignore-asserts -funbox-strict-fields    if flag(curses) {-    exposed-modules: Game.LambdaHack.Display.Curses+    other-modules: Game.LambdaHack.Action.Frontend.Curses     build-depends: hscurses >= 1.4.1 && < 2     cpp-options:   -DCURSES   } else { if flag(vty) {-    exposed-modules: Game.LambdaHack.Display.Vty+    other-modules: Game.LambdaHack.Action.Frontend.Vty     build-depends: vty >= 4.7.0.6     cpp-options:   -DVTY   } else { if flag(std) {-    exposed-modules: Game.LambdaHack.Display.Std+    other-modules: Game.LambdaHack.Action.Frontend.Std     cpp-options:   -DSTD   } else {-    exposed-modules: Game.LambdaHack.Display.Gtk+    other-modules: Game.LambdaHack.Action.Frontend.Gtk     build-depends: gtk >= 0.12.1 && < 0.13   } } }  executable LambdaHack+  hs-source-dirs:  LambdaHack   main-is:         Main.hs   other-modules:   Content.ActorKind,                    Content.CaveKind,+                   Content.FactionKind,                    Content.ItemKind,                    Content.PlaceKind,                    Content.RuleKind,+                   Content.StrategyKind,                    Content.TileKind,                    Multiline,-                   ConfigDefault-  hs-source-dirs:  LambdaHack-  other-modules:   Paths_LambdaHack-  build-depends:   LambdaHack >= 0.2.1   && < 0.2.2,+                   Paths_LambdaHack+  build-depends:   LambdaHack,                    template-haskell >= 2.6 && < 3,                     ConfigFile >= 1.1.1   && < 2,@@ -194,10 +209,11 @@   ghc-options:     -fno-warn-auto-orphans -fno-warn-implicit-prelude   ghc-options:     -fno-ignore-asserts -funbox-strict-fields   ghc-options:     -threaded -with-rtsopts=-C0.005+-- ghc-options:     -with-rtsopts=-N  -- eats all cores  executable DumbBot-  main-is:         Main.hs   hs-source-dirs:  DumbBot+  main-is:         Main.hs   build-depends:   base       >= 4       && < 5,                    random     >= 1.0.1   && < 2   default-language: Haskell2010
− LambdaHack/ConfigDefault.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP, QuasiQuotes #-}--- | The default configurations file included via CPP as a Haskell string.-module ConfigDefault ( configDefault ) where--import Multiline---- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?)--- as soon as the config file grows very big.---- | The string containing the default configuration--- included from file config.default.--- Warning: cabal does not detect that the default config is changed,--- so touching this file is needed to reinclude config and recompile.-configDefault :: String-configDefault = [multiline|-#include "../config.default"-|]
LambdaHack/Content/ActorKind.hs view
@@ -1,14 +1,15 @@ -- | Monsters and heroes for LambdaHack. module Content.ActorKind ( cdefs ) where +import Game.LambdaHack.Ability import Game.LambdaHack.Color-import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Random import Game.LambdaHack.Time -cdefs :: Content.CDefs ActorKind-cdefs = Content.CDefs+cdefs :: CDefs ActorKind+cdefs = CDefs   { getSymbol = asymbol   , getName = aname   , getFreq = afreq@@ -29,6 +30,7 @@   , asmell  = False   , aiq     = 13  -- Can see hidden doors, when he is under alien control.   , aregen  = 500+  , acanDo  = [minBound..maxBound]   }  projectile = ActorKind  -- includes homing missiles@@ -42,6 +44,7 @@   , asmell  = False   , aiq     = 0   , aregen  = maxBound+  , acanDo  = [Track]   }  eye = ActorKind@@ -49,12 +52,13 @@   , aname   = "reducible eye"   , afreq   = [("monster", 60), ("summon", 50)]   , acolor  = BrRed-  , ahp     = RollDice 3 4+  , ahp     = RollDice 7 4   , aspeed  = toSpeed 2   , asight  = True   , asmell  = False   , aiq     = 8   , aregen  = 100+  , acanDo  = [minBound..maxBound]   } fastEye = ActorKind   { asymbol = 'e'@@ -67,16 +71,18 @@   , asmell  = False   , aiq     = 12   , aregen  = 5  -- Regenerates fast (at max HP most of the time!).+  , acanDo  = [minBound..maxBound]   } nose = ActorKind   { asymbol = 'n'   , aname   = "point-free nose"   , afreq   = [("monster", 20), ("summon", 100)]   , acolor  = Green-  , ahp     = RollDice 7 2+  , ahp     = RollDice 17 2   , aspeed  = toSpeed 1.8   , asight  = False   , asmell  = True   , aiq     = 0   , aregen  = 100+  , acanDo  = [minBound..maxBound]   }
LambdaHack/Content/CaveKind.hs view
@@ -3,13 +3,13 @@  import Data.Ratio -import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs import Game.LambdaHack.Random as Random import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Misc -cdefs :: Content.CDefs CaveKind-cdefs = Content.CDefs+cdefs :: CDefs CaveKind+cdefs = CDefs   { getSymbol = csymbol   , getName = cname   , getFreq = cfreq@@ -35,7 +35,7 @@   , cdoorChance   = 1%2   , copenChance   = 1%10   , chiddenChance = 1%5-  , citemNum      = RollDice 5 2+  , citemNum      = RollDice 7 2   , cdefaultTile    = "fillerWall"   , ccorridorTile   = "darkCorridor"   , cfillerTile     = "fillerWall"@@ -52,7 +52,7 @@   , cdarkChance   = (RollDice 1 80, RollDice 1 60)   , cvoidChance   = 1%3   , cnonVoidMin   = 2-  , citemNum      = RollDice 3 2  -- few rooms+  , citemNum      = RollDice 4 2  -- few rooms   , cdefaultTile  = "floorArenaLit"   , ccorridorTile = "path"   }@@ -67,7 +67,7 @@   , cvoidChance   = 3%4   , cnonVoidMin   = 1   , cminStairDist = 50-  , citemNum      = RollDice 6 2  -- whole floor strewn with treasure+  , citemNum      = RollDice 8 2  -- whole floor strewn with treasure   , cdefaultTile  = "floorRoomLit"   , ccorridorTile = "floorRoomLit"   }@@ -80,7 +80,7 @@   , cdarkChance   = (RollDice 1 80, RollDice 1 40)   , cvoidChance   = 0   , cnonVoidMin   = 0-  , citemNum      = RollDice 3 2  -- few rooms+  , citemNum      = RollDice 4 2  -- few rooms   , cdefaultTile  = "noiseSet"   , ccorridorTile = "path"   }
+ LambdaHack/Content/FactionKind.hs view
@@ -0,0 +1,36 @@+-- | Game factions (heroes, enemies, NPCs, etc.) for LambdaHack.+module Content.FactionKind ( cdefs ) where++import Game.LambdaHack.CDefs+import Game.LambdaHack.Content.FactionKind++cdefs :: CDefs FactionKind+cdefs = CDefs+  { getSymbol = fsymbol+  , getName = fname+  , getFreq = ffreq+  , validate = fvalidate+  , content =+      [hero, monster]+  }+hero,        monster :: FactionKind++hero = FactionKind+  { fsymbol     = '@'+  , fname       = "hero"+  , ffreq       = [("hero", 1), ("playable", 50)]+  , fAiSelected = "noAbility"  -- no AI, fully manual control+  , fAiIdle     = "meleeAdjacent"+  , fenemy      = ["monster"]+  , fally       = []+  }++monster = FactionKind+  { fsymbol     = 'm'+  , fname       = "monster"+  , ffreq       = [("monster", 1), ("playable", 50), ("spawn", 1)]+  , fAiSelected = "fullAbility"+  , fAiIdle     = "fullAbility"+  , fenemy      = ["hero"]+  , fally       = []+  }
LambdaHack/Content/ItemKind.hs view
@@ -2,14 +2,14 @@ module Content.ItemKind ( cdefs ) where  import Game.LambdaHack.Color-import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs import Game.LambdaHack.Effect import Game.LambdaHack.Flavour import Game.LambdaHack.Random import Game.LambdaHack.Content.ItemKind -cdefs :: Content.CDefs ItemKind-cdefs = Content.CDefs+cdefs :: CDefs ItemKind+cdefs = CDefs   { getSymbol = isymbol   , getName = iname   , getFreq = ifreq@@ -139,7 +139,7 @@ scroll = ItemKind   { isymbol  = '?'   , iname    = "scroll"-  , ifreq    = [("dng", 6)]+  , ifreq    = [("dng", 4)]   , iflavour = zipFancy darkCol  -- arcane and old   , ieffect  = NoEffect   , icount   = intToDeep 1@@ -153,8 +153,7 @@   { ieffect  = SummonFriend   } scroll2 = scroll-  { ifreq    = [("dng", 3)]-  , ieffect  = SummonEnemy+  { ieffect  = SummonEnemy   } scroll3 = scroll   { ieffect  = Descend
LambdaHack/Content/PlaceKind.hs view
@@ -1,11 +1,11 @@ -- | Rooms, halls and passages for LambdaHack. module Content.PlaceKind ( cdefs ) where -import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs import Game.LambdaHack.Content.PlaceKind -cdefs :: Content.CDefs PlaceKind-cdefs = Content.CDefs+cdefs :: CDefs PlaceKind+cdefs = CDefs   { getSymbol = psymbol   , getName = pname   , getFreq = pfreq
LambdaHack/Content/RuleKind.hs view
@@ -1,4 +1,5 @@--- | Game rules and assorted data for LambdaHack.+{-# LANGUAGE CPP, QuasiQuotes #-}+-- | Game rules and assorted game setup data for LambdaHack. module Content.RuleKind ( cdefs ) where  -- Cabal@@ -8,10 +9,11 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Feature as F-import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs+import Multiline -cdefs :: Content.CDefs RuleKind-cdefs = Content.CDefs+cdefs :: CDefs RuleKind+cdefs = CDefs   { getSymbol = rsymbol   , getName = rname   , getFreq = rfreq@@ -39,4 +41,55 @@   , rpathsVersion  = Self.version   , ritemMelee     = ")"   , ritemProject   = "!?|/"-  }+  -- The string containing the default configuration+  -- included from file config.default.+  -- Warning: cabal does not detect that the default config is changed,+  -- so touching this file is needed to reinclude config and recompile.+  -- Note: consider code.haskell.org/~dons/code/compiled-constants+  -- as soon as the config file grows very big.+  , rconfigDefault = [multiline|+#include "../../config.default"+|]+  -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are+  -- allowed. The picture should be exactly 24 rows by 80 columns,+  -- plus an extra frame of any charecters that is ignored for all purposes.+  -- For a different screen size, the picture is centered and the outermost+  -- rows and columns cloned. When displayed in the Main Menu screen,+  -- it's overwritten with the game version string and keybinding strings.+  -- The game version string begins and ends with a space and is placed+  -- in the very bottom right corner. The keybindings overwrite places+  -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden+  -- everywhere else. Exactly five such places with 25 left braces+  -- are required, at most one per row, and all are overwritten+  -- with text that is flushed left and padded with spaces.+  -- The Main Menu is displayed dull white on black.+  -- TODO: Highlighted keybinding is in inverse video or bright white on grey+  -- background. The spaces that pad keybindings are not highlighted.+  , rmainMenuArt   = [multiline|+----------------------------------------------------------------------------------+|                                                                                |+|                                                                                |+|                      >> LambdaHack <<                                          |+|                                                                                |+|                                                                                |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                                                                                |+|                                                                                |+|                                                                                |+|                                                                                |+|                                                                                |+|                                                                                |+|                                                                                |+|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |+----------------------------------------------------------------------------------+|]}
+ LambdaHack/Content/StrategyKind.hs view
@@ -0,0 +1,52 @@+-- | AI strategies for LambdaHack.+module Content.StrategyKind ( cdefs ) where++import Game.LambdaHack.Ability+import Game.LambdaHack.CDefs+import Game.LambdaHack.Content.StrategyKind++cdefs :: CDefs StrategyKind+cdefs = CDefs+  { getSymbol = ssymbol+  , getName = sname+  , getFreq = sfreq+  , validate = svalidate+  , content =+      [noAbility, onlyFollowTrack, meleeAdjacent, meleeAndRanged, fullAbility]+  }+noAbility,        onlyFollowTrack, meleeAdjacent, meleeAndRanged, fullAbility :: StrategyKind++noAbility = StrategyKind  -- not even projectiles will fly+  { ssymbol    = '@'+  , sname      = "noAbility"+  , sfreq      = [("noAbility", 1)]+  , sabilities = []+  }++onlyFollowTrack = StrategyKind  -- projectiles enabled+  { ssymbol    = '@'+  , sname      = "onlyFollowTrack"+  , sfreq      = [("onlyFollowTrack", 1)]+  , sabilities = [Track]+  }++meleeAdjacent = StrategyKind+  { ssymbol    = '@'+  , sname      = "meleeAdjacent"+  , sfreq      = [("meleeAdjacent", 1)]+  , sabilities = [Melee, Track]+  }++meleeAndRanged = StrategyKind  -- melee and reaction fire+  { ssymbol    = '@'+  , sname      = "meleeAndRanged"+  , sfreq      = [("meleeAndRanged", 1)]+  , sabilities = [Melee, Ranged, Track]+  }++fullAbility = StrategyKind+  { ssymbol    = '@'+  , sname      = "fullAbility"+  , sfreq      = [("fullAbility", 1)]+  , sabilities = [minBound..maxBound]+  }
LambdaHack/Content/TileKind.hs view
@@ -2,14 +2,14 @@ module Content.TileKind ( cdefs ) where  import Game.LambdaHack.Color-import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.CDefs import qualified Game.LambdaHack.Effect as Effect import Game.LambdaHack.Feature import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Random as Random -cdefs :: Content.CDefs TileKind-cdefs = Content.CDefs+cdefs :: CDefs TileKind+cdefs = CDefs   { getSymbol = tsymbol   , getName = tname   , getFreq = tfreq
LambdaHack/Main.hs view
@@ -3,57 +3,32 @@ -- resulting in an executable game. module Main ( main ) where -import Data.Maybe--import qualified Game.LambdaHack.Display as Display import qualified Game.LambdaHack.Kind as Kind import qualified Content.ActorKind import qualified Content.CaveKind+import qualified Content.FactionKind import qualified Content.ItemKind import qualified Content.PlaceKind import qualified Content.RuleKind+import qualified Content.StrategyKind import qualified Content.TileKind-import qualified Game.LambdaHack.Start as Start-import Game.LambdaHack.Command-import Game.LambdaHack.Display-import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.Turn import Game.LambdaHack.Action-import qualified Game.LambdaHack.BindingAction as BindingAction--import qualified ConfigDefault---- | Gather together the content and verify its consistency.-cops :: Kind.COps-cops = Kind.COps-  { coactor = Kind.createOps Content.ActorKind.cdefs-  , cocave  = Kind.createOps Content.CaveKind.cdefs-  , coitem  = Kind.createOps Content.ItemKind.cdefs-  , coplace = Kind.createOps Content.PlaceKind.cdefs-  , corule  = Kind.createOps Content.RuleKind.cdefs-  , cotile  = Kind.createOps Content.TileKind.cdefs-  }---- | Wire together config, content and the definitions of game commands--- to form the starting game session. Evaluate to check for errors.-sess :: Config.CP -> FrontendSession -> Session-sess config sfs =-  let !skeyb = BindingAction.stdBinding config cmdSemantics cmdDescription-      !scops = cops-  in Session{..}---- | Create the starting game config from the default config file--- and initialize the engine with the starting session.-start :: IO (String, FrontendSession -> IO ())-start = do-  config <- Config.mkConfig ConfigDefault.configDefault-  -- The only option taken not from conif in savegame, but from fresh config.-  let configFont = fromMaybe "" $ Config.getOption config "ui" "font"-  return (configFont, Start.start config . sess config)+import Game.LambdaHack.BindingAction --- | Fire up the frontend with the engine fueled by config and content.+-- | Fire up the frontend with the engine fueled by content. -- Which of the frontends is run depends on the flags supplied -- when compiling the engine library. main :: IO ()-main = do-  (configFont, loop) <- start-  Display.startup configFont loop+main =+  let cops = Kind.COps+        { coactor = Kind.createOps Content.ActorKind.cdefs+        , cocave  = Kind.createOps Content.CaveKind.cdefs+        , cofact  = Kind.createOps Content.FactionKind.cdefs+        , coitem  = Kind.createOps Content.ItemKind.cdefs+        , coplace = Kind.createOps Content.PlaceKind.cdefs+        , corule  = Kind.createOps Content.RuleKind.cdefs+        , costrat = Kind.createOps Content.StrategyKind.cdefs+        , cotile  = Kind.createOps Content.TileKind.cdefs+        }+  in startFrontend cops stdBinding handleTurn
PLAYING.md view
@@ -19,7 +19,8 @@ Dungeon ------- -The goal of the hero is to explore the dungeon, battle the horrors within,+The heroes are marked on the map with symbol '@' and with '1', '2', ..., '9'.+Their goal is to explore the dungeon, battle the horrors within, gather as much gold and gems as possible, and escape to tell the tale. The dungeon consists of 10 levels and each level consists of 80 by 21 tiles. The basic tiles are as follows.@@ -57,8 +58,9 @@                 /|\       /|\                1 2 3     b j n -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.+SHIFT (or CTRL) and a movement key make the selected hero run in the indicated+direction, until anything of interest is spotted. '5' and '.' use a turn+to brace for combat, which gives a chance to block blows next turn. Melee, searching for secret doors and opening closed doors can be done by bumping into a monster, a wall and a door, respectively. @@ -69,8 +71,9 @@                <       ascend a level*                >       descend a level*                ?       display help-               Q       quit without saving-               X       save and exit the game+               R       restart game*+               S       save game+               X       save and exit*                c       close a door*                d       drop an object*                g       get an object*@@ -92,21 +95,23 @@ 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+               key       command+               ESC       cancel action+               RET       accept choice+               SPACE     clear messages+               TAB       cycle among heroes on level+               SHIFT-TAB cycle among heroes in the dungeon+               *         target monster+               +         swerve targeting line+               -         unswerve targeting line+               /         target location+               D         dump current configuration+               P         display previous messages+               [         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, all entered with the CTRL key modifier. Use at your own peril!@@ -120,9 +125,9 @@ Monsters -------- -The hero is not alone in the dungeon. Monsters roam the dark caves+Heroes are not alone in the dungeon. Monsters roam the dark caves and crawl from damp holes day and night. While heroes pay attention-to all other party members and take moves sequentially, one after another,+to all other party members and take care to move one at a time, monsters don't care about each other and all move at once, sometimes brutally colliding by accident. @@ -156,4 +161,4 @@ If all heroes die, your score is halved and only the treasure carried by the last standing hero counts. You are free to start again from a different entrance to the dungeon, but all your previous wealth-is gone and fresh, fearless enemies bar your way.+is gone and fresh, undaunted enemies bar your way.
README.md view
@@ -4,7 +4,7 @@ This is an alpha release of LambdaHack, a [Haskell] [1] game engine library for [roguelike] [2] games of arbitrary theme, size and complexity, packaged together with a small example dungeon crawler. When completed,-it will let you specify content to be procedurally generated,+the engine will let you specify content to be procedurally generated, define the AI behaviour on top of the generic content-independent rules and compile a ready-to-play game binary, using either the supplied or a custom-made main loop. Several frontends are available@@ -64,9 +64,8 @@ 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.+The current code was tested with GHC 7.6.1, but probably works with GHC > 7.2.+A [few tweaks] [7] are needed to compile with 7.0.  If you are using the curses or vty frontends, numerical keypad may not work correctly depending on the versions
config.default view
@@ -21,6 +21,7 @@ ; plus: EpsIncr True ; minus: EpsIncr False ; Tab: HeroCycle+; ISO_Left_Tab: HeroBack ; ; ; ; Items. ; g: Pickup@@ -31,13 +32,13 @@ ; z: Project { verb = "zap", object = "wand", syms = "/" } ; t: Project { verb = "throw", object = "missile", syms = "|" } ; ;-; ; Saving or ending the game.-; X: GameSave-; Q: GameQuit+; ; Saving, exiting and restarting the game.+; X: GameExit+; R: GameRestart+; S: GameSave ; ; ; ; Information for the player. ; P: History-; V: Version ; question: Help ; D: CfgDump ; ;@@ -45,7 +46,7 @@ ; KP_Begin: Wait ; Escape: Cancel ; Return: Accept-; space: Redraw+; space: Clear  ; [dungeon] ; ; Fixed caves for the first levels, then randomly picked caves.@@ -77,8 +78,9 @@ ; HeroName_4: Samuel Saunders ; HeroName_5: Roger Robin ; baseHP: 50-; extraHeroes: 0+; extraHeroes: 2 ; firstDeathEnds: False+; faction: hero  ; [macros] ; ; Handy with Vi keys:
scores view

binary file changed (45 → 133 bytes)