packages feed

LambdaHack 0.1.20110117 → 0.1.20110918

raw patch · 58 files changed

+4561/−2548 lines, 58 filesdep +template-haskelldep ~filepathnew-uploaderbinary-added

Dependencies added: template-haskell

Dependency ranges changed: filepath

Files

CREDITS view
@@ -1,4 +1,5 @@-Developers who have contributed significantly to LambdaHack:+All kinds of contributions to LambdaHack are gratefully welcome!+Some of the contributors are listed below, in chronological order.  Andres Loeh Mikolaj Konarski
LambdaHack.cabal view
@@ -1,14 +1,25 @@-cabal-version: >= 1.2+cabal-version: >= 1.6 name:          LambdaHack-version:       0.1.20110117+version:       0.1.20110918 license:       BSD3 license-file:  LICENSE+tested-with:   GHC == 6.12.3, GHC == 7.3.20110911 data-files:    LICENSE, CREDITS, DESIGN.markdown, PLAYING.markdown,-               README.markdown, LambdaHack.config.example-author:        Andres Loeh <mail@andres-loeh.de>+               README.markdown, src/config.default, scores+author:        Andres Loeh, Mikolaj Konarski maintainer:    Andres Loeh <mail@andres-loeh.de>-description:   a small roguelike game-synopsis:      a small roguelike game+description:   This is an alpha release of LambdaHack, a roguelike game engine+               packaged together with a small example roguelike game+               (not yet well separated; this is future work,+               together with improving the AI monad EDSL,+               so that the rules for synthesising monster behaviour+               from game content are more readable and easier to debug).+               .+               Another game using this engine is Allure of the Stars+               at <http://hackage.haskell.org/package/Allure>.+synopsis:      A roguelike game engine in early development+homepage:      http://github.com/kosmikus/LambdaHack+bug-reports:   http://github.com/kosmikus/LambdaHack/issues category:      Game build-type:    Simple @@ -21,21 +32,34 @@   default:       False  executable LambdaHack-  main-is:       LambdaHack.hs+  main-is:       Main.hs   hs-source-dirs:src-  other-modules: Actor, Action, Actions, Command, Display, Display2, Dungeon,-                 File, FOV, Frequency, Geometry, Item, ItemState,-                 Keys, Keybindings, LambdaHack, Level, LevelState, Message,-                 Monster, Perception, Random, Save, State, Strategy,-                 StrategyState, Turn, Version, HighScores, Config,-                 Grammar-  build-depends: base >= 4 && <5, containers >= 0.1 && < 1,+  other-modules: Action, Actions, ActorAdd, ActorKind, Actor, ActorState,+                 Color, Command, Config, ConfigDefault,+                 Display, Dungeon, DungeonState,+                 Effect, EffectAction, File, Flavour,+                 FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,+                 Frequency, Geometry, GeometryRnd, Grammar,+                 HighScores, Item, ItemKind, ItemAction,+                 Keys, Keybindings, Level, LevelState,+                 Main, Message, Multiline, Perception, Random,+                 Save, State, Strategy, StrategyState,+                 Turn, Terrain, Version+  build-depends: base >= 4 && < 5, containers >= 0.1 && < 1,                  binary >= 0.4 && < 1,                  random >= 1 && < 2, zlib >= 0.4 && < 1,                  bytestring >= 0.9 && < 1, directory >= 1 && < 2,                  mtl >= 1.1 && < 3, old-time, ConfigFile >= 1.0.6 && < 2,-                 MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 1.2-  extensions:    CPP, FlexibleContexts+                 MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 2+  extensions:    CPP, FlexibleContexts, QuasiQuotes, MultiParamTypeClasses,+                 RankNTypes, BangPatterns++  if impl(ghc < 7.0)+     -- GHC 6.12.3 does not like template-haskell 2.6 and 7.3 does not like 2.5+      build-depends: template-haskell >= 2.5 && < 2.6+  else+      build-depends: template-haskell >= 2.5+   if flag(curses) {     other-modules: Display.Curses     build-depends: hscurses >= 1.3 && < 2@@ -50,3 +74,7 @@     cpp-options:   -DGTK     ghc-options:   -threaded   } }++source-repository head+  type:              git+  location:          git://github.com/kosmikus/LambdaHack.git
− LambdaHack.config.example 
@@ -1,25 +0,0 @@-# LambdaHack looks for this file in ~/.LambdaHack/LambdaHack.config--# If you contribute to LambdaHack, please create directory ~/.LambdaHack/-# and move this example config file to ~/.LambdaHack/LambdaHack.config.-# Optionally, also copy LambdaHack.scores to ~/.LambdaConfig/.-# In this way, you won't accidentally commit your private high scores-# (nor your save files) to LambdaHack git repository.--# paths to various game files; relative to ~/.LambdaHack/-# (or analogous prefixes for other OSes, see getAppUserDataDirectory)-[files]-savegame:   LambdaHack.save-highscores: LambdaHack.scores--[engine]-fov_mode: shadow-#fov_mode: diagonal-#fov_mode: permissive-fov_radius: 40--[dungeon]-depth: 10-level3: bigroom-level10: noiseroom-#level1: noiseroom
PLAYING.markdown view
@@ -1,58 +1,71 @@ Playing LambdaHack ================== -Playing the game consist of walking around the dungeon and bumping-into things (doors, monsters, treasure). Once the few basic command keys-and on-screen symbols are learned, mastery and enjoyment of the game-is the matter of tactical skill and literary imagination.+Playing LambdaHack involves walking around the dungeon,+alone or in a party of fearless adventurers, jumping between levels,+bumping into monsters, doors and walls, gathering magical treasure+and making creative use of it. The bloodthirsty monsters do the same,+intelligence allowing, while tirelessly chasing the noble heroes+by smell and night-sight. -To be honest, right now you need a lot of imagination, since the game-is very basic, though playable and winnable. Contributions welcome.+Once the few basic command keys and on-screen symbols are learned,+mastery and enjoyment of the game is the matter of tactical skill+and literary imagination. To be honest, you need a lot of imagination+right now, since the game is still quite basic, though playable and winnable.+Contributions welcome.   Dungeon ------- -The goal of the hero is to explore the dungeon from top to the very bottom-(and grab lots of shiny treasure and gear on the way).+The goal of the hero 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 tiles are as follows:+The basic tiles are as follows.                 dungeon terrain type               on-screen symbol                floor                              .                wall (horizontal and vertical)     - and |+               pillar wall                        O                corridor                           #                stairs (up and down)               < and >                closed door                        ++               open door                          | and -                rock                               blank -The game world is persistent, i.e., every time the hero visits a level-during one game, the level should look the same.+The game world is persistent, i. e., every time a hero visits a level+during a single game, the level layout looks the same. Some items+aid in dungeon exploration, e.g., a ring of searching improves the speed+of finding hidden doors by heroes and monsters. The higher the magical+bonus displayed for this and other dungeon items, the more effective it is.+Only the best item carried in a hero's or monster's inventory counts.+You can throw the rest away, but beware that your adversaries may pick it up+and use it against you.   Keys ---- -Here are a few keys you can use in the game:+Below are the basic default keys.                 key    command+               .      wait+               <      ascend a level+               >      descend a level+               ?      display help+               Q      quit without saving+               X      save and exit the game                c      close a door                d      drop an object+               g      get an object                i      display inventory-               o      open a door-               s      search for secret doors+               o      open a door (alternatively, you can bump into a door)                q      quaff a potion-               M      display previous messages-               S      save and quit the game-               Q      quit without saving-               .      wait-               ,      pick up an object-               :      look around-               <      ascend a level-               >      descend a level+               r      read a scroll+               s      search for secret doors (or you can bump into a wall)  One of the ways of moving throughout the level is with the vi text editor keys-(also known as "Rogue-like keys"):+(also known as "Rogue-like keys").                 key    command                k      up@@ -67,45 +80,75 @@ Pressing a capital letter corresponding to a direction key will have the hero run in that direction until something interesting occurs. -It's also possible to move using the numerical keypad, with Shift for running-and the middle '5' key for resting. (If you are using the curses frontend,+It is also possible to move using the numerical keypad, with Shift for running+and the middle '5' key for waiting. (If you are using the curses frontend, numerical keypad may not work correctly for terminals with broken terminfo,-e.g., gnome terminal tends to have problems, while xterm works fine.)+e.g., gnome terminal has problems, while xterm works fine,+though only under older versions of hscurses.) -Below are also some debug and cheat keys. Use at your peril!+To make a distance attack, you need to set your target first.+The targeting commands are listed below, together with all the other+less common player commands.                 key    command-               v      display the version of the game+               ESC    cancel action+               RET    accept choice+               TAB    cycle among heroes on level+               0--9   select a hero anywhere in the dungeon (gtk only)+               *      target monster+               /      target location+               D      dump current configuration+               P      display previous messages+               V      display game version+               a      aim a wand+               t      throw a weapon++There are also some debug and cheat keys. Use at your peril!++               key    command                O      toggle "omniscience"-               I      display level meta-data-               R      toggle smell display-               T      toggle level generation sequence-               V      toggle field of vision display+               I      inform about level meta-data+               R      rotate display modes+               T      cycle among level terrain generation stages   Monsters -------- -The hero is not alone in the dungeon. Monsters roam the game world, too.-Monsters inhabit specific locations on the game map, and can be seen-if the tile they are on can be seen by the hero.-Every monster gets a turn per move of the hero. Monster moves-are restricted in the same way as hero moves, i.e., they cannot move-into obstacles like walls or rock. Some monsters-ignore the hero, others chase him only when they see him-and the especially dangerous kind is able to smell the hero.+The hero is 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,+monsters don't care about each other and all move at once,+sometimes brutally colliding by mistake. -When the hero moves into a monster or a monster bumps into the hero,-combat occurs. Whenever combat occurs, the attacked party may lose some health.-If the hero dies, the game ends.+When the hero bumps into a monster or a monster attacks the hero,+melee combat occurs. The best weapon carried by each opponent+is taken into account for calculating bonus damage. The total damage+the current hero can potentially inflict is displayed at the bottom+of the screen. The total damage potential of a monster may change+as it finds and picks up new weapons. Heroes and monsters running+into another (with the Shift key) do not inflict damage, but change places.+This gives the opponent a free blow, but can improve the tactical situation+or aid escape. +Throwing weapons at targets wounds them, consuming the weapon in the process.+You can target a monster with the '*' key from the top row or numpad.+You may throw any object in your possession+(press '*' for a non-standard choice) or on the floor (press '-'),+though only objects of a few kinds inflict any damage.+Whenever a monster or a hero hit points reach zero, the combatant dies.+When the last hero dies, the game ends. + On Winning and Dying -------------------- -If you happen to die, you are free to start again from the first level-of the dungeon, but all your treasure is gone and the dungeon will look-different this time.+You win the game if you escape the dungeon alive. Your score is+the sum of all gold you've plundered plus 100gp for each gem.+Only the loot in possession of the party members on level 1 counts+(the rest is considered MIA). -You win the game if you escape the dungeon alive with treasure and valuable-items --- the more the better!+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 the first level of the dungeon, but all your wealth and items+are gone and the dungeon and it's treasure look differently.
README.markdown view
@@ -2,6 +2,10 @@ ==========  LambdaHack is a small [roguelike] [1] game written in [Haskell] [2].+It is getting more and more configurable and aims to become a flexible+rouguelike engine, suitable for large and small dungeon crawling games+of arbitrary themes. In particular, we try to keep the AI code independent+of particular monster, item and terrain definitions.   Compilation and installation@@ -21,6 +25,17 @@ or you may try one of the terminal frontends with      cabal install -fvty+++Savegame directory+------------------++If you don't want LambdaHack to write to the current directory,+create a personal savegame directory (on Linux it's ~/.LambdaHack/).+and copy the scores file there. You may also want to+copy the configuration file src/config.default to+~/.LambdaHack/config and modify it, but be careful changing+gameplay options --- they can easily unbalance or break the game.   Further information
+ scores view

binary file changed (absent → 144 bytes)

src/Action.hs view
@@ -3,23 +3,30 @@  import Control.Monad import Control.Monad.State hiding (State)+import Data.List as L+import qualified Data.IntMap as IM -- import System.IO (hPutStrLn, stderr) -- just for debugging  import Perception-import Display2 hiding (display)+import Display hiding (display) import Message import State+import Level+import Actor+import ActorState+import ActorKind+import qualified Save  newtype Action a = Action   { runAction ::       forall r .       Session ->-      IO r ->                                          -- shutdown cont-      Perception ->                                    -- cached perception-      (State -> Message -> a -> IO r) ->               -- continuation-      IO r ->                                          -- failure/reset cont-      State ->                                         -- current state-      Message ->                                       -- current message+      IO r ->                             -- shutdown cont+      Perceptions ->                      -- cached perception+      (State -> Message -> a -> IO r) ->  -- continuation+      IO r ->                             -- failure/reset cont+      State ->                            -- current state+      Message ->                          -- current message       IO r   } @@ -51,7 +58,7 @@ handlerToIO session state msg h =   runAction h     session-    (shutdown session)         -- get out of the game+    (Save.rmBkp (sconfig state) >> shutdown session)  -- get out of the game     (perception_ state)        -- cached perception     (\ _ _ x -> return x)      -- final continuation returns result     (ioError $ userError "unhandled abort")@@ -66,25 +73,29 @@ sessionIO :: (Session -> IO a) -> Action a sessionIO f = Action (\ s e p k a st ms -> f s >>= k st ms) --- | Display the current level, with the current message.+-- | Display the current level with modified current message.+displayGeneric :: ColorMode -> (String -> String) -> Action Bool+displayGeneric dm f = Action (\ s e p k a st ms -> displayLevel dm s p st (f ms) Nothing >>= k st ms)++-- | Display the current level, with the current message and color. Most common. display :: Action Bool-display = Action (\ s e p k a st ms -> displayLevel s p st ms Nothing >>= k st ms)+display = displayGeneric ColorFull id  -- | Display an overlay on top of the current screen. overlay :: String -> Action Bool-overlay txt = Action (\ s e p k a st ms -> displayLevel s p st ms (Just txt) >>= k st ms)+overlay txt = Action (\ s e p k a st ms -> displayLevel ColorFull s p st ms (Just txt) >>= k st ms) --- | Set the current message.-message :: Message -> Action ()-message nm = Action (\ s e p k a st ms -> k st nm ())+-- | Wipe out and set a new value for the current message.+messageReset :: Message -> Action ()+messageReset nm = Action (\ s e p k a st ms -> k st nm ())  -- | Add to the current message. messageAdd :: Message -> Action () messageAdd nm = Action (\ s e p k a st ms -> k st (addMsg ms nm) ())  -- | Clear the current message.-resetMessage :: Action Message-resetMessage = Action (\ s e p k a st ms -> k st "" ms)+messageClear :: Action ()+messageClear = Action (\ s e p k a st ms -> k st "" ())  -- | Get the current message. currentMessage :: Action Message@@ -99,6 +110,18 @@ abort :: Action a abort = Action (\ s e p k a st ms -> a) +-- | Perform an action and signal an error if the result is False.+assertTrue :: Action Bool -> Action ()+assertTrue h = do+  b <- h+  when (not b) $ error "assertTrue: failure"++-- | Perform an action and signal an error if the result is True.+assertFalse :: Action Bool -> Action ()+assertFalse h = do+  b <- h+  when b $ error "assertFalse: failure"+ -- | Set the current exception handler. First argument is the handler, -- second is the computation the handler scopes over. tryWith :: Action () -> Action () -> Action ()@@ -123,33 +146,37 @@  -- | Print the given message, then abort. abortWith :: Message -> Action a-abortWith msg =-  do-    message msg-    display-    abort+abortWith msg = do+  messageReset msg+  display+  abort +neverMind :: Bool -> Action a+neverMind b = abortIfWith b "never mind"+ -- | Abort, and print the given message if the condition is true. abortIfWith :: Bool -> Message -> Action a-abortIfWith True  = abortWith-abortIfWith False = const abort+abortIfWith True msg = abortWith msg+abortIfWith False _  = abortWith "" --- | Print message, await confirmation. Return value indicates if the--- player tried to abort/escape.-messageMoreConfirm :: Message -> Action Bool-messageMoreConfirm msg =-  do-    message (msg ++ more)-    display-    session getConfirm+-- | Print message, await confirmation. Return value indicates+-- if the player tried to abort/escape.+messageMoreConfirm :: ColorMode -> Message -> Action Bool+messageMoreConfirm dm msg = do+  messageAdd (msg ++ more)+  displayGeneric dm id+  session getConfirm +-- | Print message, await confirmation, ignore confirmation.+messageMore :: Message -> Action ()+messageMore msg = messageClear >> messageMoreConfirm ColorFull msg >> return ()+ -- | Print a yes/no question and return the player's answer. messageYesNo :: Message -> Action Bool-messageYesNo msg =-  do-    message (msg ++ yesno)-    display-    session getYesNo+messageYesNo msg = do+  messageReset (msg ++ yesno)+  displayGeneric ColorBW id  -- turn player's attention to the choice+  session getYesNo  -- | Print a message and an overlay, await confirmation. Return value -- indicates if the player tried to abort/escape.@@ -161,12 +188,12 @@ messageOverlaysConfirm :: Message -> [String] -> Action Bool messageOverlaysConfirm msg [] =   do-    resetMessage+    messageClear     display     return True messageOverlaysConfirm msg (x:xs) =   do-    message msg+    messageReset msg     b <- overlay (x ++ more)     if b       then do@@ -177,11 +204,10 @@           else stop       else stop   where-    stop =-      do-        resetMessage-        display-        return False+    stop = do+      messageClear+      display+      return False  -- | Update the cached perception for the given computation. withPerception :: Action () -> Action ()@@ -189,6 +215,41 @@                             runAction h s e (perception_ st) k a st ms)  -- | Get the current perception.-currentPerception :: Action Perception+currentPerception :: Action Perceptions currentPerception = Action (\ s e p k a st ms -> k st ms p) +-- | If in targeting mode, check if the current level is the same+-- as player level and refuse performing the action otherwise.+checkCursor :: Action () -> Action ()+checkCursor h = do+  cursor <- gets scursor+  level  <- gets slevel+  if creturnLn cursor == lname level+    then h+    else abortWith "this command does not work on remote levels"++updateAnyActor :: ActorId -> (Actor -> Actor) -> Action ()+updateAnyActor actor f = modify (updateAnyActorBody actor f)++updatePlayerBody :: (Actor -> Actor) -> Action ()+updatePlayerBody f = do+  pl <- gets splayer+  updateAnyActor pl f++-- | Advance the move time for the given actor.+advanceTime :: ActorId -> Action ()+advanceTime actor = do+  time <- gets stime+  let upd m = m { atime = time + (bspeed (akind m)) }+  -- A hack to synchronize the whole party:+  pl <- gets splayer+  if (actor == pl || isAHero actor)+    then do+           modify (updateLevel (updateHeroes (IM.map upd)))+           when (not $ isAHero pl) $ updatePlayerBody upd+    else updateAnyActor actor upd++playerAdvanceTime :: Action ()+playerAdvanceTime = do+  pl <- gets splayer+  advanceTime pl
src/Actions.hs view
@@ -5,28 +5,39 @@ import Data.Function import Data.List as L import Data.Map as M+import qualified Data.IntMap as IM import Data.Maybe import Data.Set as S import System.Time  import Action-import Actor hiding (updateActor)-import Display2 hiding (display)+import Display hiding (display) import Dungeon import Geometry import Grammar import qualified HighScores as H import Item+import qualified ItemKind import qualified Keys as K import Level import LevelState import Message-import Monster+import Actor+import ActorState+import ActorKind+import ActorAdd import Perception import Random-import qualified Save as S import State+import qualified Config+import qualified Save+import Terrain+import qualified Effect+import EffectAction +-- The Action stuff that is independent from ItemAction.hs.+-- (Both depend on EffectAction.hs).+ displayHistory :: Action () displayHistory =   do@@ -34,6 +45,14 @@     messageOverlayConfirm "" (unlines hst)     abort +dumpConfig :: Action ()+dumpConfig =+  do+    config <- gets sconfig+    let fn = "config.dump"+    liftIO $ Config.dump fn config+    abortWith $ "Current configuration dumped to file " ++ fn ++ "."+ saveGame :: Action () saveGame =   do@@ -42,9 +61,12 @@       then do         -- Save the game state         st <- get-        liftIO $ S.saveGame st-        let total = calculateTotal (splayer st)-        handleScores False False False total+        liftIO $ Save.saveGame st+        ln <- gets (lname . slevel)+        let total = calculateTotal st+            status = H.Camping ln+        go <- handleScores False status total+        when go $ messageMore "See you soon, stronger and braver!"         end       else abortWith "Game resumed." @@ -53,17 +75,86 @@   do     b <- messageYesNo "Really quit?"     if b-      then end -- TODO: why no highscore?+      then end -- TODO: why no highscore? no display, because the user may be in a hurry, since he quits the game instead of getting himself killed properly? no score recording, not to polute the scores list with games that the player didn't even want to end honourably?       else abortWith "Game resumed." +-- | End targeting mode, accepting the current location or not.+endTargeting :: Bool -> Action ()+endTargeting accept = do+  returnLn <- gets (creturnLn . scursor)+  target   <- gets (atarget . getPlayerBody)+  cloc     <- gets (clocation . scursor)+  lvlSwitch returnLn  -- return to the original level of the player+  modify (updateCursor (\ c -> c { ctargeting = False }))+  let isEnemy = case target of TEnemy _ _ -> True ; _ -> False+  when (not isEnemy) $+    if accept+       then updatePlayerBody (\ p -> p { atarget = TLoc cloc })+       else updatePlayerBody (\ p -> p { atarget = TCursor })+  endTargetingMsg++endTargetingMsg :: Action ()+endTargetingMsg = do+  pkind  <- gets (akind . getPlayerBody)+  target <- gets (atarget . getPlayerBody)+  state  <- get+  let verb = "target"+      targetMsg = case target of+                    TEnemy a _ll ->+                      case findActorAnyLevel a state of+                        Just (_, m) -> objectActor (akind m)+                        Nothing     -> "a long gone adversary"+                    TLoc loc -> "location " ++ show loc+                    TCursor  -> "current cursor position continuously"+  messageAdd $ subjectActorVerb pkind verb ++ " " ++ targetMsg ++ "."++-- | Cancel something, e.g., targeting mode, resetting the cursor+-- to the position of the player. Chosen target is not invalidated.+cancelCurrent :: Action ()+cancelCurrent = do+  targeting <- gets (ctargeting . scursor)+  if targeting+    then endTargeting False+    else abortWith "Press Q to quit."++-- | Accept something, e.g., targeting mode, keeping cursor where it was.+-- Or perform the default action, if nothing needs accepting.+acceptCurrent :: Action () -> Action ()+acceptCurrent h = do+  targeting <- gets (ctargeting . scursor)+  if targeting+    then endTargeting True+    else h  -- nothing to accept right now++moveCursor :: Dir -> Int -> Action ()+moveCursor dir n = do+  (sy, sx) <- gets (lsize . slevel)+  let upd cursor =+        let (ny, nx) = iterate (`shift` dir) (clocation cursor) !! n+            cloc = (max 1 $ min ny (sy-1), max 1 $ min nx (sx-1))+        in  cursor { clocation = cloc }+  modify (updateCursor upd)+  doLook++-- TODO: Think about doing the mode dispatch elsewhere, especially if over+-- time more and more commands need to do the dispatch inside their code+-- (currently only a couple do). move :: Dir -> Action ()-move = moveOrAttack True True APlayer+move dir = do+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if targeting then moveCursor dir 1 else moveOrAttack True True pl dir  run :: Dir -> Action ()-run dir =-  do-    modify (updatePlayer (\ p -> p { mdir = Just dir }))-    moveOrAttack False False APlayer dir -- attacks and opening doors disallowed while running+run dir = do+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if targeting+    then moveCursor dir 10+    else do+      updatePlayerBody (\ p -> p { adir = Just dir })+      -- attacks and opening doors disallowed while running+      moveOrAttack False False pl dir  -- | This function implements the actual "logic" of running. It checks if we -- have to stop running because something interested happened, and it checks@@ -72,27 +163,37 @@ continueRun dir =   do     state <- get-    let lvl   @(Level   { lmonsters = ms, lmap = lmap }) = slevel  state-    let player@(Monster { mloc = loc })                  = splayer state-    let mslocs = S.fromList (L.map mloc ms)-    let t      = lmap `at` loc  -- tile at current location-    per <- currentPerception-    msg <- currentMessage-    let monstersVisible = not (S.null (mslocs `S.intersection` pvisible per))-    let newsReported    = not (L.null msg)-    let itemsHere       = not (L.null (titems t))-    let dirOK           = accessible lmap loc (loc `shift` dir)+    loc   <- gets (aloc . getPlayerBody)+    per   <- currentPerception+    msg   <- currentMessage+    ms    <- gets (lmonsters . slevel)+    hs    <- gets (lheroes . slevel)+    lmap  <- gets (lmap . slevel)+    pl    <- gets splayer+    let dms = case pl of+                AMonster n -> IM.delete n ms  -- don't be afraid of yourself+                AHero _ -> ms+        mslocs = S.fromList (L.map aloc (IM.elems dms))+        monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per))+        newsReported    = not (L.null msg)+        t         = lmap `at` loc  -- tile at current location+        itemsHere = not (L.null (titems t))+        heroThere = L.elem (loc `shift` dir) (L.map aloc (IM.elems hs))+        dirOK     = accessible lmap loc (loc `shift` dir)     -- What happens next is mostly depending on the terrain we're currently on.     let exit (Stairs  {}) = True         exit (Opening {}) = True         exit (Door    {}) = True         exit _            = False     let hop t-          | monstersVisible || newsReported || itemsHere || exit t = abort+          | monstersVisible || heroThere+            || newsReported || itemsHere || exit t = abort         hop Corridor =           -- in corridors, explore all corners and stop at all crossings+          -- TODO: even in corridors, stop if you run past an exit (rare)           let ns = L.filter (\ x -> distance (neg dir, x) > 1-                                    && accessible lmap loc (loc `shift` x))+                                    && (accessible lmap loc (loc `shift` x))+                                        || openable 1 lmap (loc `shift` x))                             moves               allCloseTo main = L.all (\ d -> distance (main, d) <= 1) ns           in  case ns of@@ -109,485 +210,431 @@           let ns = L.filter (\ x -> x /= dir && distance (neg dir, x) > 1) moves               ls = L.map (loc `shift`) ns               as = L.filter (\ x -> accessible lmap loc x-                                    || openable 0 lmap x) ls+                                    || openable 1 lmap x) ls               ts = L.map (tterrain . (lmap `at`)) as           in  if L.any exit ts then abort else run dir     hop (tterrain t) -stopRunning :: Action ()-stopRunning = modify (updatePlayer (\ p -> p { mdir = Nothing }))- ifRunning :: (Dir -> Action a) -> Action a -> Action a ifRunning t e =   do-    mdir <- gets (mdir . splayer)-    maybe e t mdir---- | Store current message in the history and reset current message.-history :: Action ()-history =-  do-    msg <- resetMessage-    unless (L.null msg) $-      modify (updateHistory (take 500 . ((msg ++ " "):)))-    -- TODO: make history max configurable+    adir <- gets (adir . getPlayerBody)+    maybe e t adir  -- | Update player memory. remember :: Action () remember =   do     per <- currentPerception-    let vis         = S.toList (pvisible per)+    let vis         = S.toList (ptvisible per)     let rememberLoc = M.update (\ (t,_) -> Just (t,t))-    modify (updateLevel (updateLMap (\ lmap -> foldr rememberLoc lmap vis)))--checkHeroDeath :: Action ()-checkHeroDeath =-  do-    player <- gets splayer-    let php = mhp player-    when (php <= 0) $ do-      messageAdd more-      display-      session getConfirm-      go <- messageMoreConfirm "You die."-      when go $ do-        let total = calculateTotal player-        handleScores True True False total-      end--neverMind :: Bool -> Action a-neverMind b = abortIfWith b "never mind"+    modify (updateLevel (updateLMap (\ lmap -> L.foldr rememberLoc lmap vis)))  -- | Open and close doors openclose :: Bool -> Action () openclose o =   do-    message "direction?"+    messageReset "direction?"     display-    e <- session nextCommand-    handleDirection e (actorOpenClose APlayer True o) (neverMind True)+    e  <- session nextCommand+    pl <- gets splayer+    K.handleDirection e (actorOpenClose pl True o) (neverMind True) -actorOpenClose :: Actor ->+actorOpenClose :: ActorId ->                   Bool ->    -- ^ verbose?                   Bool ->    -- ^ open?                   Dir -> Action () actorOpenClose actor v o dir =   do-    let txt = if o then "open" else "closed"     state <- get-    let lvl@Level { lmonsters = ms, lmap = lmap } = slevel state-    let loc                                       = mloc (getActor state actor)-    let isPlayer  = actor == APlayer+    lmap  <- gets (lmap . slevel)+    pl    <- gets splayer+    body  <- gets (getActor actor)+    let txt = if o then "open" else "closed"+    let hms = levelHeroList state ++ levelMonsterList state+    let loc = aloc body+    let isPlayer  = actor == pl     let isVerbose = v && isPlayer     let dloc = shift loc dir  -- location we act upon+    let openPower = case strongestItem (aitems body) "ring" of+                      Just i  -> biq (akind body) + ipower i+                      Nothing -> biq (akind body)       in case lmap `at` dloc of            Tile d@(Door hv o') []-             | secret o' && isPlayer-> -- door is secret, cannot be opened or closed by hero+             | secret o' && isPlayer -> -- door is secret, cannot be opened or closed by the player                                        neverMind isVerbose-             | toOpen (not o) /= o' -> -- door is in unsuitable state+             | maybe o ((|| not o) . (>= openPower)) o' ->+                                       -- door is in unsuitable state                                        abortIfWith isVerbose ("already " ++ txt)-             | not (unoccupied ms lmap dloc) ->-                                       -- door is blocked by a monster+             | not (unoccupied hms dloc) ->+                                       -- door is blocked by an actor                                        abortIfWith isVerbose "blocked"              | otherwise            -> -- door can be opened / closed                                        -- TODO: print message if action performed by monster and perceived-                                       let nt    = Tile (Door hv (toOpen o)) []-                                           clmap = M.adjust (\ (_, mt) -> (nt, mt)) dloc lmap-                                       in  modify (updateLevel (const (updateLMap (const clmap) lvl)))+                                       let nt  = Tile (Door hv (toOpen o)) []+                                           adj = M.adjust (\ (_, mt) -> (nt, mt)) dloc+                                       in  modify (updateLevel (updateLMap adj))            Tile d@(Door hv o') _    -> -- door is jammed by items                                        abortIfWith isVerbose "jammed"            _                        -> -- there is no door here                                        neverMind isVerbose+    advanceTime actor --- | Perform a level change -- will quit the game if the player leaves--- the dungeon.-lvlchange :: VDir -> Action ()-lvlchange vdir =+ -- | Attempt a level switch to k levels deeper.+-- TODO: perhaps set up some level name arithmetics in Level.hs+-- and hide there the fact levels are now essentially Ints.+lvlDescend :: Int -> Action ()+lvlDescend k =   do     state <- get-    let lvl   @(Level   { lmap = lmap }) = slevel  state-    let player@(Monster { mloc = ploc }) = splayer state-    case lmap `at` ploc of+    let n = levelNumber (lname (slevel state))+        nln = n + k+    when (nln < 1 || nln > sizeDungeon (sdungeon state) + 1) $+      abortWith "no more levels in this direction"+    assertTrue $ liftM (k == 0 ||)  (lvlSwitch (LambdaCave nln))++-- | Attempt a level change via up level and down level keys.+-- Will quit the game if the player leaves the dungeon.+lvlChange :: VDir -> Action ()+lvlChange vdir =+  do+    cursor    <- gets scursor+    targeting <- gets (ctargeting . scursor)+    pbody     <- gets getPlayerBody+    pl        <- gets splayer+    map       <- gets (lmap . slevel)+    let loc = if targeting then clocation cursor else aloc pbody+    case map `at` loc of       Tile (Stairs _ vdir' next) is         | vdir == vdir' -> -- stairs are in the right direction           case next of             Nothing ->               -- we are at the "end" of the dungeon-              fleeDungeon-            Just (nln, nloc) ->-              -- perform level change-              do-                -- put back current level-                -- (first put back, then get, in case we change to the same level!)-                let full = putDungeonLevel lvl (sdungeon state)-                -- get new level-                let (new, ndng) = getDungeonLevel nln full-                modify (\ s -> s { sdungeon = ndng, slevel = new })-                modify (updatePlayer (\ p -> p { mloc = nloc }))+              if targeting+              then abortWith "cannot escape dungeon in targeting mode"+              else do+                b <- messageYesNo "Really escape the dungeon?"+                if b+                  then fleeDungeon+                  else abortWith "Game resumed."+            Just (nln, nloc) -> do+              if targeting+                then do+                  -- this assertion says no stairs go back to the same level+                  assertTrue $ lvlSwitch nln+                  -- do not freely reveal the other end of the stairs+                  map <- gets (lmap . slevel)  -- lvlSwitch modifies map+                  let upd cursor =+                        let cloc = if Level.isUnknown (rememberAt map nloc)+                                   then loc+                                   else nloc+                        in  cursor { clocation = cloc, clocLn = nln }+                  modify (updateCursor upd)+                  doLook+                else tryWith (abortWith "somebody blocks the staircase") $ do+                  -- Remove the player from the old level.+                  modify (deleteActor pl)+                  -- At this place the invariant that the player exists fails.+                  -- Change to the new level (invariant not needed).+                  assertTrue $ lvlSwitch nln+                  -- Add the player to the new level.+                  modify (insertActor pl pbody)+                  -- At this place the invariant is restored again.+                  -- Land the player at the other end of the stairs.+                  updatePlayerBody (\ p -> p { aloc = nloc })+                  -- Change the level of the player recorded in cursor.+                  modify (updateCursor (\ c -> c { creturnLn = nln }))+                  -- Bail out if anybody blocks the staircase.+                  inhabitants <- gets (locToActors nloc)+                  when (length inhabitants > 1) abort+                  -- The invariant "at most one actor on a tile" restored.+                  -- Create a backup of the savegame.+                  state <- get+                  liftIO $ Save.saveGame state >> Save.mvBkp (sconfig state)+                  playerAdvanceTime       _ -> -- no stairs-        do+        if targeting+        then do+          lvlDescend (if vdir == Up then -1 else 1)+          ln <- gets (lname . slevel)+          let upd cursor = cursor { clocLn = ln }+          modify (updateCursor upd)+          doLook+        else           let txt = if vdir == Up then "up" else "down"-          abortWith ("no stairs " ++ txt)+          in  abortWith ("no stairs " ++ txt)  -- | Hero has left the dungeon. fleeDungeon :: Action () fleeDungeon =   do-    player@(Monster { mitems = items }) <- gets splayer-    let total = calculateTotal player+    state <- get+    let total = calculateTotal state+        items = L.concatMap aitems (levelHeroList state)     if total == 0       then do-             messageMoreConfirm "Coward!"-             messageMoreConfirm "Next time try to grab some loot before you flee!"+             go <- messageClear >> messageMoreConfirm ColorFull "Coward!"+             when go $+               messageMore "Next time try to grab some loot before escape!"              end       else do              let winMsg = "Congratulations, you won! Your loot, worth " ++                           show total ++ " gold, is:"              displayItems winMsg True items              go <- session getConfirm-             when go $ handleScores True False True total+             when go $ do+               go <- handleScores True H.Victor total+               when go $ messageMore "Can it be done better, though?"              end --- | Calculate loot's worth. TODO: move to another module, and refine significantly.-calculateTotal :: Player -> Int-calculateTotal player = L.sum $ L.map price $ mitems player-  where-    price i = if iletter i == Just '$' then icount i else 10 * icount i---- | Handle current score and display it with the high scores. TODO: simplify. Scores--- should not be shown during the game, because ultimately the worth of items might give--- information about the nature of the items.-handleScores :: Bool -> Bool -> Bool -> Int -> Action ()-handleScores write killed victor total =-  unless (total == 0) $ do-    nm   <- gets (lname . slevel)-    cfg  <- gets config-    time <- gets stime-    let points  = if killed then (total + 1) `div` 2 else total-    let current = levelNumber nm   -- TODO: rather use name of level-    curDate <- liftIO getClockTime-    let score   = H.ScoreRecord-                    points (-time) curDate current killed victor-    (placeMsg, slideshow) <- liftIO $ H.register cfg write score-    messageOverlaysConfirm placeMsg slideshow-    return ()+-- | Switches current hero to the next hero on the level, if any, wrapping.+cycleHero :: Action ()+cycleHero =+  do+    pl <- gets splayer+    hs <- gets (lheroes . slevel)+    let i        = case pl of AHero n -> n ; _ -> -1+        (lt, gt) = IM.split i hs+    case IM.keys gt ++ IM.keys lt of+      [] -> abortWith "Cannot select another hero on this level."+      ni : _ -> assertTrue $ selectPlayer (AHero ni)  -- | Search for secret doors search :: Action () search =   do-    Level   { lmap = lmap } <- gets slevel-    Monster { mloc = ploc } <- gets splayer-    let searchTile (Tile (Door hv (Just n)) x,t') = Just (Tile (Door hv (Just (max (n - 1) 0))) x, t')-        searchTile t                              = Just t-        slmap = foldl (\ l m -> update searchTile (shift ploc m) l) lmap moves+    lmap   <- gets (lmap . slevel)+    ploc   <- gets (aloc . getPlayerBody)+    pitems <- gets (aitems . getPlayerBody)+    let delta = case strongestItem pitems "ring" of+                  Just i  -> 1 + ipower i+                  Nothing -> 1+        searchTile (Tile (Door hv (Just n)) x, t') =+          (Tile (Door hv (Just (max (n - delta) 0))) x, t')+        searchTile t = t+        f l m = M.adjust searchTile (shift ploc m) l+        slmap = L.foldl' f lmap moves     modify (updateLevel (updateLMap (const slmap)))+    playerAdvanceTime --- | Look around at current location-lookAround :: Action a-lookAround =+-- | Start the floor targeting mode or reset the cursor location to the player.+targetFloor :: Action ()+targetFloor = do+  ploc      <- gets (aloc . getPlayerBody)+  target    <- gets (atarget . getPlayerBody)+  targeting <- gets (ctargeting . scursor)+  let tgt = case target of+              _ | targeting -> TLoc ploc  -- double key press: reset cursor+              TEnemy _ _ -> TCursor  -- forget enemy target, keep the cursor+              t -> t  -- keep the target from previous targeting session+  updatePlayerBody (\ p -> p { atarget = tgt })+  setCursor tgt++-- | Start the monster targeting mode. Cycle between monster targets.+-- TODO: also target a monster by moving the cursor, if in target monster mode.+-- TODO: sort monsters by distance to the player.+targetMonster :: Action ()+targetMonster = do+  pl        <- gets splayer+  ms        <- gets (lmonsters . slevel)+  per       <- currentPerception+  target    <- gets (atarget . getPlayerBody)+  targeting <- gets (ctargeting . scursor)+  let i = case target of+            TEnemy (AMonster n) _ | targeting -> n  -- try next monster+            TEnemy (AMonster n) _ -> n - 1  -- try to retarget old monster+            _ -> -1  -- try to target first monster (e.g., number 0)+      dms = case pl of+              AMonster n -> IM.delete n ms  -- don't target yourself+              AHero _ -> ms+      (lt, gt) = IM.split i dms+      gtlt     = IM.assocs gt ++ IM.assocs lt+      lf = L.filter (\ (_, m) -> actorSeesLoc pl (aloc m) per (Just pl)) gtlt+      tgt = case lf of+              [] -> target  -- no monsters in sight, stick to last target+              (na, nm) : _ -> TEnemy (AMonster na) (aloc nm)  -- pick the next+  updatePlayerBody (\ p -> p { atarget = tgt })+  setCursor tgt++-- | Set, activate and display cursor information.+setCursor :: Target -> Action ()+setCursor tgt = do+  state <- get+  per   <- currentPerception+  ploc  <- gets (aloc . getPlayerBody)+  ln    <- gets (lname . slevel)+  let upd cursor =+        let cloc = case targetToLoc (ptvisible per) state of+                     Nothing -> ploc+                     Just l  -> l+        in  cursor { ctargeting = True, clocation = cloc, clocLn = ln }+  modify (updateCursor upd)+  doLook++-- | Perform look around in the current location of the cursor.+-- TODO: depending on tgt, show extra info about tile or monster or both+doLook :: Action ()+doLook =   do-    state <- get-    let lvl@(Level   { lmap = lmap }) = slevel  state-    let      Monster { mloc = ploc }  = splayer state-    -- general info about current loc-    let lookMsg = lookAt True state lmap ploc-    -- check if there's something lying around at current loc-    let t = lmap `at` ploc+    loc    <- gets (clocation . scursor)+    state  <- get+    lmap   <- gets (lmap . slevel)+    per    <- currentPerception+    target <- gets (atarget . getPlayerBody)+    let canSee = S.member loc (ptvisible per)+        monsterMsg =+          if canSee+          then case L.find (\ m -> aloc m == loc) (levelMonsterList state) of+                 Just m  -> subjectActor (akind m) ++ " is here. "+                 Nothing -> ""+          else ""+        mode = case target of+                 TEnemy _ _ -> "[targeting monster] "+                 TLoc _   -> "[targeting location] "+                 TCursor  -> "[targeting current] "+        -- general info about current loc+        lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg+        -- check if there's something lying around at current loc+        t = lmap `at` loc     if length (titems t) <= 2       then do-             abortWith lookMsg+             messageAdd lookMsg       else do              displayItems lookMsg False (titems t)              session getConfirm-             abortWith ""---- | Display inventory-inventory :: Action a-inventory =-  do-    player <- gets splayer-    if L.null (mitems player)-      then abortWith "You are not carrying anything"-      else do-             displayItems "This is what you are carrying:" True (mitems player)-             session getConfirm-             abortWith ""---- | Given item is now known to the player.-discover :: Item -> Action ()-discover i = modify (updateDiscoveries (S.insert (itype i)))--drinkPotion :: Action ()-drinkPotion =-  do-    state <- get-    let lvl   @(Level   { lmap = lmap }) = slevel  state-    let player@(Monster { mloc = ploc }) = splayer state-    if L.null (mitems player)-      then abortWith "You are not carrying anything."-      else do-             i <- getPotion "What to drink?" (mitems player) "inventory"-             case i of-               Just i'@(Item { itype = Potion ptype }) ->-                 do-                   -- only one potion is consumed even if several are joined in the inventory-                   let consumed = i' { icount = 1 }-                   removeFromInventory consumed-                   message (subjectVerbIObject state player "drink" consumed "")-                   -- the potion is identified after drinking-                   discover i'-                   case ptype of-                     PotionWater   -> messageAdd "Tastes like water."-                     PotionHealing -> do-                                        messageAdd "You feel better."-                                        modify (updatePlayer (\ p -> p { mhp = min (mhpmax p) (mhp p + playerHP `div` 4) }))-               Just _  -> abortWith "you cannot drink that"-               Nothing -> neverMind True--dropItem :: Action ()-dropItem =-  do-    state <- get-    let player@(Monster { mloc = ploc }) = splayer state-    if L.null (mitems player)-      then abortWith "You are not carrying anything."-      else do-             i <- getAnyItem "What to drop?" (mitems player) "inventory"-             case i of-               Just i' ->-                 do-                   removeFromInventory i'-                   message (subjectVerbIObject state player "drop" i' "")-                   dropItemsAt [i'] ploc-               Nothing -> neverMind True--dropItemsAt :: [Item] -> Loc -> Action ()-dropItemsAt is loc = modify (updateLevel (scatterItems is loc))---- | Remove given item from the hero's inventory.-removeFromInventory :: Item -> Action ()-removeFromInventory i =-  modify (updatePlayer (\ p -> p { mitems = removeItemByLetter i (mitems p) }))---- | Remove given item from the given location.-removeFromLoc :: Item -> Loc -> Action ()-removeFromLoc i loc =-  modify (updateLevel (\ l -> l { lmap = M.adjust (\ (t, rt) -> (update t, rt)) loc (lmap l) }))-  where-    update t = t { titems = removeItemByType i (titems t) }---- | Let the player choose any potion. Note that this does not guarantee a potion to be chosen,--- as the player can override the choice.-getPotion :: String ->  -- prompt-             [Item] ->  -- all objects in question-             String ->  -- how to refer to the collection of objects, e.g. "in your inventory"-             Action (Maybe Item)-getPotion prompt is isn = getItem prompt (\ i -> case itype i of Potion {} -> True; _ -> False)-                                  "Potions" is isn--actorPickupItem :: Actor -> Action ()-actorPickupItem actor =-  do-    state <- get-    per   <- currentPerception-    let lvl@(Level { lmap = lmap }) = slevel state-    let monster   = getActor state actor-    let loc       = mloc monster-    let t         = lmap `at` loc -- the map tile in question-    let perceived = loc `S.member` pvisible per-    let isPlayer  = actor == APlayer-    -- check if something is here to pick up-    case titems t of-      []     -> abortIfWith isPlayer "nothing here"-      (i:rs) -> -- pick up first item; TODO: let player select item; not for monsters-        case assignLetter (iletter i) (mletter monster) (mitems monster) of-          Just l ->-            do-              let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems monster)-              -- message is dependent on who picks up and if the hero can perceive it-              if isPlayer-                then message (letterLabel (iletter ni) ++ objectItem state (icount ni) (itype ni))-                else when perceived $-                       message $ subjectCompoundVerbIObject state monster "pick" "up" i ""-              removeFromLoc i loc-              -- add item to actor's inventory:-              updateActor actor $ \ m ->-                m { mitems = nitems, mletter = maxLetter l (mletter monster) }-          Nothing -> abortIfWith isPlayer "you cannot carry any more"---- | Replaces the version in Actor module-updateActor :: Actor ->                 -- ^ who to update-               (Monster -> Monster) ->  -- ^ the update-               Action ()-updateActor (AMonster n) f =-  do-    monsters <- gets (lmonsters . slevel)-    let (m, ms) = updateMonster f n monsters-    modify (updateLevel (updateMonsters (const ms)))-updateActor APlayer f =-  modify (updatePlayer f)--pickupItem :: Action ()-pickupItem = actorPickupItem APlayer---- TODO: I think that player handlers should be wrappers around more general actor handlers, but--- the actor handlers should be performing specific actions, i.e., already specify the item to be--- picked up. It doesn't make sense to invoke dialogues for arbitrary actors, and most likely the--- decision for a monster is based on perceiving a particular item to be present, so it's already--- known. In actor handlers we should make sure that messages are printed to the player only if the--- hero can perceive the action.---- | Let the player choose any item from a list of items.-getAnyItem :: String ->  -- prompt-              [Item] ->  -- all objects in question-              String ->  -- how to refer to the collection of objects, e.g. "in your inventory"-              Action (Maybe Item)-getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn---- | Let the player choose a single item from a list of items.-getItem :: String ->              -- prompt message-           (Item -> Bool) ->      -- which items to consider suitable-           String ->              -- how to describe suitable objects-           [Item] ->              -- all objects in question-           String ->              -- how to refer to the collection of objects, e.g. "in your inventory"-           Action (Maybe Item)-getItem prompt p ptext is0 isn =-  let is = L.filter p is0-      choice | L.null is = "[*]"-             | otherwise = "[" ++ letterRange (concatMap (maybeToList . iletter) is) ++ " or ?*]"-      r = do-            message (prompt ++ " " ++ choice)-            display-            let h = session nextCommand >>= h'-                h' e = case e of-                         K.Char '?' -> do-                                         -- filter for supposedly suitable objects-                                         b <- displayItems (ptext ++ " " ++ isn) True is-                                         if b then session (getOptionalConfirm (const r) h')-                                              else r-                         K.Char '*' -> do-                                         -- show all objects-                                         b <- displayItems ("Objects " ++ isn) True is0-                                         if b then session (getOptionalConfirm (const r) h')-                                              else r-                         K.Char l   -> return (find (\ i -> maybe False (== l) (iletter i)) is0)-                         _          -> return Nothing-            h-  in r--displayItems :: Message -> Bool -> [Item] -> Action Bool-displayItems msg sorted is =-    do-      state <- get-      let inv = unlines $-                L.map (\ (Item { icount = c, iletter = l, itype = t }) ->-                         letterLabel l ++ objectItem state c t ++ " ")-                      ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)-      let ovl = inv ++ more-      message msg-      overlay ovl+             messageAdd "" --- | This function performs a move (or attack) by any actor, i.e., it can handle--- both monsters and the player.+-- | This function performs a move (or attack) by any actor,+-- i.e., it can handle monsters, heroes and both. moveOrAttack :: Bool ->        -- allow attacks?                 Bool ->        -- auto-open doors on move-                Actor ->       -- who's moving?+                ActorId ->     -- who's moving?                 Dir ->                 Action () moveOrAttack allowAttacks autoOpen actor dir   | dir == (0,0) =-      -- Moving with no direction is a noop. We include it currently to prevent that+      -- Moving with no direction is a noop.+      -- We include it currently to prevent that       -- monsters attack themselves by accident.-      return ()-  | otherwise =-    do+      advanceTime actor+  | otherwise = do       -- We start by looking at the target position.       state <- get-      let lvl@(Level { lmap = lmap }) = slevel  state-      let player                      = splayer state-      let monster = getActor state actor-      let loc     = mloc monster     -- current location-      let s       = lmap `at` loc    -- tile at current location-      let nloc    = loc `shift` dir  -- target location-      let t       = lmap `at` nloc   -- tile at target location-      let attackedPlayer   = [ APlayer | mloc player == nloc ]-      let attackedMonsters = L.map AMonster $-                             findIndices (\ m -> mloc m == nloc) (lmonsters lvl)-      let attacked :: [Actor]-          attacked = attackedPlayer ++ attackedMonsters-      -- At the moment, we check whether there is a monster before checking accessibility-      -- i.e., we can attack a monster on a blocked location. For instance,-      -- a monster on an open door can be attacked diagonally, and a-      -- monster capable of moving through walls can be attacked from an-      -- adjacent position.-      if not (L.null attacked)-        then if not allowAttacks then abort else do-          -- perform the attack-          mapM_ (actorAttackActor actor) attacked-        else if accessible lmap loc nloc then do-          -- perform the move-          updateActor actor (\ m -> m { mloc = nloc })-          when (actor == APlayer) $ message $ lookAt False state lmap nloc-            -- TODO: seems somewhat dubious to do this here, but perhaps it's ok-        else if autoOpen then-          -- try to check if there's a door we can open-          actorOpenClose actor False True dir-        else abort -- nothing useful we can do+      pl    <- gets splayer+      lmap  <- gets (lmap . slevel)+      sm    <- gets (getActor actor)+      let sloc = aloc sm           -- source location+          tloc = sloc `shift` dir  -- target location+      tgt <- gets (locToActor tloc)+      case tgt of+        Just target ->+          if allowAttacks then+            -- Attacking does not require full access, adjacency is enough.+            actorAttackActor actor target+          else if accessible lmap sloc tloc then do+            -- Switching positions requires full access.+            actorRunActor actor target+            when (actor == pl) $+              messageAdd $ lookAt False True state lmap tloc ""+          else abortWith ""+        Nothing ->+          if accessible lmap sloc tloc then do+            -- perform the move+            updateAnyActor actor $ \ body -> body { aloc = tloc }+            when (actor == pl) $+              messageAdd $ lookAt False True state lmap tloc ""+            advanceTime actor+          else if allowAttacks && actor == pl+                  && canBeDoor (lmap `rememberAt` tloc) then do+            messageAdd "You search your surroundings."  -- TODO: proper msg+            search+          else if autoOpen then+            -- try to open a door+            actorOpenClose actor False True dir+          else abortWith "" -actorAttackActor :: Actor -> Actor -> Action ()-actorAttackActor source target =-  do-    debug "actorAttackActor"-    state <- get-    let sm = getActor state source-    let tm = getActor state target-    -- determine the weapon used for the attack-    let sword = strongestSword (mitems sm)-    -- damage the target-    let newHp  = mhp tm - 3 - sword-    let killed = newHp <= 0-    updateActor target $ \ m ->-      if killed-        then m { mhp = 0, mtime = 0 } -- grant an immediate move to die-        -- TODO: is there a good reason not to let the monster die just here?-        else m { mhp = newHp }-    -- determine how the hero perceives the event; TODO: we have to be more-    -- precise and treat cases where two monsters fight, but only one is visible-    let combatVerb = if killed && target /= APlayer then "kill" else "hit"-    let swordMsg   = if sword == 0 then "" else-                       " with a (+" ++ show sword ++ ") sword" -- TODO: generate proper message-    let combatMsg  = subjectVerbMObject state sm combatVerb tm swordMsg-    per <- currentPerception-    let perceived  = mloc sm `S.member` pvisible per-    messageAdd $-      if perceived-        then combatMsg-        else "You hear some noises."+-- | Resolves the result of an actor moving into another. Usually this+-- involves melee attack, but with two heroes it just changes focus.+-- Actors on blocked locations can be attacked without any restrictions.+-- For instance, an actor on an open door can be attacked diagonally,+-- and an actor capable of moving through walls can be attacked from an+-- adjacent position.+-- This function is analogous to zapGroupItem, but for melee+-- and not using up the weapon.+actorAttackActor :: ActorId -> ActorId -> Action ()+actorAttackActor (AHero _) target@(AHero _) =+  -- Select adjacent hero by bumping into him. Takes no time.+  assertTrue $ selectPlayer target+actorAttackActor source target = do+  state <- get+  sm    <- gets (getActor source)+  tm    <- gets (getActor target)+  per   <- currentPerception+  let groupName = "sword"+      verb = attackToVerb groupName+      sloc = aloc sm+      -- The hand-to-hand "weapon", equivalent to +0 sword.+      h2h = Item ItemKind.swordKindId 0 Nothing 1+      str = strongestItem (aitems sm) groupName+      stack  = fromMaybe h2h str+      single = stack { icount = 1 }+      -- The message describes the source part of the action.+      -- TODO: right now it also describes the victim and weapon;+      -- perhaps, when a weapon is equipped, just say "you hit" or "you miss"+      -- and then "nose dies" or "nose yells in pain".+      msg = subjectVerbMObject sm verb tm $+              if isJust str then " with " ++ objectItem state single else ""+  when (sloc `S.member` ptvisible per) $ messageAdd msg+  -- Messages inside itemEffectAction describe the target part.+  itemEffectAction 0 source target single+  advanceTime source +attackToVerb :: String -> String+attackToVerb "sword" = "hit"  -- TODO: "slash"? "pierce"? "swing"?+attackToVerb "mace" = "bludgeon"+attackToVerb _ = "hit"++-- | Resolves the result of an actor running into another.+-- This involves switching positions of the two actors.+actorRunActor :: ActorId -> ActorId -> Action ()+actorRunActor source target = do+  pl    <- gets splayer+  sloc  <- gets (aloc . getActor source)  -- source location+  tloc  <- gets (aloc . getActor target)  -- target location+  updateAnyActor source $ \ m -> m { aloc = tloc }+  updateAnyActor target $ \ m -> m { aloc = sloc }+  if source == pl+    then stopRunning  -- do not switch positions repeatedly+    else if isAMonster source+         then focusIfAHero target+         else return ()+  advanceTime source+ -- | Generate a monster, possibly. generateMonster :: Action () generateMonster =-  do-    lvl    <- gets slevel-    player <- gets splayer-    nlvl   <- liftIO $ rndToIO $ addMonster lvl player-    modify (updateLevel (const nlvl))---- | Advance the move time for the given actor.-advanceTime :: Actor -> Action ()-advanceTime actor =-  do-    time <- gets stime-    updateActor actor (\ m -> m { mtime = time + mspeed m })+  do  -- TODO: simplify+    state  <- get+    nstate <- liftIO $ rndToIO $ rollMonster state+    modify (const nstate) --- | Possibly regenerate HP for the given actor.-regenerate :: Actor -> Action ()-regenerate actor =+-- | Possibly regenerate HP for all actors on the current level.+regenerateLevelHP :: Action ()+regenerateLevelHP =   do-    time <- gets stime-    -- TODO: remove hardcoded time interval, regeneration should be an attribute of the monster-    when (time `mod` 1500 == 0) $-      updateActor actor (\ m -> m { mhp = min (mhpmax m) (mhp m + 1) })-+    time  <- gets stime+    let upd m =+          let regen = bregen (akind m) `div`+                      case strongestItem (aitems m) "amulet" of+                        Just i  -> ipower i+                        Nothing -> 1+          in if time `mod` regen /= 0+             then m+             else m { ahp = min (bhpMax (akind m)) (ahp m + 1) }+    -- We really want hero selection to be a purely UI distinction,+    -- so all heroes need to regenerate, not just the player.+    -- Only the heroes on the current level regenerate (others are frozen+    -- in time together with their level). This prevents cheating+    -- via sending one hero to a safe level and waiting there.+    modify (updateLevel (updateHeroes   (IM.map upd)))+    modify (updateLevel (updateMonsters (IM.map upd)))
src/Actor.hs view
@@ -1,35 +1,83 @@ module Actor where -import Level-import Monster-import State+import Data.Binary+import Control.Monad -data Actor = AMonster Int  -- offset in monster list-           | APlayer-  deriving (Show, Eq)+import Geometry+import Item+import ActorKind -getActor :: State -> Actor -> Monster-getActor (State { slevel = lvl, splayer = p }) a =-  case a of-    AMonster n -> lmonsters lvl !! n-    APlayer    -> p+-- | Monster properties that are changing a lot. If they are dublets+-- of properties form ActorKind, the intention is they may be modified+-- temporarily, but will return to the original value over time. E.g., HP.+data Actor = Actor+  { akind   :: !ActorKind, -- ^ kind of the actor; TODO: make this an index+    ahp     :: !Int,       -- ^ current hit pints+    adir    :: Maybe Dir,  -- ^ the direction of running+    atarget :: Target,     -- ^ the target for distance attacks and AI+    aloc    :: !Loc,       -- ^ current location+    aitems  :: [Item],     -- ^ inventory+    aletter :: !Char,      -- ^ next inventory letter+    atime   :: !Time }     -- ^ time of next action+  deriving Show -updateActor :: (Monster -> Monster) ->        -- the update-               (Monster -> State -> IO a) ->  -- continuation-               Actor ->                       -- who to update-               State -> IO a                  -- transformed continuation-updateActor f k (AMonster n) state@(State { slevel = lvl, splayer = p }) =-  let (m,ms) = updateMonster f n (lmonsters lvl)-  in  k m (updateLevel (updateMonsters (const ms)) state)-updateActor f k APlayer      state@(State { slevel = lvl, splayer = p }) =-  k p (updatePlayer f state)+instance Binary Actor where+  put (Actor akind ahp adir atarget aloc aitems aletter atime) =+    do+      put akind+      put ahp+      put adir+      put atarget+      put aloc+      put aitems+      put aletter+      put atime+  get = do+          akind   <- get+          ahp     <- get+          adir    <- get+          atarget <- get+          aloc    <- get+          aitems  <- get+          aletter <- get+          atime   <- get+          return (Actor akind ahp adir atarget aloc aitems aletter atime) -updateMonster :: (Monster -> Monster) -> Int -> [Monster] ->-                 (Monster, [Monster])-updateMonster f n ms =-  case splitAt n ms of-    (pre, x : post) -> let m = f x-                           mtimeChanged = mtime x /= mtime m-                       in (m, if mtimeChanged then snd (insertMonster m (pre ++ post))-                                              else pre ++ [m] ++ post)-    xs              -> error "updateMonster"+data ActorId = AHero Int     -- ^ hero index (on the lheroes intmap)+             | AMonster Int  -- ^ monster index (on the lmonsters intmap)+  deriving (Show, Eq, Ord)++isAHero :: ActorId -> Bool+isAHero (AHero _) = True+isAHero (AMonster _) = False++isAMonster :: ActorId -> Bool+isAMonster = not . isAHero++instance Binary ActorId where+  put (AHero n)    = putWord8 0 >> put n+  put (AMonster n) = putWord8 1 >> put n+  get = do+          tag <- getWord8+          case tag of+            0 -> liftM AHero get+            1 -> liftM AMonster get+            _ -> fail "no parse (ActorId)"++data Target =+    TEnemy ActorId Loc  -- ^ fire at the actor; last seen location+  | TLoc Loc            -- ^ fire at a given location+  | TCursor             -- ^ fire at the current position of the cursor; default+  deriving (Show, Eq)++instance Binary Target where+  put (TEnemy a ll) = putWord8 0 >> put a >> put ll+  put (TLoc loc) = putWord8 1 >> put loc+  put TCursor    = putWord8 2+  get = do+          tag <- getWord8+          case tag of+            0 -> liftM2 TEnemy get get+            1 -> liftM TLoc get+            2 -> return TCursor+            _ -> fail "no parse (Target)"
+ src/ActorAdd.hs view
@@ -0,0 +1,108 @@+module ActorAdd where++import Prelude hiding (floor)+import qualified Data.IntMap as IM+import Data.List as L+import Data.Map as M+import Data.Ratio+import Data.Maybe+import qualified Data.Char as Char++import Geometry+import State+import Level+import Dungeon+import Actor+import ActorState+import ActorKind+import Random+import qualified Config++-- Generic functions++-- 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+template :: ActorKind -> Int -> Loc -> Actor+template mk hp loc = Actor mk hp Nothing TCursor loc [] 'a' 0++nearbyFreeLoc :: Loc -> State -> Loc+nearbyFreeLoc origin state@(State { slevel = Level { lmap = map } }) =+  let hs = levelHeroList state+      ms = levelMonsterList state+      places = origin : L.nub (concatMap surroundings places)+      good loc = open (map `at` loc) && not (loc `L.elem` L.map aloc (hs ++ ms))+  in  fromMaybe (error "no nearby free location found") $ L.find good places++-- Adding heroes++findHeroName :: Config.CP -> Int -> String+findHeroName config n =+  let heroName = Config.getOption config "heroes" ("HeroName_" ++ show n)+  in  fromMaybe ("hero number " ++ show n) heroName++-- | Create a new hero on the current level, close to the given location.+addHero :: Loc -> State -> State+addHero ploc state =+  let config = sconfig state+      bHP = Config.get config "heroes" "baseHP"+      mk = hero {bhpMin = bHP, bhpMax = bHP, bsymbol = symbol, bname = name }+      loc = nearbyFreeLoc ploc state+      n = fst (scounter state)+      symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n+      name = findHeroName config n+      startHP = bHP `div` (min 10 (n + 1))+      m = template mk startHP loc+      state' = state { scounter = (n + 1, snd (scounter state)) }+  in  updateLevel (updateHeroes (IM.insert n m)) state'++-- | Create a set of initial heroes on the current level, at location ploc.+initialHeroes :: Loc -> State -> State+initialHeroes ploc state =+  let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes"+  in  iterate (addHero ploc) state !! k++-- Adding monsters++-- | Chance that a new monster is generated. Currently depends on the+-- number of monsters already present, and on the level. In the future,+-- the strength of the character and the strength of the monsters present+-- could further influence the chance, and the chance could also affect+-- which monster is generated.+monsterGenChance :: LevelName -> Int -> Rnd Bool+monsterGenChance (LambdaCave depth) numMonsters =+  chance $ 1%(fromIntegral (250 + 200 * (numMonsters - depth)) `max` 50)+monsterGenChance _ _ = return False++-- | Create a new monster in the level, at a random position.+addMonster :: ActorKind -> Int -> Loc -> State -> State+addMonster mk hp ploc state = do+  let loc = nearbyFreeLoc ploc state+      n = snd (scounter state)+      m = template mk hp loc+      state' = state { scounter = (fst (scounter state), n + 1) }+  updateLevel (updateMonsters (IM.insert n m)) state'++-- | Create a new monster in the level, at a random position.+rollMonster :: State -> Rnd State+rollMonster state@(State { slevel = lvl }) = do+  let hs = levelHeroList state+      ms = levelMonsterList state+  rc <- monsterGenChance (lname lvl) (L.length ms)+  if not rc+    then return state+    else do+      -- TODO: new monsters should always be generated in a place that isn't+      -- visible by the player (if possible -- not possible for bigrooms)+      -- levels with few rooms are dangerous, because monsters may spawn+      -- in adjacent and unexpected places+      loc <- findLocTry 1000 lvl+             (\ l t -> open t+                       && not (l `L.elem` L.map aloc (hs ++ ms)))+             (\ l t -> floor t+                       && L.all (\ pl -> distance (aloc pl, l) > 400) hs)+      let fmk = Frequency $ L.zip (L.map bfreq dungeonMonsters) dungeonMonsters+      mk <- frequency fmk+      hp <- randomR (bhpMin mk, bhpMax mk)+      return $ addMonster mk hp loc state
+ src/ActorKind.hs view
@@ -0,0 +1,111 @@+module ActorKind where++import Data.Binary+import Control.Monad++import Geometry+import Random+import qualified Color++-- | Monster properties that are changing rarely and permanently.+data ActorKind = ActorKind+  { bhpMin  :: !Int,          -- ^ minimal initial hp+    bhpMax  :: !Int,          -- ^ maximal possible and initial hp+    bspeed  :: !Time,         -- ^ natural speed+    bsymbol :: !Char,         -- ^ map symbol+    bcolor  :: !Color.Color,  -- ^ map color+    bname   :: String,        -- ^ name+    bsight  :: !Bool,         -- ^ can it see?+    bsmell  :: !Bool,         -- ^ can it smell?+    biq     :: !Int,          -- ^ intelligence+    bregen  :: !Int,          -- ^ regeneration interval+    bfreq   :: !Int           -- ^ dungeon frequency+  }+  deriving (Show, Eq)++instance Binary ActorKind where+  put (ActorKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq) =+    do+      put nhpMin+      put nhpMax+      put nsp+      put nsym+      put ncol+      put nnm+      put nsi+      put nsm+      put niq+      put nreg+      put nfreq+  get = do+    nhpMin <- get+    nhpMax <- get+    nsp    <- get+    nsym   <- get+    ncol   <- get+    nnm    <- get+    nsi    <- get+    nsm    <- get+    niq    <- get+    nreg   <- get+    nfreq  <- get+    return (ActorKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq)++-- | The list of kinds of monsters that appear randomly throughout the dungeon.+dungeonMonsters :: [ActorKind]+dungeonMonsters = [eye, fastEye, nose]++hero, eye, fastEye, nose :: ActorKind+hero = ActorKind+  { bhpMin  = 50,+    bhpMax  = 50,+    bspeed  = 10,+    bsymbol = '@',+    bname   = "you",+    bcolor  = Color.BrWhite,  -- Heroes white, monsters colorful.+    bsight  = True,+    bsmell  = False,+    biq     = 13,  -- Can see secret doors under alien control.+    bregen  = 1500,+    bfreq   = 0+  }++eye = ActorKind+  { bhpMin  = 1,  -- falls in 1--4 unarmed rounds+    bhpMax  = 12,+    bspeed  = 10,+    bsymbol = 'e',+    bcolor  = Color.BrRed,+    bname   = "the reducible eye",+    bsight  = True,+    bsmell  = False,+    biq     = 8,+    bregen  = 1500,+    bfreq   = 6+  }+fastEye = ActorKind+  { bhpMin  = 1,  -- falls in 1--2 unarmed rounds+    bhpMax  = 6,+    bspeed  = 4,+    bsymbol = 'e',+    bcolor  = Color.BrBlue,+    bname   = "the super-fast eye",+    bsight  = True,+    bsmell  = False,+    biq     = 12,+    bregen  = 1500,+    bfreq   = 1+  }+nose = ActorKind+  { bhpMin  = 6,  -- 2--5 and in 1 round of the strongest sword+    bhpMax  = 13,+    bspeed  = 11,+    bsymbol = 'n',+    bcolor  = Color.Green,+    bname   = "the point-free nose",+    bsight  = False,+    bsmell  = True,+    biq     = 0,+    bregen  = 1500,+    bfreq   = 2+  }
+ src/ActorState.hs view
@@ -0,0 +1,122 @@+module ActorState where++import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Control.Monad+import Data.Maybe+import Control.Exception (assert)++import Geometry+import Actor+import Level+import Dungeon+import State++-- The operations with "Any", and those that use them, consider all the dungeon.+-- All the other actor and level operations only consider the current level.++-- | Finds an actor body on any level. Error if not found.+findActorAnyLevel :: ActorId -> State -> Maybe (LevelName, Actor)+findActorAnyLevel actor state@(State { slevel   = lvl,+                                       sdungeon = Dungeon m }) =+  let chk lvl =+        fmap (\ m -> (lname lvl, m)) $+        case actor of+          AHero n    -> IM.lookup n (lheroes lvl)+          AMonster n -> IM.lookup n (lmonsters lvl)+  in  listToMaybe $ mapMaybe chk (lvl : M.elems m)++getPlayerBody :: State -> Actor+getPlayerBody state = snd $ fromMaybe (error "getPlayerBody") $+                      findActorAnyLevel (splayer state) state++-- | The list of actors and levels for all heroes in the dungeon.+-- Heroes from the current level go first.+allHeroesAnyLevel :: State -> [(ActorId, LevelName)]+allHeroesAnyLevel state =+  let Dungeon m = sdungeon state+      one (Level { lname = ln, lheroes = hs }) =+        L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs hs)+  in  L.concatMap one (slevel state : M.elems m)++updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State+updateAnyActorBody actor f state =+  case findActorAnyLevel actor state of+    Just (ln, _) ->+      case actor of+        AHero n    -> updateAnyLevel (updateHeroes   $ IM.adjust f n) ln state+        AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state+    Nothing -> error "updateAnyActorBody"++updateAnyLevel :: (Level -> Level) -> LevelName -> State -> State+updateAnyLevel f ln state@(State { slevel = level,+                                   sdungeon = Dungeon dng })+  | ln == lname level = updateLevel f state+  | otherwise = updateDungeon (const $ Dungeon $ M.adjust f ln dng) state++-- | Calculate the location of player's target.+targetToLoc :: S.Set Loc -> State -> Maybe Loc+targetToLoc visible state =+  case atarget (getPlayerBody state) of+    TLoc loc -> Just loc+    TCursor  ->+      if lname (slevel state) == clocLn (scursor state)+      then Just $ clocation (scursor state)+      else Nothing  -- cursor invalid: set at a different level+    TEnemy a _ll -> do+      guard $ memActor a state           -- alive and on the current level?+      let loc = aloc (getActor a state)+      guard $ S.member loc visible       -- visible?+      return loc++-- The operations below disregard levels other than the current.++-- | Checks if the actor is present on the current level.+memActor :: ActorId -> State -> Bool+memActor a (State { slevel = lvl }) =+  case a of+    AHero n    -> IM.member n (lheroes lvl)+    AMonster n -> IM.member n (lmonsters lvl)++-- | Gets actor body from the current level. Error if not found.+getActor :: ActorId -> State -> Actor+getActor a (State { slevel = lvl }) =+  case a of+    AHero n    -> lheroes   lvl IM.! n+    AMonster n -> lmonsters lvl IM.! n++-- | Removes the actor, if present, from the current level.+deleteActor :: ActorId -> State -> State+deleteActor a =+  case a of+    AHero n    -> updateLevel (updateHeroes   (IM.delete n))+    AMonster n -> updateLevel (updateMonsters (IM.delete n))++-- | Add actor to the current level.+insertActor :: ActorId -> Actor -> State -> State+insertActor a m =+  case a of+    AHero n    -> updateLevel (updateHeroes   (IM.insert n m))+    AMonster n -> updateLevel (updateMonsters (IM.insert n m))++levelHeroList, levelMonsterList :: State -> [Actor]+levelHeroList    (State { slevel = Level { lheroes   = hs } }) = IM.elems hs+levelMonsterList (State { slevel = Level { lmonsters = ms } }) = IM.elems ms++-- | Finds an actor at a location on the current level. Perception irrelevant.+locToActor :: Loc -> State -> Maybe ActorId+locToActor loc state =+  let l = locToActors loc state+  in assert (L.length l <= 1) $+       listToMaybe l++locToActors :: Loc -> State -> [ActorId]+locToActors loc state =+  getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero)+    where+      getIndex (projection, injection) =+        let l  = IM.assocs $ projection $ slevel state+            im = L.filter (\ (_i, m) -> aloc m == loc) l+        in  fmap (injection . fst) im
+ src/Color.hs view
@@ -0,0 +1,119 @@+module Color where++import Control.Monad+import qualified Data.Binary as Binary++data Color =+    Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | BrBlack+  | BrRed+  | BrGreen+  | BrYellow+  | BrBlue+  | BrMagenta+  | BrCyan+  | BrWhite+  deriving (Show, Eq, Ord, Enum, Bounded)++instance Binary.Binary Color where+  put = Binary.putWord8 . fromIntegral . fromEnum+  get = liftM (toEnum . fromIntegral) Binary.getWord8++defBG, defFG :: Color+defBG = Black+defFG = White++type Attr = (Color.Color, Color.Color)+defaultAttr :: Attr+defaultAttr = (Color.defFG, Color.defBG)++isBright :: Color -> Bool+isBright c = fromEnum c > 7  -- for terminals that display bright via bold++-- | Due to limitation of curses, only these are legal backgrounds.+legalBG :: [Color]+legalBG = [Black, White, Blue, Magenta]++-- Heavily modified Linux console colors.+colorToRGB :: Color -> String+colorToRGB Black     = "#000000"+colorToRGB Red       = "#D50000"+colorToRGB Green     = "#00AA00"+colorToRGB Yellow    = "#AA5500"  -- brown+colorToRGB Blue      = "#203AF0"+colorToRGB Magenta   = "#AA00AA"+colorToRGB Cyan      = "#00AAAA"+colorToRGB White     = "#C5BCB8"+colorToRGB BrBlack   = "#6F5F5F"+colorToRGB BrRed     = "#FF5555"+colorToRGB BrGreen   = "#75FF45"+colorToRGB BrYellow  = "#FFE855"+colorToRGB BrBlue    = "#4090FF"+colorToRGB BrMagenta = "#FF77FF"+colorToRGB BrCyan    = "#60FFF0"+colorToRGB BrWhite   = "#FFFFFF"++-- For reference, the original Linux console colors.+-- Good old retro feel and more useful than xterm (e.g. brown).+colorToRGB' :: Color -> String+colorToRGB' Black     = "#000000"+colorToRGB' Red       = "#AA0000"+colorToRGB' Green     = "#00AA00"+colorToRGB' Yellow    = "#AA5500"  -- brown+colorToRGB' Blue      = "#0000AA"+colorToRGB' Magenta   = "#AA00AA"+colorToRGB' Cyan      = "#00AAAA"+colorToRGB' White     = "#AAAAAA"+colorToRGB' BrBlack   = "#555555"+colorToRGB' BrRed     = "#FF5555"+colorToRGB' BrGreen   = "#55FF55"+colorToRGB' BrYellow  = "#FFFF55"+colorToRGB' BrBlue    = "#5555FF"+colorToRGB' BrMagenta = "#FF55FF"+colorToRGB' BrCyan    = "#55FFFF"+colorToRGB' BrWhite   = "#FFFFFF"++-- Human-readable names, for item descriptions. The simple set.+colorToName :: Color -> String+colorToName Black     = "black"+colorToName Red       = "red"+colorToName Green     = "green"+colorToName Yellow    = "brown"+colorToName Blue      = "blue"+colorToName Magenta   = "purple"+colorToName Cyan      = "cyan"+colorToName White     = "ivory"+colorToName BrBlack   = "gray"+colorToName BrRed     = "coral"+colorToName BrGreen   = "lime"+colorToName BrYellow  = "yellow"+colorToName BrBlue    = "azure"+colorToName BrMagenta = "pink"+colorToName BrCyan    = "aquamarine"+colorToName BrWhite   = "white"++-- The fancy set.+colorToName' :: Color -> String+colorToName' Black     = "smoky black"+colorToName' Red       = "apple red"+colorToName' Green     = "forest green"+colorToName' Yellow    = "mahogany"+colorToName' Blue      = "royal blue"+colorToName' Magenta   = "indigo"+colorToName' Cyan      = "teal"+colorToName' White     = "silver gray"+colorToName' BrBlack   = "charcoal"+colorToName' BrRed     = "salmon"+colorToName' BrGreen   = "emerald"+colorToName' BrYellow  = "amber"+colorToName' BrBlue    = "sky blue"+colorToName' BrMagenta = "magenta"+colorToName' BrCyan    = "turquoise"+colorToName' BrWhite   = "ghost white"
src/Command.hs view
@@ -2,9 +2,10 @@  import Action import Actions+import ItemAction import Geometry-import qualified Keys as K import Level+import Version  data Described a = Described { chelp :: String, caction :: a }                  | Undescribed { caction :: a }@@ -12,21 +13,29 @@ type Command    = Described (Action ()) type DirCommand = Described (Dir -> Action ()) -closeCommand     = Described "close a door"      (openclose False)-openCommand      = Described "open a door"       (openclose True)-pickupCommand    = Described "pick up an object" pickupItem-dropCommand      = Described "drop an object"    dropItem+closeCommand     = Described "close a door"      (checkCursor (openclose False))+openCommand      = Described "open a door (or bump into a door)"       (checkCursor (openclose True))+pickupCommand    = Described "get an object"     (checkCursor pickupItem)+dropCommand      = Described "drop an object"    (checkCursor dropItem) inventoryCommand = Described "display inventory" inventory-searchCommand    = Described "search for secret doors" search-ascendCommand    = Described "ascend a level"    (lvlchange Up)-descendCommand   = Described "descend a level"   (lvlchange Down)-lookCommand      = Described "look around"       lookAround-drinkCommand     = Described "quaff a potion"    drinkPotion-waitCommand      = Described "wait"              (return () :: Action ())-saveCommand      = Described "save and quit the game" saveGame+searchCommand    = Described "search for secret doors (or bump)" (checkCursor search)+ascendCommand    = Described "ascend a level"    (lvlChange Up)+descendCommand   = Described "descend a level"   (lvlChange Down)+floorCommand     = Described "target location"   targetFloor+monsterCommand   = Described "target monster"    (checkCursor targetMonster)+quaffCommand     = Described "quaff a potion"    (checkCursor quaffPotion)+readCommand      = Described "read a scroll"     (checkCursor readScroll)+throwCommand     = Described "throw a weapon"    (checkCursor throwItem)+aimCommand       = Described "aim a wand"        (checkCursor aimItem)+waitCommand      = Described "wait"              playerAdvanceTime+saveCommand      = Described "save and exit the game" saveGame quitCommand      = Described "quit without saving" quitGame+cancelCommand    = Described "cancel action"     cancelCurrent+acceptCommand h  = Described "accept choice"     (acceptCurrent h) historyCommand   = Described "display previous messages" displayHistory+dumpCommand      = Described "dump current configuration" dumpConfig+heroCommand      = Described "cycle among heroes on level" cycleHero+versionCommand   = Described "display game version" (abortWith version)  moveDirCommand   = Described "move in direction" move runDirCommand    = Described "run in direction"  run-
src/Config.hs view
@@ -1,71 +1,113 @@-module Config where+module Config+ (CP, defaultCP, config, getOption, getItems, get, getFile, dump) where  import System.Directory import System.FilePath+import System.IO import Control.Monad.Error -import Data.ConfigFile+import qualified Data.ConfigFile as CF import Data.Either.Utils import Data.Maybe-import qualified Data.Binary as B+import qualified Data.Binary as Binary -newtype CP = CP ConfigParser+import qualified ConfigDefault -instance B.Binary CP where-  put (CP config) = B.put $ to_string config+newtype CP = CP CF.ConfigParser++instance Binary.Binary CP where+  put (CP config) = Binary.put $ CF.to_string config   get = do-    string <- B.get-    let parsed = readstring emptyCP string-    return $ CP $ forceEither $ parsed+    string <- Binary.get+    -- use config in case savegame is from older version and lacks some options+    let c = CF.readstring defCF string+    return $ toCP $ forceEither c  instance Show CP where-  show (CP config) = show $ to_string config+  show (CP config) = show $ CF.to_string config --- | Underscore in the name to avoid name clash.-empty_CP :: CP-empty_CP = CP emptyCP+-- | Switches all names to case sensitive (unlike by default in ConfigFile).+toSensitive :: CF.ConfigParser -> CF.ConfigParser+toSensitive cp = cp {CF.optionxform = id} --- | Path to the main configuration file.-file :: IO String+-- | The default configuration taken from the default configuration file+-- included via CPP in ConfigDefault.hs.+defCF :: CF.ConfigParser+defCF  =+  let c = CF.readstring CF.emptyCP ConfigDefault.configDefault+  in  toSensitive $ forceEither c++toCP :: CF.ConfigParser -> CP+toCP cp = CP $ toSensitive cp++defaultCP :: CP+defaultCP = toCP defCF++-- | Path to the user configuration file.+file :: IO FilePath file =   do     appData <- getAppUserDataDirectory "LambdaHack"-    return $ combine appData "LambdaHack.config"+    return $ combine appData "config" --- | The configuration read from the main configuration file.--- If no such file, generate empty configuration.+-- | The configuration read from the user configuration file.+-- The default configuration file provides underlying defaults+-- in case some options, or the whole file, are missing. config :: IO CP config =+  -- evaluate, to catch config errors ASAP+  defCF `seq`   do     f <- file     b <- doesFileExist f     if not b-      then return $ empty_CP+      then return $ toCP $ defCF       else do-        c <- readfile emptyCP f-        return $ CP (forceEither c)+        c <- CF.readfile defCF f+        return $ toCP $ forceEither c  -- | A simplified access to an option in a given section, -- with simple error reporting (no error is caught and hidden). -- If there is no config file or no such option, gives Nothing.-getOption :: Get_C a => CP -> SectionSpec -> OptionSpec ->-             Maybe a+getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a getOption (CP config) s o =-  do-    if has_option config s o-      then let val = get config s o-               valForced = forceEither val-           in  Just valForced-      else Nothing+  if CF.has_option config s o+  then Just $ forceEither $ CF.get config s o+  else Nothing --- | Looks up a file path in the config file, faling back to the default path.--- The path from the config file is taken relative to the home directory--- and the default is taken relative to the current directory. In any case,--- the returned path is absolute.-getFile :: CP -> FilePath -> SectionSpec -> OptionSpec -> IO FilePath-getFile config dflt s o =+-- | A simplified access to an option in a given section.+get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a+get (CP config) s o =+  if CF.has_option config s o+  then forceEither $ CF.get config s o+  else error $ "unknown config option: " ++ s ++ "." ++ o++-- | An association list corresponding to a section.+getItems :: CP -> CF.SectionSpec -> [(String, String)]+getItems (CP config) s =+  if CF.has_section config s+  then forceEither $ CF.items config 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 path is appended to it; otherwise, it's appended+-- to the current directory.+getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath+getFile config s o =   do     current <- getCurrentDirectory     appData <- getAppUserDataDirectory "LambdaHack"-    let path = getOption config s o-    return $ maybe (combine current dflt) (combine appData) path+    let path    = get config s o+        appPath = combine appData path+        curPath = combine current path+    b <- doesDirectoryExist appData+    return $ if b then appPath else curPath++dump :: FilePath -> CP -> IO ()+dump fn (CP config) =+  do+    current <- getCurrentDirectory+    let path = combine current fn+        dump = CF.to_string config+    writeFile path dump
+ src/ConfigDefault.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP, QuasiQuotes #-}++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 src/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"++|]
src/Display.hs view
@@ -1,14 +1,208 @@ {-# LANGUAGE CPP #-} -module Display (module D) where+module Display where  -- wrapper for selected Display frontend  #ifdef CURSES-import Display.Curses as D+import qualified Display.Curses as D #elif GTK-import Display.Gtk as D+import qualified Display.Gtk as D #else-import Display.Vty as D+import qualified Display.Vty as D #endif +-- Display routines that are independent of the selected display frontend.++import qualified Data.Char as Char+import Data.Set as S+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2+import Data.Maybe++import Message+import qualified Color+import State+import Geometry+import Level+import LevelState+import Dungeon+import Perception+import Actor+import ActorState+import ActorKind+import Item+import qualified Keys as K+import qualified Terrain++-- Re-exported from the display frontend, with an extra slot for function+-- for translating keys to a canonical form.+type InternalSession = D.Session+type Session = (InternalSession, M.Map K.Key K.Key)+display area = D.display area . fst+startup = D.startup+shutdown = D.shutdown . fst+displayId = D.displayId++-- | Next event translated to a canonical form.+nextCommand :: MonadIO m => Session -> m K.Key+nextCommand session =+  do+    e <- liftIO $ D.nextEvent (fst session)+    return $+      case M.lookup e (snd session) of+        Just key -> key+        Nothing  -> K.canonMoveKey e++-- | Displays a message on a blank screen. Waits for confirmation.+displayBlankConfirm :: Session -> String -> IO Bool+displayBlankConfirm session txt =+  let x = txt ++ more+      doBlank = const (Color.defaultAttr, ' ')+  in do+       display ((0, 0), normalLevelSize) session doBlank x ""+       getConfirm session++-- | Waits for a space or return or '?' or '*'. The last two act this way,+-- to let keys that request information toggle display the information off.+getConfirm :: MonadIO m => Session -> m Bool+getConfirm session =+  getOptionalConfirm return (const $ getConfirm session) session++getOptionalConfirm :: MonadIO m =>+                      (Bool -> m a) -> (K.Key -> m a) -> Session -> m a+getOptionalConfirm h k session =+  do+    e <- liftIO $ nextCommand session+    case e of+      K.Char ' ' -> h True+      K.Char '?' -> h True+      K.Char '*' -> h True+      K.Return   -> h True+      K.Esc      -> h False+      _          -> k e++-- | A yes-no confirmation.+getYesNo :: MonadIO m => Session -> m Bool+getYesNo session =+  do+    e <- liftIO $ nextCommand session+    case e of+      K.Char 'y' -> return True+      K.Char 'n' -> return False+      K.Esc      -> return False+      _          -> getYesNo session++splitOverlay :: Int -> String -> [[String]]+splitOverlay s xs = splitOverlay' (lines xs)+  where+    splitOverlay' ls+      | length ls <= s = [ls]  -- everything fits on one screen+      | otherwise      = let (pre,post) = splitAt (s - 1) ls+                         in  (pre ++ [more]) : splitOverlay' post++-- | Returns a function that looks up the characters in the+-- string by location. Takes the height of the display plus+-- the string. Returns also the number of screens required+-- to display all of the string.+stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)+stringByLocation sy xs =+  let+    ls   = splitOverlay sy xs+    m    = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))+    k    = length ls+  in+    (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)++data ColorMode = ColorFull | ColorBW++displayLevel ::+  ColorMode -> Session -> Perceptions -> State -> Message -> Maybe String+  -> IO Bool+displayLevel+  dm session per+  (state@(State { scursor = cursor,+                  stime   = time,+                  sassocs = assocs,+                  slevel  = Level ln _ (sy, sx) _ smap lmap _ }))+  msg moverlay =+  let Actor { akind = ActorKind { bhpMax = xhp },+              ahp = php, aloc = ploc, aitems = pitems } = getPlayerBody state+      reachable = ptreachable per+      visible   = ptvisible per+      overlay   = fromMaybe "" moverlay+      (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed+      sSml   = ssensory state == Smell+      sVis   = case ssensory state of Vision _ -> True; _ -> False+      sOmn   = sdisplay state == Omniscient+      sTer   = case sdisplay state of Terrain n -> n; _ -> 0+      lAt    = if sOmn || sTer > 0 then at else rememberAt+      sVisBG = if sVis+               then \ vis rea -> if vis+                                 then Color.Blue+                                 else if rea+                                      then Color.Magenta+                                      else Color.defBG+                else \ vis rea -> Color.defBG+      wealth  = L.sum $ L.map itemPrice pitems+      damage  = case strongestItem pitems "sword" of+                  Just sw -> 3 + ipower sw+                  Nothing -> 3+      hs      = levelHeroList state+      ms      = levelMonsterList state+      dis n loc =+        let tile = lmap `lAt` loc+            sml  = ((smap ! loc) - time) `div` 100+            viewActor loc (Actor { akind = mk })+              | loc == ploc && ln == creturnLn cursor =+                  (bsymbol mk, Color.defBG)  -- highlight player+              | otherwise = (bsymbol mk, bcolor mk)+            viewSmell :: Int -> Char+            viewSmell n+              | n > 9     = '*'+              | n < 0     = '-'+              | otherwise = Char.intToDigit n+            rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1)+            (char, fg) =+              case L.find (\ m -> loc == aloc m) (hs ++ ms) of+                _ | sTer > 0 -> Terrain.viewTerrain sTer False (tterrain tile)+                Just m | sOmn || vis -> viewActor loc m+                _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc)+                  | otherwise        -> viewTile vis tile assocs+            vis = S.member loc visible+            rea = S.member loc reachable+            bg = if ctargeting cursor && loc == clocation cursor+                 then Color.defFG      -- highlight targeting cursor+                 else sVisBG vis rea  -- FOV debug+            reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)+            optVisually (fg, bg) =+              if fg == Color.defBG+              then reverseVideo+              else if bg == Color.defFG && fg == Color.defFG+                   then reverseVideo+                   else (fg, bg)+            a = case dm of+                  ColorBW   -> Color.defaultAttr+                  ColorFull -> optVisually (fg, bg)+        in case over (loc `shift` ((sy+1) * n, 0)) of+             Just c -> (Color.defaultAttr, c)+             _      -> (a, char)+      status =+        take 30 (levelName ln ++ repeat ' ') +++        take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') +++        take 10 ("$: " ++ show wealth ++ repeat ' ') +++        take 10 ("Dmg: " ++ show damage ++ repeat ' ') +++        take 20 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ')+      disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg status+      msgs = splitMsg sx msg+      perf k []     = perfo k ""+      perf k [xs]   = perfo k xs+      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->+                      if b then perf k xs else return False+      perfo k xs+        | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->+                      if b then perfo (k+1) xs else return False+        | otherwise = disp k xs >> return True+  in  perf 0 msgs
src/Display/Curses.hs view
@@ -1,125 +1,126 @@ module Display.Curses-  (displayId, startup, shutdown,-   display, nextEvent, setBG, setFG, setBold, Session,-   white, black, yellow, blue, magenta, red, green, attr, Display.Curses.Attr) where+  (displayId, startup, shutdown, display, nextEvent, Session) where -import UI.HSCurses.Curses as C hiding (setBold)+import UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C import Data.List as L import Data.Map as M import Data.Char-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS+import Control.Monad  import Geometry-import Keys as K+import qualified Keys as K (Key(..))+import qualified Color  displayId = "curses"  data Session =   Session     { win :: Window,-      styles :: Map (Maybe AttrColor, Maybe AttrColor) C.CursesStyle }+      styles :: Map (Color.Color, Color.Color) C.CursesStyle }  startup :: (Session -> IO ()) -> IO () startup k =   do     C.start-    C.startColor     cursSet CursorInvisible+    let s = [ ((f, b), C.Style (toFColor f) (toBColor b))+            | f <- [minBound..maxBound],+              -- No more color combinations possible: 16*4, 64 is max.+              b <- Color.legalBG ]     nr <- colorPairs-    let s = [ ((f,b), C.Style (toFColor f) (toBColor b))-            | f <- Nothing : L.map Just [minBound..maxBound],-              b <- Nothing : L.map Just [minBound..maxBound] ]-    let (ks, vs) = unzip (tail s)  -- drop the Nothing/Nothing combo-    ws <- C.convertStyles (take (nr - 1) vs)-    k (Session C.stdScr (M.fromList (zip ks ws)))+    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 (Session C.stdScr styleMap)  shutdown :: Session -> IO () shutdown w = C.end -display :: Area -> Session -> (Loc -> (Display.Curses.Attr, Char)) -> String -> String -> IO ()+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO () display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =   do-    erase-    mvWAddStr w 0 0 msg-    sequence_ [ let (a,c) = f (y,x) in C.setStyle (findWithDefault C.defaultCursesStyle a s) >> mvWAddStr w (y+1) x [c]-              | x <- [x0..x1], y <- [y0..y1] ]-    mvWAddStr w (y1+2) 0 status+    -- let defaultStyle = C.defaultCursesStyle+    -- Terminals with white background require this:+    let defaultStyle = s ! Color.defaultAttr+    C.erase+    C.setStyle defaultStyle+    mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg)  -- TODO: BS as in vty+    mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status)+    sequence_ [ C.setStyle (findWithDefault defaultStyle a s)+                >> mvWAddStr w (y+1) x [c]+              | x <- [x0..x1], y <- [y0..y1], let (a, c) = f (y, x) ]     refresh-{--    in  V.update vty (Pic NoCursor -         ((renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) msg)))) <->-          img <-> -          (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) status))))))--} -{- toWidth :: Int -> String -> String toWidth n x = take n (x ++ repeat ' ')--} -keyTranslate :: C.Key -> Maybe K.Key+keyTranslate :: C.Key -> K.Key keyTranslate e =   case e of-    C.KeyChar '\ESC' -> Just K.Esc-    C.KeyExit        -> Just K.Esc-    C.KeyChar '\n'   -> Just K.Return-    C.KeyChar '\r'   -> Just K.Return-    C.KeyEnter       -> Just K.Return-    C.KeyUp          -> Just K.Up-    C.KeyDown        -> Just K.Down-    C.KeyLeft        -> Just K.Left-    C.KeyRight       -> Just K.Right-    C.KeyHome        -> Just K.Home-    C.KeyPPage       -> Just K.PgUp-    C.KeyEnd         -> Just K.End-    C.KeyNPage       -> Just K.PgDn-    C.KeyBeg         -> Just K.Begin-    C.KeyB2          -> Just K.Begin-    C.KeyChar c      -> Just (K.Char c)-    _                -> Nothing+    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 '\t'   -> K.Tab+    C.KeyUp          -> K.Up+    C.KeyDown        -> K.Down+    C.KeyLeft        -> K.Left+    C.KeyRight       -> 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+    -- For now, movement keys are more important than hero selection:+    C.KeyChar c+      | c `elem` ['1'..'9'] -> K.KP c+      | otherwise           -> K.Char c+    _                       -> K.Unknown (show e)  nextEvent :: Session -> IO K.Key nextEvent session =   do     e <- C.getKey refresh-    maybe (nextEvent session) return (keyTranslate e)--type Attr = (Maybe AttrColor, Maybe AttrColor)--attr = (Nothing, Nothing)--data AttrColor = White | Black | Yellow | Blue | Magenta | Red | Green -  deriving (Show, Eq, Ord, Enum, Bounded)--toFColor :: Maybe AttrColor -> C.ForegroundColor-toFColor (Just White)    = C.WhiteF-toFColor (Just Black)    = C.BlackF-toFColor (Just Yellow)   = C.BrownF-toFColor (Just Blue)     = C.DarkBlueF-toFColor (Just Magenta)  = C.PurpleF-toFColor (Just Red)      = C.DarkRedF-toFColor (Just Green)    = C.DarkGreenF-toFColor Nothing         = C.DefaultF--toBColor :: Maybe AttrColor -> C.BackgroundColor-toBColor (Just White)    = C.WhiteB-toBColor (Just Black)    = C.BlackB-toBColor (Just Yellow)   = C.BrownB-toBColor (Just Blue)     = C.DarkBlueB-toBColor (Just Magenta)  = C.PurpleB-toBColor (Just Red)      = C.DarkRedB-toBColor (Just Green)    = C.DarkGreenB-toBColor Nothing         = C.DefaultB+    return (keyTranslate e)+--    case keyTranslate e of+--      Unknown _ -> nextEvent session+--      k -> return k -white   = White-black   = Black-yellow  = Yellow-blue    = Blue-magenta = Magenta-red     = Red-green   = Green+toFColor :: Color.Color -> C.ForegroundColor+toFColor Color.Black     = C.BlackF+toFColor Color.Red       = C.DarkRedF+toFColor Color.Green     = C.DarkGreenF+toFColor Color.Yellow    = 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 -setBold (f, b) = (f, b)-setFG c (_, b) = (Just c, b)-setBG c (f, _) = (f, Just c)+toBColor :: Color.Color -> C.BackgroundColor+toBColor Color.Black     = C.BlackB+toBColor Color.Red       = C.DarkRedB+toBColor Color.Green     = C.DarkGreenB+toBColor Color.Yellow    = 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
src/Display/Gtk.hs view
@@ -1,40 +1,28 @@ module Display.Gtk-  (displayId, startup, shutdown, -   display, nextEvent, setBG, setFG, setBold, Session,-   white, black, yellow, blue, magenta, red, green, attr, Attr) where+  (displayId, startup, shutdown, display, nextEvent, Session) where +import qualified Data.Binary import Control.Monad import Control.Concurrent import Graphics.UI.Gtk.Gdk.Events  -- TODO: replace, deprecated-import Graphics.UI.Gtk hiding (Attr)+import Graphics.UI.Gtk import Data.List as L import Data.IORef import Data.Map as M+import qualified Data.ByteString.Char8 as BS  import Geometry-import Keys as K+import qualified Keys as K (Key(..), keyTranslate)+import qualified Color  displayId = "gtk"  data Session =   Session {     schan :: Chan String,-    stags :: Map AttrKey TextTag,+    stags :: Map Color.Attr TextTag,     sview :: TextView } -doAttr :: TextTag -> AttrKey -> IO ()-doAttr tt (BG Blue)    = set tt [ textTagBackground := "#0000CC" ]-doAttr tt (BG Magenta) = set tt [ textTagBackground := "#CC00CC" ]-doAttr tt (BG Green)   = set tt [ textTagBackground := "#00CC00" ]-doAttr tt (BG Red)     = set tt [ textTagBackground := "#CC0000" ]-doAttr tt (BG White)   = set tt [ textTagBackground := "#FFFFFF" ]-doAttr tt (FG Green)   = set tt [ textTagForeground := "#00FF00" ]-doAttr tt (FG Red)     = set tt [ textTagForeground := "#FF0000" ]-doAttr tt (FG Blue)    = set tt [ textTagForeground := "#0000FF" ]-doAttr tt (FG Yellow)  = set tt [ textTagForeground := "#CCCC00" ]-doAttr tt (FG Black)   = set tt [ textTagForeground := "#000000" ]-doAttr tt _            = return ()- startup :: (Session -> IO ()) -> IO () startup k =   do@@ -45,12 +33,12 @@     ttt <- textTagTableNew     -- text attributes     tts <- fmap M.fromList $-           mapM (\ c -> do-                          tt <- textTagNew Nothing-                          textTagTableAdd ttt tt-                          doAttr tt c-                          return (c,tt))-                [ x | c <- [minBound .. maxBound], x <- [FG c, BG c]]+           mapM (\ ak -> do+                           tt <- textTagNew Nothing+                           textTagTableAdd ttt tt+                           doAttr tt ak+                           return (ak, tt))+                [ (f, b) | f <- [minBound..maxBound], b <- Color.legalBG ]      -- text buffer     tb <- textBufferNew (Just ttt)@@ -90,14 +78,14 @@                                    return True                                _ -> return False) -    let black = Color minBound minBound minBound-    let white = Color maxBound maxBound maxBound+    let black = Color minBound minBound minBound  -- Color.defBG == Color.Black+        white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White     widgetModifyBase tv StateNormal black     widgetModifyText tv StateNormal white -    ec <- newChan +    ec <- newChan     forkIO $ k (Session ec tts tv)-    +     onKeyPress tv (\ e -> postGUIAsync (writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)) >> return True)      onDestroy w mainQuit -- set quit handler@@ -107,23 +95,41 @@  shutdown _ = mainQuit -display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()-display ((y0,x0),(y1,x1)) session f msg status =+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO ()+display ((y0,x0), (y1,x1)) session f msg status =   postGUIAsync $   do     tb <- textViewGetBuffer (sview session)-    let text = unlines [ [ snd (f (y,x)) | x <- [x0..x1] ] | y <- [y0..y1] ]-    textBufferSetText tb (msg ++ "\n" ++ text ++ status)-    sequence_ [ setTo tb (stags session) (y,x) a | -                y <- [y0..y1], x <- [x0..x1], let loc = (y,x), let (a,c) = f (y,x) ]+    let fLine y = let (as, cs) = unzip [ f (y, x) | x <- [x0..x1] ]+                  in  ((y, as), BS.pack cs)+        memo  = L.map fLine [y0..y1]+        attrs = L.map fst memo+        chars = L.map snd memo+        bs    = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status]+    textBufferSetByteString tb (BS.concat bs)+    mapM_ (setTo tb (stags session) x0) attrs -setTo :: TextBuffer -> Map AttrKey TextTag -> Loc -> Attr -> IO ()-setTo tb tts (ly,lx) a =-  do-    ib <- textBufferGetIterAtLineOffset tb (ly+1) lx-    ie <- textIterCopy ib-    textIterForwardChar ie-    mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a+setTo :: TextBuffer -> Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) -> IO ()+setTo tb tts lx (ly, []) = return ()+setTo tb tts lx (ly, a:as) = do+  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx+  ie <- textIterCopy ib+  let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO ()+      setIter previous repetitions [] = do+        textIterForwardChars ie repetitions+        when (previous /= Color.defaultAttr) $+          textBufferApplyTag tb (tts ! previous) ib ie+      setIter previous repetitions (a:as)+        | a == previous =+            setIter a (repetitions + 1) as+        | otherwise = do+            textIterForwardChars ie repetitions+            when (previous /= Color.defaultAttr) $+              textBufferApplyTag tb (tts ! previous) ib ie+            textIterForwardChars ib repetitions+            setIter a 1 as+  setIter a 1 as  -- | reads until a non-dead key encountered readUndeadChan :: Chan String -> IO String@@ -151,64 +157,16 @@             "Caps_Lock"        -> True             _                  -> False -keyTranslate :: String -> Maybe K.Key-keyTranslate "less"          = Just (K.Char '<')-keyTranslate "greater"       = Just (K.Char '>')-keyTranslate "period"        = Just (K.Char '.')-keyTranslate "colon"         = Just (K.Char ':')-keyTranslate "comma"         = Just (K.Char ',')-keyTranslate "space"         = Just (K.Char ' ')-keyTranslate "question"      = Just (K.Char '?')-keyTranslate "asterisk"      = Just (K.Char '*')-keyTranslate "Escape"        = Just K.Esc-keyTranslate "Return"        = Just K.Return-keyTranslate "KP_Up"         = Just K.Up-keyTranslate "KP_Down"       = Just K.Down-keyTranslate "KP_Left"       = Just K.Left-keyTranslate "KP_Right"      = Just K.Right-keyTranslate "KP_Home"       = Just K.Home-keyTranslate "KP_End"        = Just K.End-keyTranslate "KP_Page_Up"    = Just K.PgUp-keyTranslate "KP_Page_Down"  = Just K.PgDn-keyTranslate "KP_Begin"      = Just K.Begin-keyTranslate "KP_Enter"      = Just K.Return-keyTranslate ['K','P','_',c] = Just (K.Char c)  -- for numbers-keyTranslate [c]             = Just (K.Char c)-keyTranslate _               = Nothing- nextEvent :: Session -> IO K.Key nextEvent session =   do     e <- readUndeadChan (schan session)-    maybe (nextEvent session) return (keyTranslate e)--setBold   = id  -- not supported yet-setBG c   = (BG c :)-setFG c   = (FG c :)-blue      = Blue-magenta   = Magenta-red       = Red-yellow    = Yellow-green     = Green-white     = White-black     = Black-attr      = []--type Attr = [AttrKey]--data AttrKey =-    FG AttrColor-  | BG AttrColor-  deriving (Eq, Ord)--type Color = AttrColor+    return (K.keyTranslate e) -data AttrColor =-    Blue-  | Magenta-  | Red-  | Green-  | Yellow-  | White-  | Black-  deriving (Eq, Ord, Enum, Bounded)+doAttr :: TextTag -> Color.Attr -> IO ()+doAttr tt (fg, bg)+  | (fg, bg) == 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]
src/Display/Vty.hs view
@@ -1,15 +1,14 @@ module Display.Vty-  (displayId, startup, shutdown,-   display, nextEvent, setBold, setBG, setFG, Session,-   white, black, yellow, blue, magenta, red, green, attr, Attr) where+  (displayId, startup, shutdown, display, nextEvent, Session) where  import Graphics.Vty as V import Data.List as L import Data.Char-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS  import Geometry-import Keys as K+import qualified Keys as K (Key(..))+import qualified Color  displayId = "vty" @@ -18,47 +17,80 @@ startup :: (Session -> IO ()) -> IO () startup k = V.mkVty >>= k -display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO () display ((y0,x0),(y1,x1)) vty f msg status =-    let img = (foldr (<->) V.empty_image .-               L.map (foldr (<|>) V.empty_image .-                      L.map (\ (x,y) -> let (a,c) = f (y,x) in char a c)))-              [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]-    in  V.update vty (pic_for_image-         (utf8_bytestring attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) msg))) <->-          img <-> -          utf8_bytestring attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) status)))))+  let img = (foldr (<->) V.empty_image .+             L.map (foldr (<|>) V.empty_image .+                    L.map (\ (x,y) -> let (a, c) = f (y, x)+                                      in  char (setAttr a) c)))+            [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]+  in  V.update vty (pic_for_image+       (utf8_bytestring (setAttr Color.defaultAttr)+        (BS.pack (toWidth (x1 - x0 + 1) msg)) <->+        img <->+        utf8_bytestring (setAttr Color.defaultAttr)+        (BS.pack (toWidth (x1 - x0 + 1) status))))  toWidth :: Int -> String -> String toWidth n x = take n (x ++ repeat ' ') -keyTranslate :: V.Event -> Maybe K.Key+keyTranslate :: V.Event -> K.Key keyTranslate e =   case e of-    V.EvKey KEsc []         -> Just K.Esc-    V.EvKey KEnter []       -> Just K.Return-    V.EvKey KUp []          -> Just K.Up-    V.EvKey KDown []        -> Just K.Down-    V.EvKey KLeft []        -> Just K.Left-    V.EvKey KRight []       -> Just K.Right-    V.EvKey KHome []        -> Just K.Home-    V.EvKey KPageUp []      -> Just K.PgUp-    V.EvKey KEnd []         -> Just K.End-    V.EvKey KPageDown []    -> Just K.PgDn-    V.EvKey KBegin []       -> Just K.Begin-    V.EvKey (KASCII c) []   -> Just (K.Char c)-    _                       -> Nothing+    V.EvKey KEsc []          -> K.Esc+    V.EvKey KEnter []        -> K.Return+    V.EvKey (KASCII '\t') [] -> K.Tab+    V.EvKey KUp []           -> K.Up+    V.EvKey KDown []         -> K.Down+    V.EvKey KLeft []         -> K.Left+    V.EvKey KRight []        -> K.Right+    V.EvKey KHome []         -> K.Home+    V.EvKey KPageUp []       -> K.PgUp+    V.EvKey KEnd []          -> K.End+    V.EvKey KPageDown []     -> K.PgDn+    V.EvKey KBegin []        -> K.Begin+    -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8+    -- For now, movement keys are more important than hero selection:+    V.EvKey (KASCII c) []+      | c `elem` ['1'..'9']  -> K.KP c+      | otherwise            -> K.Char c+    _                        -> K.Unknown (show e)  nextEvent :: Session -> IO K.Key nextEvent session =   do     e <- V.next_event session-    maybe (nextEvent session) return (keyTranslate e)--attr = def_attr+    return (keyTranslate e) -setBold a = with_style a bold+-- 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 c a = if Color.isBright c then with_style a bold else a -setBG c a = with_back_color a c+setAttr (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) } -setFG c a = with_fore_color a c+aToc :: Color.Color -> Color+aToc Color.Black     = black+aToc Color.Red       = red+aToc Color.Green     = green+aToc Color.Yellow    = 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
− src/Display2.hs 
@@ -1,194 +0,0 @@-module Display2 (module Display, module Display2) where---- Display routines that are independent of the selected display frontend.--import Data.Set as S-import Data.List as L-import Data.Map as M-import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2--import Message-import Display-import State-import Geometry-import Level-import LevelState-import Dungeon-import Perception-import Monster-import Item-import Keys as K---- | Next event translated to a canonical form-nextCommand :: MonadIO m => Session -> m Key-nextCommand session =-  do-    e <- liftIO $ nextEvent session-    return (canonicalKey e)---- | maps a key to the canonical key for the command it denotes-canonicalKey :: Key -> Key-canonicalKey e =-  case e of-    K.Char '8' -> K.Char 'K'-    K.Char '2' -> K.Char 'J'-    K.Char '4' -> K.Char 'H'-    K.Char '6' -> K.Char 'L'-    K.Char '7' -> K.Char 'Y'-    K.Char '9' -> K.Char 'U'-    K.Char '1' -> K.Char 'B'-    K.Char '3' -> K.Char 'N'-    K.Char '5' -> K.Char '.'-    K.Up       -> K.Char 'k'-    K.Down     -> K.Char 'j'-    K.Left     -> K.Char 'h'-    K.Right    -> K.Char 'l'-    K.Home     -> K.Char 'y'-    K.PgUp     -> K.Char 'u'-    K.End      -> K.Char 'b'-    K.PgDn     -> K.Char 'n'-    K.Begin    -> K.Char '.'-    k          -> k---- | Displays a message on a blank screen. Waits for confirmation.-displayBlankConfirm :: Session -> String -> IO Bool-displayBlankConfirm session txt =-  let x = txt ++ more-  in  do-        display ((0, 0), normalLevelSize) session (const (attr, ' ')) x ""-        getConfirm session---- | Waits for a space or return.-getConfirm :: MonadIO m => Session -> m Bool-getConfirm session =-  getOptionalConfirm return (const $ getConfirm session) session--getOptionalConfirm :: MonadIO m => (Bool -> m a) -> (Key -> m a) -> Session -> m a-getOptionalConfirm h k session =-  do-    e <- liftIO $ nextCommand session-    case e of-      K.Char ' ' -> h True-      K.Return   -> h True-      K.Esc      -> h False-      _          -> k e---- | A yes-no confirmation.-getYesNo :: MonadIO m => Session -> m Bool-getYesNo session =-  do-    e <- liftIO $ nextCommand session-    case e of-      K.Char 'y' -> return True-      K.Char 'n' -> return False-      K.Esc      -> return False-      _          -> getYesNo session---- | Configurable event handler for the direction keys. Is used to---   handle player moves, but can also be used for directed commands---   such as open/close.-handleDirection :: Key -> (Dir -> a) -> a -> a-handleDirection e h k =-  case e of-    K.Char 'k' -> h up-    K.Char 'j' -> h down-    K.Char 'h' -> h left-    K.Char 'l' -> h right-    K.Char 'y' -> h upleft-    K.Char 'u' -> h upright-    K.Char 'b' -> h downleft-    K.Char 'n' -> h downright-    _          -> k---- | Configurable event handler for the upper direction keys. Is used to---   handle player moves, but can also be used for directed commands---   such as open/close.-handleUDirection :: Key -> (Dir -> a) -> a -> a-handleUDirection e h k =-  case e of-    K.Char 'K' -> h up-    K.Char 'J' -> h down-    K.Char 'H' -> h left-    K.Char 'L' -> h right-    K.Char 'Y' -> h upleft-    K.Char 'U' -> h upright-    K.Char 'B' -> h downleft-    K.Char 'N' -> h downright-    _          -> k--splitOverlay :: Int -> String -> [[String]]-splitOverlay s xs = splitOverlay' (lines xs)-  where-    splitOverlay' ls-      | length ls <= s = [ls]  -- everything fits on one screen-      | otherwise      = let (pre,post) = splitAt (s - 1) ls-                         in  (pre ++ [more]) : splitOverlay' post---- | Returns a function that looks up the characters in the--- string by location. Takes the height of the display plus--- the string. Returns also the number of screens required--- to display all of the string.-stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)-stringByLocation sy xs =-  let-    ls   = splitOverlay sy xs-    m    = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))-    k    = length ls-  in-    (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)--displayLevel :: Session -> Perception -> State -> Message -> Maybe String -> IO Bool-displayLevel session per-             (state@(State { splayer = player@(Monster { mhpmax = phpmax, mhp = php, mdir = pdir, mloc = ploc }),-                             stime   = time,-                             sassocs = assocs,-                             slevel  = lvl@(Level nm sz@(sy,sx) ms smap nlmap lmeta) }))-             msg moverlay =-    let-      overlay = maybe "" id moverlay-      reachable = preachable per-      visible   = pvisible per-      sSml    = ssensory state == Smell-      sVis    = case ssensory state of Vision _ -> True; _ -> False-      sOmn    = sdisplay state == Omniscient-      sTer    = case sdisplay state of Terrain n -> n; _ -> 0-      lAt     = if sOmn || sTer > 0 then at else rememberAt-      lVision = if sVis-                  then \ vis rea ->-                       if      vis then setBG blue-                       else if rea then setBG magenta-                                   else id-                  else \ vis rea -> id-      (n,over) = stringByLocation (sy+1) overlay -- n is the number of overlay screens-      gold    = maybe 0 (icount . fst) $ findItem (\ i -> iletter i == Just '$') (mitems player)-      disp n msg =-        display ((0,0),sz) session-                 (\ loc -> let tile = nlmap `lAt` loc-                               sml  = ((smap ! loc) - time) `div` 100-                               vis  = S.member loc visible-                               rea  = S.member loc reachable-                               (rv,ra) = case L.find (\ m -> loc == mloc m) (player:ms) of-                                           _ | sTer > 0          -> viewTerrain sTer False (tterrain tile)-                                           Just m | sOmn || vis  -> viewMonster (mtype m)-                                           _ | sSml && sml >= 0  -> viewSmell sml-                                             | otherwise         -> viewTile vis tile assocs-                               vision = lVision vis rea-                           in-                             case over (loc `shift` ((sy+1) * n, 0)) of-                               Just c  ->  (attr, c)-                               _       ->  (ra . vision $ attr, rv))-                msg-                (take 40 (levelName nm ++ repeat ' ') ++-                 take 10 ("$: " ++ show gold ++ repeat ' ') ++-                 take 15 ("HP: " ++ show php ++ " (" ++ show phpmax ++ ")" ++ repeat ' ') ++-                 take 10 ("T: " ++ show (time `div` 10) ++ repeat ' '))-      msgs = splitMsg sx msg-      perf k []     = perfo k ""-      perf k [xs]   = perfo k xs-      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->-                      if b then perf k xs else return False-      perfo k xs-        | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->-                      if b then perfo (k+1) xs else return False-        | otherwise = disp k xs >> return True-    in perf 0 msgs
src/Dungeon.hs view
@@ -2,18 +2,46 @@  import Prelude hiding (floor) import Control.Monad+import qualified System.Random as R +import Data.Binary import Data.Map as M import Data.List as L import Data.Ratio+import Data.Maybe -import State import Geometry+import GeometryRnd import Level-import Monster import Item import Random+import Terrain+import qualified ItemKind +-- | The complete dungeon is a map from level names to levels.+-- We usually store all but the current level in this data structure.+newtype Dungeon = Dungeon (M.Map LevelName Level)+  deriving Show++instance Binary Dungeon where+  put (Dungeon dng) = put (M.elems dng)+  get = liftM dungeon get++-- | Create a dungeon from a list of levels.+dungeon :: [Level] -> Dungeon+dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))++-- | Extract a level from a dungeon.+getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)+getDungeonLevel ln (Dungeon dng) = (dng ! ln, Dungeon (M.delete ln dng))++-- | Put a level into a dungeon.+putDungeonLevel :: Level -> Dungeon -> Dungeon+putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)++sizeDungeon :: Dungeon -> Int+sizeDungeon (Dungeon dng) = M.size dng+ type Corridor = [(Y,X)] type Room = Area @@ -37,6 +65,20 @@     (ry,rx) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd,x1 - bd))     return ((ry,rx),(ry,rx)) +data HV = Horiz | Vert+  deriving (Eq, Show, Bounded)++fromHV Horiz = True+fromHV Vert  = False++toHV True  = Horiz+toHV False = Vert++instance R.Random HV where+  randomR (a,b) g = case R.randomR (fromHV a, fromHV b) g of+                      (b, g') -> (toHV b, g')+  random g = R.randomR (minBound, maxBound) g+ -- | Create a corridor, either horizontal or vertical, with -- a possible intermediate part that is in the opposite direction. mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -}@@ -81,17 +123,17 @@ digCorridor _ l = l  -- | Create a new tile.-newTile :: Terrain -> (Tile, Tile)+newTile :: Terrain DungeonLoc -> (Tile, Tile) newTile t = (Tile t [], Tile Unknown [])  -- | Create a level consisting of only one room. Optionally, insert some walls.-emptyroom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig ->+emptyRoom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig ->            LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-emptyroom addWallsRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm =+emptyRoom addWallsRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm =   do     let lmap = digRoom Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx))     let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ]-    let lvl = Level nm (sy,sx) [] smap lmap ""+    let lvl = Level nm emptyParty (sy,sx) emptyParty smap lmap ""     -- locations of the stairs     su <- findLoc lvl (const floor)     sd <- findLoc lvl (\ l t -> floor t@@ -104,29 +146,29 @@           addWalls $           maybe id (\ l -> M.insert su (newTile (Stairs Light Up   l))) lu $           maybe id (\ l -> M.insert sd (newTile (Stairs Light Down l))) ld $-          (\lmap -> foldl' addItem lmap is) $+          (\lmap -> L.foldl' addItem lmap is) $           lmap-        level lu ld = Level nm (sy,sx) [] smap (flmap lu ld) "bigroom"+        level lu ld = Level nm emptyParty (sy,sx) emptyParty smap (flmap lu ld) "bigroom"     return (level, su, sd)  -- | For a bigroom level: Create a level consisting of only one, empty room.-bigroom :: LevelConfig ->+bigRoom :: LevelConfig ->            LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-bigroom = emptyroom (\ lvl -> return id)+bigRoom = emptyRoom (\ lvl -> return id)  -- | For a noiseroom level: Create a level consisting of only one room -- with randomly distributed pillars.-noiseroom :: LevelConfig ->+noiseRoom :: LevelConfig ->              LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-noiseroom cfg =+noiseRoom cfg =   let addWalls lvl = do         rs <- rollPillars cfg lvl         let insertWall lmap l =               case lmap `at` l of                 Tile (Floor _) [] -> M.insert l (newTile (Wall O)) lmap                 _ -> lmap-        return $ \ lmap -> foldl' insertWall lmap rs-  in  emptyroom addWalls cfg+        return $ \ lmap -> L.foldl' insertWall lmap rs+  in  emptyRoom addWalls cfg  data LevelConfig =   LevelConfig {@@ -136,10 +178,8 @@     border            :: Int,       -- must be at least 2!     levelSize         :: (Y,X),     -- lower right point     extraConnects     :: (Y,X) -> Int,-                                    -- relative to grid-                                    -- (in fact a range, because of duplicate connects)-    noRooms           :: (Y,X) -> Rnd Int,-                                    -- range, relative to grid+      -- relative to grid (in fact a range, because of duplicate connects)+    noRooms           :: (Y,X) -> Rnd Int,  -- range, relative to grid     minStairsDistance :: Int,       -- must not be too large     doorChance        :: Rnd Bool,     doorOpenChance    :: Rnd Bool,@@ -184,15 +224,15 @@  -- | Create a "normal" dungeon level. Takes a configuration in order -- to tweak all sorts of data.-level :: LevelConfig ->+rogueRoom :: LevelConfig ->          LevelName ->          Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) ->               Level, Loc, Loc)-level cfg nm =+rogueRoom cfg nm =   do     lgrid    <- levelGrid cfg     lminroom <- minRoomSize cfg-    let gs = M.toList (grid lgrid ((0,0),levelSize cfg))+    let gs = grid lgrid ((0, 0), levelSize cfg)     -- grid locations of "no-rooms"     nrnr <- noRooms cfg lgrid     nr   <- replicateM nrnr (do@@ -220,9 +260,9 @@     let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg,                                            y <- [0..sy], x <- [0..sx] ]     let lmap :: LMap-        lmap = foldr digCorridor (foldr (\ (r, dl) m -> digRoom dl r m)+        lmap = L.foldr digCorridor (L.foldr (\ (r, dl) m -> digRoom dl r m)                                         (emptyLMap (levelSize cfg)) dlrooms) cs-    let lvl = Level nm (levelSize cfg) [] smap lmap ""+    let lvl = Level nm emptyParty (levelSize cfg) emptyParty smap lmap ""     -- convert openings into doors     dlmap <- fmap M.fromList . mapM                 (\ o@((y,x),(t,r)) ->@@ -238,7 +278,7 @@                         rs <- if ro then return Nothing                                     else do rsc <- doorSecretChance cfg                                             fmap Just-                                                 (if rsc then randomR (1, doorSecretMax cfg)+                                                 (if rsc then randomR (doorSecretMax cfg `div` 2, doorSecretMax cfg)                                                          else return 0)                         if rb                           then return ((y,x),newTile (Door hv rs))@@ -257,9 +297,9 @@     return (\ lu ld ->       let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Up   l)) su) lu $                   maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Down l)) sd) ld $-                  foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is+                  L.foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is                   dlmap-      in  Level nm (levelSize cfg) [] smap flmap meta, su, sd)+      in  Level nm emptyParty (levelSize cfg) emptyParty smap flmap meta, su, sd)  rollItems :: LevelConfig -> Level -> Loc -> Rnd [(Loc, Item)] rollItems cfg lvl ploc =@@ -267,9 +307,9 @@     nri <- nrItems cfg     replicateM nri $       do-        t <- newItem (depth cfg) itemFrequency-        l <- case itype t of-               Sword _ ->+        t <- newItem (depth cfg)+        l <- case ItemKind.jname (ItemKind.getIK (ikind t)) of+               "sword" ->                  -- swords generated close to monsters; MUAHAHAHA                  findLocTry 200 lvl                    (const floor)@@ -301,24 +341,3 @@                      ++ [ ((y,x),newTile (Wall p))     | x <- [x0..x1], (y,p) <- [(y0-1,U),(y1+1,D)] ]                      ++ [ ((y,x),newTile (Wall p))     | (x,p) <- [(x0-1,L),(x1+1,R)],  y <- [y0..y1]    ]   in M.unionWith const rm l---- | Create a new monster in the level, at a random position.-addMonster :: Level -> Player -> Rnd Level-addMonster lvl@(Level { lmonsters = ms, lmap = lmap })-           player@(Monster { mloc = ploc }) =-  do-    rc <- monsterGenChance (lname lvl) ms-    if rc-     then do-            -- TODO: new monsters should always be generated in a place that isn't-            -- visible by the player (if possible -- not possible for bigrooms)-            -- levels with few rooms are dangerous, because monsters may spawn-            -- in adjacent and unexpected places-            sm <- findLocTry 1000 lvl-                    (\ l t -> not (l `L.elem` L.map mloc (player : ms))-                              && open t)-                    (\ l t -> distance (ploc, l) > 400-                              && floor t)-            m <- newMonster sm monsterFrequency-            return (updateMonsters (const (m : ms)) lvl)-     else return lvl
+ src/DungeonState.hs view
@@ -0,0 +1,40 @@+module DungeonState where++import Data.Map as M++import Geometry+import Level+import Dungeon+import Random+import qualified Config++connect ::+  Maybe (Maybe DungeonLoc) ->+  [(Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)] ->+  [Level]+connect au [(x,_,_)] = [x au Nothing]+connect au ((x,_,d):ys@((_,u,_):_)) =+  let (z:zs) = connect (Just (Just (lname x',d))) ys+      x'     = x au (Just (Just (lname z,u)))+  in  x' : z : zs++matchGenerator n Nothing = rogueRoom  -- the default+matchGenerator n (Just "bigRoom")   = bigRoom+matchGenerator n (Just "noiseRoom") = noiseRoom+matchGenerator n (Just "rogueRoom") = rogueRoom+matchGenerator n (Just s) =+  error $ "matchGenerator: unknown: " ++ show n ++ ", " ++ s++findGenerator config n =+  let ln = "LambdaCave_" ++ show n+      genName = Config.getOption config "dungeon" ln+  in  matchGenerator n genName (defaultLevelConfig n) (LambdaCave n)++-- | Generate the dungeon for a new game.+generate :: Config.CP -> Rnd (Loc, Level, Dungeon)+generate config = do+  let depth = Config.get config "dungeon" "depth"+  levels <- mapM (findGenerator config) [1..depth]+  let lvls = connect (Just Nothing) levels+      ploc = ((\ (_,x,_) -> x) (head levels))+  return $ (ploc, head lvls, dungeon (tail lvls))
+ src/Effect.hs view
@@ -0,0 +1,41 @@+module Effect where++import Random++data Effect =+    NoEffect+  | Heal            -- healing strength in ipower+  | Wound RollDice  -- base damage, to-dam bonus in ipower+  | Dominate+  | SummonFriend+  | SummonEnemy+  | ApplyPerfume+  | Regneration+  | Searching+  deriving (Show, Eq, Ord)++effectToName :: Effect -> String+effectToName NoEffect = ""+effectToName Heal = "of healing"+effectToName (Wound (a, b)) = if a == 0 && b == 0+                              then "of wounding"+                              else "(" ++ show a ++ "d" ++ show b ++ ")"+effectToName Dominate = "of domination"+effectToName SummonFriend = "of aid calling"+effectToName SummonEnemy = "of summoning"+effectToName ApplyPerfume = "of rose water"+effectToName Regneration = "of regeneration"+effectToName Searching = "of searching"++-- | How much AI benefits from applying the effect. Multipllied by item power.+-- Negative means harm to the enemy when thrown. Zero won't ever be used.+effectToBenefit :: Effect -> Int+effectToBenefit NoEffect = 0+effectToBenefit Heal = 10           -- TODO: depends on (maxhp - hp)+effectToBenefit (Wound _) = -10     -- TODO: dice ignored for now+effectToBenefit Dominate = 0        -- AI can't use this+effectToBenefit SummonFriend = 100+effectToBenefit SummonEnemy = 0+effectToBenefit ApplyPerfume = 0+effectToBenefit Regneration = 0     -- much more benefit from carrying around+effectToBenefit Searching = 0       -- AI does not need to search
+ src/EffectAction.hs view
@@ -0,0 +1,334 @@+module EffectAction where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Function+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Set as S+import System.Time+import Control.Exception (assert)++import Action+import Display hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified ItemKind+import qualified Keys as K+import Level+import LevelState+import Message+import Actor+import ActorState+import ActorKind+import ActorAdd+import Perception+import Random+import State+import qualified Config+import qualified Save+import Terrain+import qualified Effect++-- The effectToAction function and all it depends on.+-- This file should not depend on Action.hs nor ItemAction.hs.++-- | The source actor affects the target actor, with a given effect and power.+-- The second argument is verbosity of the resulting message.+-- TODO: instead of verbosity return msg components and tailor them outside?+-- Both actors are on the current level and can be the same actor.+-- The bool result indicates if the actors identify the effect.+-- TODO: separately define messages for the case when source == target+-- and for the other case; then use the messages outside of effectToAction,+-- depending on the returned bool, perception and identity of the actors.+effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int ->+                  Action (Bool, String)+effectToAction Effect.NoEffect _ source target power = nullEffect+effectToAction Effect.Heal _ _source target power = do+  tm <- gets (getActor target)+  if ahp tm >= bhpMax (akind tm) || power <= 0+    then nullEffect+    else do+      focusIfAHero target+      let upd m = m { ahp = min (bhpMax (akind m)) (ahp m + power) }+      updateAnyActor target upd+      return (True, subjectActorVerb (akind tm) "feel" ++ " better.")+effectToAction (Effect.Wound nDm) verbosity source target power = do+  n <- liftIO $ rndToIO $ rollDice nDm+  if (n + power <= 0) then nullEffect else do+    focusIfAHero target+    tm <- gets (getActor target)+    let newHP  = ahp tm - n - power+        killed = newHP <= 0+        msg = if source == target  -- a potion of wounding, etc.+              then subjectActorVerb (akind tm) "feel"+                   ++ if killed then " mortally" else ""+                   ++ " wounded."+              else if killed+                   then if isAHero target+                        then ""+                        else subjectActorVerb (akind tm) "die" ++ "."+                   else if verbosity <= 0+                        then ""+                        else if isAHero target+                             then subjectActorVerb (akind tm) "lose"+                                  ++ " " ++ show (n + power) ++ "HP."+                             else subjectActorVerb (akind tm) "hiss"+                                  ++ " in pain."+    updateAnyActor target $ \ m -> m { ahp = newHP }  -- Damage the target.+    when killed $ do+      -- Place the actor's possessions on the map.+      modify (updateLevel (dropItemsAt (aitems tm) (aloc tm)))+      -- Clean bodies up.+      pl <- gets splayer+      if target == pl+        then checkPartyDeath  -- kills the player and checks game over+        else modify (deleteActor target)  -- kills the enemy+    return (True, msg)+effectToAction Effect.Dominate _ source target power =+  if isAMonster target  -- Monsters have weaker will than heroes.+  then do+         assertTrue $ selectPlayer target+         -- Prevent AI from getting a few free moves until new player ready.+         updatePlayerBody (\ m -> m { atime = 0})+         display+         return (True, "")+  else nullEffect+effectToAction Effect.SummonFriend _ source target power = do+  tm <- gets (getActor target)+  if isAHero source+    then summonHeroes (1 + power) (aloc tm)+    else summonMonsters (1 + power) (aloc tm)+  return (True, "")+effectToAction Effect.SummonEnemy _ source target power = do+  tm <- gets (getActor target)+  if not $ isAHero source  -- a trick: monster player will summon a hero+    then summonHeroes (1 + power) (aloc tm)+    else summonMonsters (1 + power) (aloc tm)+  return (True, "")+effectToAction Effect.ApplyPerfume _ source target _ =+  if source == target+  then return (True, "Tastes like water, but with a strong rose scent.")+  else do+    let upd lvl = lvl { lsmell = M.map (const (-100)) (lsmell lvl) }+    modify (updateLevel upd)+    return (True, "The fragrance quells all scents in the vicinity.")+effectToAction Effect.Regneration verbosity source target power =+  effectToAction Effect.Heal verbosity source target power+effectToAction Effect.Searching _ source target power =+  return (True, "It gets lost and you search in vain.")++nullEffect :: Action (Bool, String)+nullEffect = return (False, "Nothing happens.")++-- | The source actor affects the target actor, with a given item.+-- If either actor is a hero, the item may get identified.+itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool+itemEffectAction verbosity source target item = do+  state <- get+  pl    <- gets splayer+  tm    <- gets (getActor target)+  per   <- currentPerception+  let effect = ItemKind.jeffect $ ItemKind.getIK $ ikind item+  -- The message describes the target part of the action.+  (b, msg) <- effectToAction effect verbosity source target (ipower item)+  -- Determine how the player perceives the event.+  -- TODO: factor it out as a function messageActor+  -- and messageActorVerb (incorporating subjectActorVerb).+  if aloc tm `S.member` ptvisible per+     then messageAdd msg+     else if not b+          then return ()  -- victim is not seen and nothing interestng happens+          else messageAdd "You hear some noises."+  -- If something happens, the item gets identified.+  when (b && (isAHero source || isAHero target)) $ discover item+  return b++-- | Given item is now known to the player.+discover :: Item -> Action ()+discover i = do+  state <- get+  let ik = ikind i+      obj = unwords $ tail $ words $ objectItem state i+      msg = "The " ++ obj ++ " turns out to be "+      kind = ItemKind.getIK ik+      alreadyIdentified = L.length (ItemKind.jflavour kind) == 1 ||+                          ik `S.member` sdiscoveries state+  if alreadyIdentified+    then return ()+    else do+           modify (updateDiscoveries (S.insert ik))+           state <- get+           messageAdd $ msg ++ objectItem state i ++ "."++-- | Make the actor controlled by the player.+-- Focus on the actor if level changes. False, if nothing to do.+selectPlayer :: ActorId -> Action Bool+selectPlayer actor =+  do+    pl <- gets splayer+    if (actor == pl)+      then return False -- already selected+      else do+        state <- get+        case findActorAnyLevel actor state of+          Nothing -> abortWith $ "No such member of the party."+          Just (nln, pbody) -> do+            -- Make the new actor the player-controlled actor.+            modify (\ s -> s { splayer = actor })+            -- Record the original level of the new player.+            modify (updateCursor (\ c -> c { creturnLn = nln }))+            -- Don't continue an old run, if any.+            stopRunning+            -- Switch to the level.+            lvlSwitch nln+            -- Set smell display, depending on player capabilities.+            -- This also resets FOV mode.+            modify (\ s -> s { ssensory = if ActorKind.bsmell (akind pbody)+                                          then Smell+                                          else Implicit })+            -- Announce.+            messageAdd $ subjectActor (akind pbody) ++ " selected."+            return True++focusIfAHero :: ActorId -> Action ()+focusIfAHero target =+  if isAHero target+  then do+    -- Focus on the hero being wounded/displaced/etc.+    b <- selectPlayer target+    -- Display status line for the new hero.+    when b $ display >> return ()+  else return ()++summonHeroes :: Int -> Loc -> Action ()+summonHeroes n loc =+  assert (n > 0) $ do+  newHeroId <- gets (fst . scounter)+  modify (\ state -> iterate (addHero loc) state !! n)+  assertTrue $ selectPlayer (AHero newHeroId)+  -- Display status line for the new hero.+  display >> return ()++summonMonsters :: Int -> Loc -> Action ()+summonMonsters n loc = do+  let fmk = Frequency $ L.zip (L.map bfreq dungeonMonsters) dungeonMonsters+  mk <- liftIO $ rndToIO $ frequency fmk+  modify (\ state -> iterate (addMonster mk (bhpMax mk) loc) state !! n)++-- | Remove dead heroes, check if game over.+-- For now we only check the selected hero, but if poison, etc.+-- is implemented, we'd need to check all heroes on the level.+checkPartyDeath :: Action ()+checkPartyDeath =+  do+    ahs    <- gets allHeroesAnyLevel+    pl     <- gets splayer+    pbody  <- gets getPlayerBody+    config <- gets sconfig+    when (ahp pbody <= 0) $ do  -- TODO: change to guard? define mzero? Why are the writes to to files performed when I call abort later? That probably breaks the laws of MonadPlus.+      go <- messageMoreConfirm ColorBW $+              subjectActorVerb (akind pbody) "die" ++ "."+      history  -- Prevent the messages from being repeated.+      let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"+      if firstDeathEnds+        then gameOver go+        else case L.filter (\ (actor, _) -> actor /= pl) ahs of+               [] -> gameOver go+               (actor, _nln) : _ -> do+                 messageAdd "The survivors carry on."+                 -- Remove the dead player.+                 modify (deleteActor pl)+                 -- At this place the invariant that the player exists fails.+                 -- Focus on the new hero (invariant not needed).+                 assertTrue $ selectPlayer actor+                 -- At this place the invariant is restored again.++-- | End game, showing the ending screens, if requested.+gameOver :: Bool -> Action ()+gameOver showEndingScreens =+  do+    when showEndingScreens $ do+      state <- get+      ln <- gets (lname . slevel)+      let total = calculateTotal state+          status = H.Killed ln+      handleScores True status total+      messageMore "Let's hope another party can save the day!"+    end++-- | Calculate loot's worth for heroes on the current level.+calculateTotal :: State -> Int+calculateTotal s =+  L.sum $ L.map itemPrice $ L.concatMap aitems (levelHeroList s)++-- | Handle current score and display it with the high scores. Scores+-- should not be shown during the game, because ultimately the worth of items might give+-- information about the nature of the items.+-- False if display of the scores was void or interrupted by the user+handleScores :: Bool -> H.Status -> Int -> Action Bool+handleScores write status total =+  if (total == 0)+  then return False+  else do+    config  <- gets sconfig+    time    <- gets stime+    curDate <- liftIO getClockTime+    let points = case status of+                   H.Killed _ -> (total + 1) `div` 2+                   _ -> total+    let score = H.ScoreRecord points (-time) curDate status+    (placeMsg, slideshow) <- liftIO $ H.register config write score+    messageOverlaysConfirm placeMsg slideshow++-- | Perform a level switch to a given level. False, if nothing to do.+lvlSwitch :: LevelName -> Action Bool+lvlSwitch nln =+  do+    ln <- gets (lname . slevel)+    if (nln == ln)+      then return False+      else do+        level   <- gets slevel+        dungeon <- gets sdungeon+        -- put back current level+        -- (first put back, then get, in case we change to the same level!)+        let full = putDungeonLevel level dungeon+        -- get new level+        let (new, ndng) = getDungeonLevel nln full+        modify (\ s -> s { sdungeon = ndng, slevel = new })+        return True++-- effectToAction does not depend on this function right now, but it might,+-- and I know no better place to put it.+displayItems :: Message -> Bool -> [Item] -> Action Bool+displayItems msg sorted is = do+  state <- get+  let inv = unlines $+            L.map (\ i -> letterLabel (iletter i) ++ objectItem state i ++ " ")+              ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)+  let ovl = inv ++ more+  messageReset msg+  overlay ovl++stopRunning :: Action ()+stopRunning = updatePlayerBody (\ p -> p { adir = Nothing })++-- | Store current message in the history and reset current message.+history :: Action ()+history =+  do+    (_, sx) <- gets (lsize . slevel)+    msg     <- currentMessage+    messageClear+    config  <- gets sconfig+    let historyMax = Config.get config "ui" "historyMax"+        -- TODO: not ideal, continuations of sentences are atop beginnings.+        split = splitMsg sx (msg ++ " ")+    unless (L.null msg) $+      modify (updateHistory (take historyMax . (L.reverse split ++)))
src/FOV.hs view
@@ -7,19 +7,16 @@ import Data.Maybe import Debug.Trace +import FOV.Common+import FOV.Digital+import FOV.Permissive+import FOV.Shadow import Geometry import Level -type Interval = (Rational, Rational)-type Distance = Int-type Progress = Int-newtype Bump      = B Loc  deriving (Show)-type Line         = (Bump, Bump)-type ConvexHull   = [Bump]-type Edge         = (Line, ConvexHull)-type EdgeInterval = (Edge, Edge)--data FovMode = Shadow | Permissive Int | Diagonal Int+-- TODO: should Blind really be a FovMode, or a modifier? Let's decide+-- when other similar modifiers are added.+data FovMode = Shadow | Permissive Int | Digital Int | Blind  -- Three Field of View algorithms. Press 'V' to cycle among them in the game. @@ -42,373 +39,12 @@                 (((B(1, 0), B(0, r+1)), [B(0, 1)]),                  ((B(0, 1), B(r+1, 0)), [B(1, 0)])))       [qtr0,qtr1,qtr2,qtr3]-    Diagonal r    ->  -- diagonal with range r+    Digital r    ->  -- digital with range r       S.unions $       L.map (\ tr ->               dscan r (tr loc) lmap 1                 (((B(0, 1), B(r, -r)),  [B(0, 0)]),                  ((B(0, 0), B(r, r+1)), [B(0, 1)])))       [qtr0,qtr1,qtr2,qtr3]---- Common functions.---- | The translation, rotation and symmetry functions for octants.-tr0 (oy,ox) (d,p) = (oy + d,ox + p)-tr1 (oy,ox) (d,p) = (oy + d,ox - p)-tr2 (oy,ox) (d,p) = (oy - d,ox + p)-tr3 (oy,ox) (d,p) = (oy - d,ox - p)-tr4 (oy,ox) (d,p) = (oy + p,ox + d)-tr5 (oy,ox) (d,p) = (oy + p,ox - d)-tr6 (oy,ox) (d,p) = (oy - p,ox + d)-tr7 (oy,ox) (d,p) = (oy - p,ox - d)---- | The translation and rotation functions for quadrants.-qtr0, qtr1, qtr2, qtr3 :: Loc -> Bump -> Loc-qtr0 (oy, ox) (B(y, x)) = (oy - y, ox + x)  -- first quadrant-qtr1 (oy, ox) (B(y, x)) = (oy - x, ox - y)  -- then rotated clockwise 90 degrees-qtr2 (oy, ox) (B(y, x)) = (oy + y, ox - x)-qtr3 (oy, ox) (B(y, x)) = (oy + x, ox + y)---- | Integer division, rounding up.-divUp n k = - (-n) `div` k---- | Maximal element of a non-empty list. Prefers elements from the rear,--- which is essential for PFOV, to avoid ill-defined lines.-maximal :: (a -> a -> Bool) -> [a] -> a-maximal gte = L.foldl1' (\ acc x -> if gte x acc then x else acc)---- | Check if the line from the second point to the first is more steep--- than the line from the third point to the first. This is related--- to the formal notion of gradient (or angle), but hacked wrt signs--- to work in this particular setup. Returns True for ill-defined lines.-steeper :: Bump ->  Bump -> Bump -> Bool-steeper (B(yf, xf)) (B(y1, x1)) (B(y2, x2)) =-  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)---- | Adds a bump to the convex hull of bumps represented as a list.-addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull-addHull gte b l =-  case l of-    x:y:zs ->-      if gte x y-      then addHull gte b (y:zs)-      else b : l-    _ -> b : l---- Recursive Shadow Casting.---- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.--- It's not designed for dungeons with diagonal walls, so they block visibility,--- though they don't block movement. Such cases appear in LambdaHack only--- when two corridors touch diagonally by accident and on the random pillars--- levels.---- | The current state of a scan is kept in a variable of Maybe Rational.--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-scan :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc-scan tr l d (s,e) =-    let ps = downBias (s * fromIntegral d)   -- minimal progress to check-        pe = upBias (e * fromIntegral d)     -- maximal progress to check-        st = if open (l `at` tr (d,ps)) then Just s   -- start in light-                                        else Nothing  -- start in shadow-    in-        -- trace (show (d,s,e,ps,pe)) $-        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)-  where-    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc-    -- scan' st ps pe-    --   | trace (show (st,ps,pe)) False = undefined-    scan' (Just s) ps pe-      | s  >= e  = S.empty               -- empty interval-      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next-      | closed (l `at` tr (d,ps)) =-                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))-                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe-                                      -- entering shadow-      | otherwise = scan' (Just s) (ps+1) pe-                                      -- continue in light-    scan' Nothing ps pe-      | ps > pe  = S.empty            -- reached end while in shadow-      | open (l `at` tr (d,ps)) =-                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-                   in  scan' (Just ns) (ps+1) pe-                                      -- moving out of shadow-      | otherwise = scan' Nothing (ps+1) pe-                                      -- continue in shadow--downBias, upBias :: (Integral a, Integral b) => Ratio a -> b-downBias x = round (x - 1 % (denominator x * 3))-upBias   x = round (x + 1 % (denominator x * 3))----- Permissive FOV with a given range.---- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View,--- though the general structure is more influenced by recursive shadow casting,--- as implemented above. In the result, this algorithm is much faster--- on dense maps, since it does not scan areas blocked by shadows.--- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los for some more context.---- TODO: Scanning squares on horizontal lines in octants, not squares--- on diagonals in quadrants, may be much faster and a bit simpler.--- Right now we build new view on each end of each visible wall tile--- and this is necessary only for straight, thin, diagonal walls.---- | The current state of a scan is kept in Maybe (Line, ConvexHull).--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->-         Set Loc-pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =-  -- trace (show (d,s,e,ps,pe)) $-  if illegal-  then S.empty-  else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]])-    -- the area is diagonal, which is incorrect, but looks good enough-    where-      (ns, ks) = pintersect sl d-      (ne, ke) = pintersect el d-      -- Corners are translucent, so they are invisible, so if intersection-      -- is at a corner, choose pe that creates the smaller view.-      (ps, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check-      -- Single ray from an extremity, produces non-permissive digital lines.-      illegal  = let (n, k) = pintersect sl 0-                 in  ns*ke == ne*ks && (n == 0 || n == k)-      outside-        | d >= r = S.empty-        | open (l `at` tr (d, ps)) = pscan' (Just s) ps  -- start in light-        | ps == ns `divUp` ks = pscan' (Just s) ps       -- start in a corner-        | otherwise = pscan' Nothing (ps+1)              -- start in mid-wall--      dp2bump     (d, p) = B(p, d - p)-      bottomRight (d, p) = B(p, d - p + 1)-      tr = ptr . dp2bump--      pscan' :: Maybe Edge -> Progress -> Set Loc-      pscan' (Just s@(_, sBumps)) ps-        | ps > pe =                            -- reached end, scan next-            pscan r ptr l (d+1) (s, e)-        | closed (l `at` tr (d, ps)) =         -- entering shadow, steep bump-            let steepBump = bottomRight (d, ps)-                gte = flip $ psteeper steepBump-                -- sBumps may contain steepBump, but maximal will ignore it-                nep = maximal gte sBumps-                neBumps = addHull gte steepBump eBumps-            in  S.union-                  (pscan r ptr l (d+1) (s, (pline nep steepBump, neBumps)))-                  (pscan' Nothing (ps+1))-        | otherwise = pscan' (Just s) (ps+1)   -- continue in light--      pscan' Nothing ps-        | ps > ne `div` ke = S.empty           -- reached absolute end-        | otherwise =                          -- out of shadow, shallow bump-            -- the light can be just through a corner of diagonal walls-            -- and the recursive call verifies that at the same ps coordinate-            let shallowBump = bottomRight (d, ps)-                gte = psteeper shallowBump-                nsp = maximal gte eBumps-                nsBumps = addHull gte shallowBump sBumps-            in  pscan' (Just (pline nsp shallowBump, nsBumps)) ps--      pline p1 p2 =-        pdebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)--      psteeper f p1 p2 =-        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2---- | The y coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of squares at distance d from (0, 0).-pintersect :: Line -> Distance -> (Int, Int)-pintersect (B(y, x), B(yf, xf)) d =-  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))-{--Derivation of the formula:-The intersection point (yt, xt) satisfies the following equalities:-xt = 1 + d - yt-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-yt (xf - x) - y xf = xt (yf - y) - x yf-yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf-yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf-yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)--General remarks:-A square is denoted by its bottom-left corner. Hero at (0,0).-Order of processing in the first quadrant is-9-58-247-@136-so the first processed square is at (0, 1). The order is reversed-wrt the shadow casting algorithm above. The line in the curent state-of scan' is not the steep line, but the shallow line,-and we start scanning from the bottom right.--The Loc coordinates are cartesian, the Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first quadrant, the (Distance, Progress) cordinates-are mangled and not used for geometry.--}---- | Debug functions for PFOV:---- | Debug: calculate steeper for PFOV in another way and compare results.-pdebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool-pdebugSteeper f p1 p2 x =-  let (n1, k1) = pintersect (p1, f) 0-      (n2, k2) = pintersect (p2, f) 0-  in  if x == (n1 * k2 <= k1 * n2)-      then x-      else error $ "psteeper: " ++ show (f, p1, p2, x)---- | Debug: checks postconditions of borderLine.-pdebugLine :: Line -> Line-pdebugLine line@(B(y1, x1), B(y2, x2))-  | y1 == y2 && x1 == x2 =-      error $ "pdebugLine: wrongly defined line " ++ show line-  | x2 - x1 == - (y2 - y1) =-      error $ "pdebugLine: diagonal line " ++ show line-  | crossL0 =-      error $ "pdebugLine: crosses diagonal below 0 " ++ show line-  | crossG1 =-      error $ "pdebugLine: crosses diagonal above 1 " ++ show line-  | otherwise = line-    where-      (n, k)  = pintersect line 0-      (q, r)  = if k == 0 then (0, 0) else n `divMod` k-      crossL0 = q < 0  -- q truncated toward negative infinity-      crossG1 = q >= 1 && (q > 1 || r /= 0)----- Digital FOV with a given range.---- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation,--- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been--- implemented before. The algorithm is based on the PFOV algorithm,--- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View.--- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los for some more context.---- | The current state of a scan is kept in Maybe (Line, ConvexHull).--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->-         Set Loc-dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =-  -- trace (show (d,s,e,ps,pe)) $-  S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]])-    -- the scanned area is a square, which is a sphere in this metric; good-    where-      ps = let (n, k) = dintersect sl d       -- minimal progress to check-           in  n `div` k-      pe = let (n, k) = dintersect el d       -- maximal progress to check-               -- Corners obstruct view, so the steep line, constructed-               -- from corners, is itself not a part of the view,-               -- so if its intersection with the line of diagonals is only-               -- at a corner, choose the diamond leading to a smaller view.-           in  -1 + n `divUp` k-      outside-        | d >= r = S.empty-        | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe))-        | open (l `at` tr (B(d, ps))) =-            dscan' (Just s) (ps+1)            -- start in light, jump ahead-        | otherwise = dscan' Nothing (ps+1)   -- start in shadow, jump ahead--      dscan' :: Maybe Edge -> Progress -> Set Loc-      dscan' (Just s@(_, sBumps)) ps-        | ps > pe = dscan r tr l (d+1) (s, e) -- reached end, scan next-        | closed (l `at` tr steepBump) =      -- entering shadow-            S.union-              (dscan r tr l (d+1) (s, (dline nep steepBump, neBumps)))-              (dscan' Nothing (ps+1))-        | otherwise = dscan' (Just s) (ps+1)  -- continue in light-        where-          steepBump = B(d, ps)-          gte = dsteeper steepBump-          nep = maximal gte sBumps-          neBumps = addHull gte steepBump eBumps--      dscan' Nothing ps-        | ps > pe = S.empty                   -- reached end while in shadow-        | open (l `at` tr shallowBump) =      -- moving out of shadow-            dscan' (Just (dline nsp shallowBump, nsBumps)) (ps+1)-        | otherwise = dscan' Nothing (ps+1)   -- continue in shadow-        where-          shallowBump = B(d, ps)-          gte = flip $ dsteeper shallowBump-          nsp = maximal gte eBumps-          nsBumps = addHull gte shallowBump sBumps--      dline p1 p2 =-        ddebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)--      dsteeper f p1 p2 =-        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2---- | The x coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of diamonds at distance d from (0, 0).-dintersect :: Line -> Distance -> (Int, Int)-dintersect (B(y, x), B(yf, xf)) d =-  ((d - y)*(xf - x) + x*(yf - y), yf - y)-{--Derivation of the formula:-The intersection point (yt, xt) satisfies the following equalities:-yt = d-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) + x (yf - y) = xt (yf - y)-xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)--General remarks:-A diamond is denoted by its left corner. Hero at (0,0).-Order of processing in the first quadrant rotated by 45 degrees is- 45678-  123-   @-so the first processed diamond is at (-1, 1). The order is similar-as for the shadow casting algorithm above and reversed wrt PFOV.-The line in the curent state of scan' is called the shallow line,-but it's the one that delimits the view from the left, while the steep-line is on the right, opposite to PFOV. We start scanning from the left.--The Loc coordinates are cartesian, the Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first roatated quadrant, the (Distance, Progress) cordinates-coincide with the Bump coordinates, unlike in PFOV.--}---- | Debug functions for DFOV:---- | Debug: calculate steeper for DFOV in another way and compare results.-ddebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool-ddebugSteeper f p1 p2 x =-  let (n1, k1) = dintersect (p1, f) 0-      (n2, k2) = dintersect (p2, f) 0-  in  if x == (n1 * k2 >= k1 * n2)-      then x-      else error $ "dsteeper: " ++ show (f, p1, p2, x)---- | Debug: check is a view border line for DFOV is legal.-ddebugLine :: Line -> Line-ddebugLine line@(B(y1, x1), B(y2, x2))-  | y1 == y2 && x1 == x2 =-      error $ "ddebugLine: wrongly defined line " ++ show line-  | y2 - y1 == 0 =-      error $ "ddebugLine: horizontal line " ++ show line-  | crossL0 =-      error $ "ddebugLine: crosses the X axis below 0 " ++ show line-  | crossG1 =-      error $ "ddebugLine: crosses the X axis above 1 " ++ show line-  | otherwise = line-    where-      (n, k)  = dintersect line 0-      (q, r)  = if k == 0 then (0, 0) else n `divMod` k-      crossL0 = q < 0  -- q truncated toward negative infinity-      crossG1 = q >= 1 && (q > 1 || r /= 0)+    Blind        ->  -- only feeling out adjacent tiles by touch+      S.empty
+ src/FOV/Common.hs view
@@ -0,0 +1,58 @@+module FOV.Common where++import Data.List as L++import Geometry++type Interval = (Rational, Rational)+type Distance = Int+type Progress = Int+newtype Bump      = B Loc  deriving (Show)+type Line         = (Bump, Bump)+type ConvexHull   = [Bump]+type Edge         = (Line, ConvexHull)+type EdgeInterval = (Edge, Edge)++-- | The translation, rotation and symmetry functions for octants.+tr0 (oy,ox) (d,p) = (oy + d,ox + p)+tr1 (oy,ox) (d,p) = (oy + d,ox - p)+tr2 (oy,ox) (d,p) = (oy - d,ox + p)+tr3 (oy,ox) (d,p) = (oy - d,ox - p)+tr4 (oy,ox) (d,p) = (oy + p,ox + d)+tr5 (oy,ox) (d,p) = (oy + p,ox - d)+tr6 (oy,ox) (d,p) = (oy - p,ox + d)+tr7 (oy,ox) (d,p) = (oy - p,ox - d)++-- | The translation and rotation functions for quadrants.+qtr0, qtr1, qtr2, qtr3 :: Loc -> Bump -> Loc+qtr0 (oy, ox) (B(y, x)) = (oy - y, ox + x)  -- first quadrant+qtr1 (oy, ox) (B(y, x)) = (oy - x, ox - y)  -- then rotated clockwise 90 degrees+qtr2 (oy, ox) (B(y, x)) = (oy + y, ox - x)+qtr3 (oy, ox) (B(y, x)) = (oy + x, ox + y)++-- | Integer division, rounding up.+divUp n k = - (-n) `div` k++-- | Maximal element of a non-empty list. Prefers elements from the rear,+-- which is essential for PFOV, to avoid ill-defined lines.+maximal :: (a -> a -> Bool) -> [a] -> a+maximal gte = L.foldl1' (\ acc x -> if gte x acc then x else acc)++-- | Check if the line from the second point to the first is more steep+-- than the line from the third point to the first. This is related+-- to the formal notion of gradient (or angle), but hacked wrt signs+-- to work in this particular setup. Returns True for ill-defined lines.+steeper :: Bump ->  Bump -> Bump -> Bool+steeper (B(yf, xf)) (B(y1, x1)) (B(y2, x2)) =+  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)++-- | Adds a bump to the convex hull of bumps represented as a list.+addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull+addHull gte b l =+  case l of+    x:y:zs ->+      if gte x y+      then addHull gte b (y:zs)+      else b : l+    _ -> b : l+
+ src/FOV/Digital.hs view
@@ -0,0 +1,137 @@+module FOV.Digital where++import Data.Set as S++import FOV.Common+import Geometry+import Level++-- Digital FOV with a given range.++-- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation,+-- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been+-- implemented before. The algorithm is based on the PFOV algorithm,+-- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View.+-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los+-- for some more context.++-- | The current state of a scan is kept in Maybe (Line, ConvexHull).+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]])+    -- the scanned area is a square, which is a sphere in this metric; good+    where+      ps = let (n, k) = dintersect sl d       -- minimal progress to check+           in  n `div` k+      pe = let (n, k) = dintersect el d       -- maximal progress to check+               -- Corners obstruct view, so the steep line, constructed+               -- from corners, is itself not a part of the view,+               -- so if its intersection with the line of diagonals is only+               -- at a corner, choose the diamond leading to a smaller view.+           in  -1 + n `divUp` k+      outside+        | d >= r = S.empty+        | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe))+        | open (l `at` tr (B(d, ps))) =+            dscan' (Just s) (ps+1)            -- start in light, jump ahead+        | otherwise = dscan' Nothing (ps+1)   -- start in shadow, jump ahead++      dscan' :: Maybe Edge -> Progress -> Set Loc+      dscan' (Just s@(_, sBumps)) ps+        | ps > pe = dscan r tr l (d+1) (s, e) -- reached end, scan next+        | closed (l `at` tr steepBump) =      -- entering shadow+            S.union+              (dscan r tr l (d+1) (s, (dline nep steepBump, neBumps)))+              (dscan' Nothing (ps+1))+        | otherwise = dscan' (Just s) (ps+1)  -- continue in light+        where+          steepBump = B(d, ps)+          gte = dsteeper steepBump+          nep = maximal gte sBumps+          neBumps = addHull gte steepBump eBumps++      dscan' Nothing ps+        | ps > pe = S.empty                   -- reached end while in shadow+        | open (l `at` tr shallowBump) =      -- moving out of shadow+            dscan' (Just (dline nsp shallowBump, nsBumps)) (ps+1)+        | otherwise = dscan' Nothing (ps+1)   -- continue in shadow+        where+          shallowBump = B(d, ps)+          gte = flip $ dsteeper shallowBump+          nsp = maximal gte eBumps+          nsBumps = addHull gte shallowBump sBumps++      dline p1 p2 =+        ddebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      dsteeper f p1 p2 =+        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        steeper f p1 p2++-- | The x coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of diamonds at distance d from (0, 0).+dintersect :: Line -> Distance -> (Int, Int)+dintersect (B(y, x), B(yf, xf)) d =+  ((d - y)*(xf - x) + x*(yf - y), yf - y)+{-+Derivation of the formula:+The intersection point (yt, xt) satisfies the following equalities:+yt = d+(yt - y) (xf - x) = (xt - x) (yf - y)+hence+(yt - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) + x (yf - y) = xt (yf - y)+xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)++General remarks:+A diamond is denoted by its left corner. Hero at (0,0).+Order of processing in the first quadrant rotated by 45 degrees is+ 45678+  123+   @+so the first processed diamond is at (-1, 1). The order is similar+as for the shadow casting algorithm above and reversed wrt PFOV.+The line in the curent state of scan' is called the shallow line,+but it's the one that delimits the view from the left, while the steep+line is on the right, opposite to PFOV. We start scanning from the left.++The Loc coordinates are cartesian, the Bump coordinates are cartesian,+translated so that the hero is at (0, 0) and rotated so that he always+looks at the first roatated quadrant, the (Distance, Progress) cordinates+coincide with the Bump coordinates, unlike in PFOV.+-}++-- | Debug functions for DFOV:++-- | Debug: calculate steeper for DFOV in another way and compare results.+ddebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+ddebugSteeper f p1 p2 x =+  let (n1, k1) = dintersect (p1, f) 0+      (n2, k2) = dintersect (p2, f) 0+  in  if x == (n1 * k2 >= k1 * n2)+      then x+      else error $ "dsteeper: " ++ show (f, p1, p2, x)++-- | Debug: check is a view border line for DFOV is legal.+ddebugLine :: Line -> Line+ddebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "ddebugLine: wrongly defined line " ++ show line+  | y2 - y1 == 0 =+      error $ "ddebugLine: horizontal line " ++ show line+  | crossL0 =+      error $ "ddebugLine: crosses the X axis below 0 " ++ show line+  | crossG1 =+      error $ "ddebugLine: crosses the X axis above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = dintersect line 0+      (q, r)  = if k == 0 then (0, 0) else n `divMod` k+      crossL0 = q < 0  -- q truncated toward negative infinity+      crossG1 = q >= 1 && (q > 1 || r /= 0)
+ src/FOV/Permissive.hs view
@@ -0,0 +1,150 @@+module FOV.Permissive where++import Data.Set as S++import FOV.Common+import Geometry+import Level++-- Permissive FOV with a given range.++-- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View,+-- though the general structure is more influenced by recursive shadow casting,+-- 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.+-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los+-- for some more context.++-- TODO: Scanning squares on horizontal lines in octants, not squares+-- on diagonals in quadrants, may be much faster and a bit simpler.+-- Right now we build new view on each end of each visible wall tile+-- and this is necessary only for straight, thin, diagonal walls.++-- | The current state of a scan is kept in Maybe (Line, ConvexHull).+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  if illegal+  then S.empty+  else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]])+    -- the area is diagonal, which is incorrect, but looks good enough+    where+      (ns, ks) = pintersect sl d+      (ne, ke) = pintersect el d+      -- Corners are translucent, so they are invisible, so if intersection+      -- is at a corner, choose pe that creates the smaller view.+      (ps, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check+      -- Single ray from an extremity, produces non-permissive digital lines.+      illegal  = let (n, k) = pintersect sl 0+                 in  ns*ke == ne*ks && (n == 0 || n == k)+      outside+        | d >= r = S.empty+        | open (l `at` tr (d, ps)) = pscan' (Just s) ps  -- start in light+        | ps == ns `divUp` ks = pscan' (Just s) ps       -- start in a corner+        | otherwise = pscan' Nothing (ps+1)              -- start in mid-wall++      dp2bump     (d, p) = B(p, d - p)+      bottomRight (d, p) = B(p, d - p + 1)+      tr = ptr . dp2bump++      pscan' :: Maybe Edge -> Progress -> Set Loc+      pscan' (Just s@(_, sBumps)) ps+        | ps > pe =                            -- reached end, scan next+            pscan r ptr l (d+1) (s, e)+        | closed (l `at` tr (d, ps)) =         -- entering shadow, steep bump+            let steepBump = bottomRight (d, ps)+                gte = flip $ psteeper steepBump+                -- sBumps may contain steepBump, but maximal will ignore it+                nep = maximal gte sBumps+                neBumps = addHull gte steepBump eBumps+            in  S.union+                  (pscan r ptr l (d+1) (s, (pline nep steepBump, neBumps)))+                  (pscan' Nothing (ps+1))+        | otherwise = pscan' (Just s) (ps+1)   -- continue in light++      pscan' Nothing ps+        | ps > ne `div` ke = S.empty           -- reached absolute end+        | otherwise =                          -- out of shadow, shallow bump+            -- the light can be just through a corner of diagonal walls+            -- and the recursive call verifies that at the same ps coordinate+            let shallowBump = bottomRight (d, ps)+                gte = psteeper shallowBump+                nsp = maximal gte eBumps+                nsBumps = addHull gte shallowBump sBumps+            in  pscan' (Just (pline nsp shallowBump, nsBumps)) ps++      pline p1 p2 =+        pdebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      psteeper f p1 p2 =+        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        steeper f p1 p2++-- | The y coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of squares at distance d from (0, 0).+pintersect :: Line -> Distance -> (Int, Int)+pintersect (B(y, x), B(yf, xf)) d =+  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))+{-+Derivation of the formula:+The intersection point (yt, xt) satisfies the following equalities:+xt = 1 + d - yt+(yt - y) (xf - x) = (xt - x) (yf - y)+hence+(yt - y) (xf - x) = (xt - x) (yf - y)+yt (xf - x) - y xf = xt (yf - y) - x yf+yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf+yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf+yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)++General remarks:+A square is denoted by its bottom-left corner. Hero at (0,0).+Order of processing in the first quadrant is+9+58+247+@136+so the first processed square is at (0, 1). The order is reversed+wrt the shadow casting algorithm above. The line in the curent state+of scan' is not the steep line, but the shallow line,+and we start scanning from the bottom right.++The Loc coordinates are cartesian, the Bump coordinates are cartesian,+translated so that the hero is at (0, 0) and rotated so that he always+looks at the first quadrant, the (Distance, Progress) cordinates+are mangled and not used for geometry.+-}++-- | Debug functions for PFOV:++-- | Debug: calculate steeper for PFOV in another way and compare results.+pdebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+pdebugSteeper f p1 p2 x =+  let (n1, k1) = pintersect (p1, f) 0+      (n2, k2) = pintersect (p2, f) 0+  in  if x == (n1 * k2 <= k1 * n2)+      then x+      else error $ "psteeper: " ++ show (f, p1, p2, x)++-- | Debug: checks postconditions of borderLine.+pdebugLine :: Line -> Line+pdebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "pdebugLine: wrongly defined line " ++ show line+  | x2 - x1 == - (y2 - y1) =+      error $ "pdebugLine: diagonal line " ++ show line+  | crossL0 =+      error $ "pdebugLine: crosses diagonal below 0 " ++ show line+  | crossG1 =+      error $ "pdebugLine: crosses diagonal above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = pintersect line 0+      (q, r)  = if k == 0 then (0, 0) else n `divMod` k+      crossL0 = q < 0  -- q truncated toward negative infinity+      crossG1 = q >= 1 && (q > 1 || r /= 0)
+ src/FOV/Shadow.hs view
@@ -0,0 +1,54 @@+module FOV.Shadow where++import Data.Ratio+import Data.Set as S++import FOV.Common+import Geometry+import Level++-- Recursive Shadow Casting.++-- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.+-- It's not designed for dungeons with diagonal walls, so they block visibility,+-- though they don't block movement. Such cases appear in the game only+-- when two corridors touch diagonally by accident and on the random pillars+-- levels.++-- | The current state of a scan is kept in a variable of Maybe Rational.+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+scan :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc+scan tr l d (s,e) =+    let ps = downBias (s * fromIntegral d)   -- minimal progress to check+        pe = upBias (e * fromIntegral d)     -- maximal progress to check+        st = if open (l `at` tr (d,ps)) then Just s   -- start in light+                                        else Nothing  -- start in shadow+    in+        -- trace (show (d,s,e,ps,pe)) $+        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)+  where+    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc+    -- scan' st ps pe+    --   | trace (show (st,ps,pe)) False = undefined+    scan' (Just s) ps pe+      | s  >= e  = S.empty               -- empty interval+      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next+      | closed (l `at` tr (d,ps)) =+                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))+                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe+                                      -- entering shadow+      | otherwise = scan' (Just s) (ps+1) pe+                                      -- continue in light+    scan' Nothing ps pe+      | ps > pe  = S.empty            -- reached end while in shadow+      | open (l `at` tr (d,ps)) =+                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))+                   in  scan' (Just ns) (ps+1) pe+                                      -- moving out of shadow+      | otherwise = scan' Nothing (ps+1) pe+                                      -- continue in shadow++downBias, upBias :: (Integral a, Integral b) => Ratio a -> b+downBias x = round (x - 1 % (denominator x * 3))+upBias   x = round (x + 1 % (denominator x * 3))
+ src/Flavour.hs view
@@ -0,0 +1,21 @@+module Flavour where++import qualified Data.List as L+import Color++-- TODO: add more variety, as the number of items increases+type Flavour = (Color, Bool)  -- the flag tells to use fancy color names++zipPlain cs = L.zip cs (repeat False)+zipFancy cs = L.zip cs (repeat True)+darkCol    = [Red .. Cyan]+brightCol  = [BrRed .. BrCyan]  -- BrBlack is not really that bright+stdCol     = darkCol ++ brightCol+stdFlav    = zipPlain stdCol ++ zipFancy stdCol++flavourToName :: Flavour -> String+flavourToName (c, False) = colorToName c+flavourToName (c, True) = colorToName' c++flavourToColor :: Flavour -> Color+flavourToColor (c, _) = c
src/Geometry.hs view
@@ -1,8 +1,14 @@ module Geometry where +import Data.List as L+ -- | Game time in turns. (Placement in module Geometry is not ideal.) type Time = Int +-- | Vertical directions.+data VDir = Up | Down+  deriving (Eq, Show, Enum, Bounded)+ type X = Int type Y = Int @@ -51,9 +57,9 @@ neg :: Dir -> Dir neg (y,x) = (-y,-x) --- | Get the vectors of all the moves.+-- | Get the vectors of all the moves, clockwise, starting north-west. moves :: [Dir]-moves = [ (x,y) | x <- [-1..1], y <- [-1..1], x /= 0 || y /= 0 ]+moves = [(-1,-1), (-1,0), (-1,1), (0,1), (1,1), (1,0), (1,-1), (0,-1)]  up, down, left, right :: Dir upleft, upright, downleft, downright :: Dir@@ -69,3 +75,42 @@ horiz, vert :: [Dir] horiz = [left, right] vert  = [up, down]++neighbors :: Area ->        {- size limitation -}+             Loc ->         {- location to find neighbors of -}+             [Loc]+neighbors area (y,x) =+  let cs = [ (y + dy, x + dx)+           | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ]+  in  L.filter (`inside` area) cs++inside :: Loc -> Area -> Bool+inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0++fromTo :: Loc -> Loc -> [Loc]+fromTo (y0,x0) (y1,x1)+  | y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1)+  | x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1)++fromTo1 :: X -> X -> [X]+fromTo1 x0 x1+  | x0 <= x1  = [x0..x1]+  | otherwise = [x0,x0-1..x1]++normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))+normalize (a,b) | a <= b    = (a,b)+                | otherwise = (b,a)++normalizeArea :: Area -> Area+normalizeArea a@((y0,x0),(y1,x1)) =+  ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))++grid :: (Y,X) -> Area -> [((Y,X), Area)]+grid (ny,nx) ((y0,x0),(y1,x1)) =+  let yd = y1 - y0+      xd = x1 - x0+  in [ ((y, x), ((y0 + (yd * y `div` ny),+                  x0 + (xd * x `div` nx)),+                 (y0 + (yd * (y + 1) `div` ny - 1),+                  x0 + (xd * (x + 1) `div` nx - 1))))+     | x <- [0..nx-1], y <- [0..ny-1] ]
+ src/GeometryRnd.hs view
@@ -0,0 +1,58 @@+module GeometryRnd where++import Data.List as L+import Data.Set as S++import Geometry+import Random++findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc+findLocInArea a@((y0, x0), (y1, x1)) p = do+  rx <- randomR (x0, x1)+  ry <- randomR (y0, y1)+  let loc = (ry, rx)+  if p loc then return loc else findLocInArea a p++locInArea :: Area -> Rnd Loc+locInArea a = findLocInArea a (const True)++connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X), (Y,X))] ->+                Rnd [((Y,X), (Y,X))]+connectGrid' (ny, nx) unconnected candidates acc+  | S.null candidates = return (L.map normalize acc)+  | otherwise = do+      c <- oneOf (S.toList candidates)+      -- potential new candidates:+      let ns = S.fromList $ neighbors ((0,0),(ny-1,nx-1)) c+          nu = S.delete c unconnected  -- new unconnected+          -- (new candidates, potential connections):+          (nc, ds) = S.partition (`S.member` nu) ns+      new <- if S.null ds+             then return id+             else do+                    d <- oneOf (S.toList ds)+                    return ((c,d) :)+      connectGrid' (ny,nx) nu (S.delete c (candidates `S.union` nc)) (new acc)++connectGrid :: (Y,X) -> Rnd [((Y,X), (Y,X))]+connectGrid (ny, nx) = do+  let unconnected = S.fromList [ (y, x) | x <- [0..nx-1], y <- [0..ny-1] ]+  -- candidates are neighbors that are still unconnected; we start with+  -- a random choice+  rx <- randomR (0, nx-1)+  ry <- randomR (0, ny-1)+  let candidates  = S.fromList [ (ry, rx) ]+  connectGrid' (ny, nx) unconnected candidates []++randomConnection :: (Y,X) -> Rnd ((Y,X), (Y,X))+randomConnection (ny, nx) = do+  rb  <- randomR (False, True)+  if rb+    then do+           rx  <- randomR (0, nx-2)+           ry  <- randomR (0, ny-1)+           return (normalize ((ry, rx), (ry, rx+1)))+    else do+           ry  <- randomR (0, ny-2)+           rx  <- randomR (0, nx-1)+           return (normalize ((ry, rx), (ry+1, rx)))
src/Grammar.hs view
@@ -1,56 +1,84 @@ module Grammar where  import Data.Char+import Data.Set as S+import Data.List as L+import qualified Data.IntMap as IM  import Item-import Monster+import Actor+import ActorKind import State-import ItemState+import ItemKind+import Effect+import Flavour --- | How to refer to a monster in object position of a sentence.-objectMonster :: MonsterType -> String-objectMonster Player  = "you"-objectMonster Eye     = "the reducible eye"-objectMonster FastEye = "the super-fast eye"-objectMonster Nose    = "the point-free nose"+suffixS :: String -> String+suffixS word = case last word of+                'y' -> init word ++ "ies"+                's' -> word ++ "es"+                'x' -> word ++ "es"+                _   -> word ++ "s" --- | How to refer to a monster in subject position of a sentence.-subjectMonster :: MonsterType -> String-subjectMonster x = let (s:r) = objectMonster x in toUpper s : r+capitalize :: String -> String+capitalize [] = []+capitalize (c : cs) = toUpper c : cs -verbMonster :: MonsterType -> String -> String-verbMonster Player v = v-verbMonster _      v = v ++ "s"+-- | How to refer to an actor in object position of a sentence.+objectActor :: ActorKind -> String+objectActor mk = bname mk -compoundVerbMonster :: MonsterType -> String -> String -> String-compoundVerbMonster Player v p = v ++ " " ++ p-compoundVerbMonster _      v p = v ++ "s " ++ p+-- | How to refer to an actor in subject position of a sentence.+subjectActor :: ActorKind -> String+subjectActor x = capitalize $ objectActor x -objectItem :: State -> Int -> ItemType -> String-objectItem _ n Ring       = makeObject n id "ring"-objectItem _ n Scroll     = makeObject n id "scroll"-objectItem s n (Potion t) = makeObject n (identified (sassocs s) (sdiscoveries s) (Potion t)) "potion"-objectItem _ n Wand       = makeObject n id "wand"-objectItem _ n Amulet     = makeObject n id "amulet"-objectItem _ n Gem        = makeObject n id "gem"-objectItem _ n Gold       = makeObject n id "gold piece"-objectItem _ n (Sword i)  = makeObject n id ("(+" ++ show i ++ ") sword")+verbActor :: ActorKind -> String -> String+verbActor mk v = if bname mk == "you" then v else suffixS v -subjectVerbIObject :: State -> Monster -> String -> Item -> String -> String+-- | Sentences such like "The dog barks".+subjectActorVerb :: ActorKind -> String -> String+subjectActorVerb x v = subjectActor x ++ " " ++ verbActor x v++compoundVerbActor :: ActorKind -> String -> String -> String+compoundVerbActor m v p = verbActor m v ++ " " ++ p++subjectVerbIObject :: State -> Actor -> String -> Item -> String -> String subjectVerbIObject state m v o add =-  subjectMonster (mtype m) ++ " " ++-  verbMonster (mtype m) v ++ " " ++-  objectItem state (icount o) (itype o) ++ add ++ "."+  subjectActor (akind m) ++ " " +++  verbActor (akind m) v ++ " " +++  objectItem state o ++ add ++ "." -subjectVerbMObject :: State -> Monster -> String -> Monster -> String -> String-subjectVerbMObject state m v o add =-  subjectMonster (mtype m) ++ " " ++-  verbMonster (mtype m) v ++ " " ++-  objectMonster (mtype o) ++ add ++ "."+subjectVerbMObject :: Actor -> String -> Actor -> String -> String+subjectVerbMObject m v o add =+  subjectActor (akind m) ++ " " +++  verbActor (akind m) v ++ " " +++  objectActor (akind o) ++ add ++ "." -subjectCompoundVerbIObject :: State -> Monster -> String -> String ->-                             Item -> String -> String-subjectCompoundVerbIObject state m v p o add =-  subjectMonster (mtype m) ++ " " ++-  compoundVerbMonster (mtype m) v p ++ " " ++-  objectItem state (icount o) (itype o) ++ add ++ "."+subjCompoundVerbIObj :: State -> Actor -> String -> String ->+                        Item -> String -> String+subjCompoundVerbIObj state m v p o add =+  subjectActor (akind m) ++ " " +++  compoundVerbActor (akind m) v p ++ " " +++  objectItem state o ++ add ++ "."++makeObject :: Int -> (String -> String) -> String -> String+makeObject 1 adj obj = let b = adj obj+                       in  case b of+                             (c:_) | c `elem` "aeio" -> "an " ++ b+                             _                       -> "a " ++ b+makeObject n adj obj = show n ++ " " ++ adj (suffixS obj)++objectItem :: State -> Item -> String+objectItem state o =+  let ik = ikind o+      kind = ItemKind.getIK ik+      identified = L.length (jflavour kind) == 1 ||+                   ik `S.member` sdiscoveries state+      addSpace s = if s == "" then "" else " " ++ s+      eff = effectToName (jeffect kind)+      pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")"+      adj name = if identified+                 then name ++ addSpace eff ++ addSpace pwr+                 else let flavour = getFlavour (sassocs state) ik+                      in  flavourToName flavour ++ " " ++ name+  in  makeObject (icount o) adj (jname kind)
src/HighScores.hs view
@@ -2,6 +2,7 @@  import System.Directory import Control.Exception as E hiding (handle)+import Control.Monad import Text.Printf import System.Time @@ -11,10 +12,11 @@  import File import Dungeon+import Level import qualified Config  -- | A single score.--- TODO: add hero's name, exp and level, cause of death, user number/name.+-- 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).@@ -23,11 +25,12 @@                      { points  :: Int,                        negTurn :: Int,                        date    :: ClockTime,-                       current :: Int,-                       killed  :: Bool,-                       victor  :: Bool}+                       status  :: Status}   deriving (Eq, Ord) +data Status = Killed LevelName | Camping LevelName | Victor+  deriving (Eq, Ord)+ instance Binary ClockTime where   put (TOD s p) =     do@@ -39,40 +42,48 @@       p <- get       return (TOD s p) +instance Binary Status where+  put (Killed ln)  = putWord8 0 >> put ln+  put (Camping ln) = putWord8 1 >> put ln+  put Victor       = putWord8 2+  get = do+          tag <- getWord8+          case tag of+            0 -> liftM Killed  get+            1 -> liftM Camping get+            2 -> return Victor+ instance Binary ScoreRecord where-  put (ScoreRecord points negTurn date current killed victor) =+  put (ScoreRecord points negTurn date status) =     do       put points       put negTurn       put date-      put current-      put killed-      put victor+      put status   get =     do       points <- get       negTurn <- get       date <- get-      current <- get-      killed <- get-      victor <- get-      return (ScoreRecord points negTurn date current killed victor)+      status <- get+      return (ScoreRecord points negTurn date status)  -- | Show a single high score. showScore :: (Int, ScoreRecord) -> String showScore (pos, score) =-  let won  = if victor score-             then "emerged victorious"-             else "is camping on level " ++ show (current score) ++ ","-      died = if killed score-             then "perished on level " ++ show (current score) ++ ","-             else won-      time = calendarTimeToString . toUTCTime . date $ score-      big  = "                                                 "-      lil  = "              "+  let died  =+        case status score of+          Killed (LambdaCave n)  -> "perished on level " ++ show n ++ ","+          Camping (LambdaCave n) -> "is camping on level " ++ show n ++ ","+          Victor     -> "emerged victorious"+      time  = calendarTimeToString . toUTCTime . date $ score+      big   = "                                                 "+      lil   = "              "+      steps = negTurn score `div` (-10)   in-   printf "%s\n%4d. %6d  This hero %s after %d steps  \n%son %s.  \n"-     big pos (points score) died (- (negTurn score)) lil time+   printf+     "%s\n%4d. %6d  This adventuring party %s after %d steps  \n%son %s.  \n"+     big pos (points score) died steps lil time  -- | The list of scores, in decreasing order. type ScoreTable = [ScoreRecord]@@ -83,7 +94,7 @@  -- | Name of the high scores file. file :: Config.CP -> IO String-file config = Config.getFile config "LambdaHack.scores" "files" "highscores"+file config = Config.getFile config "files" "highScores"  -- | We save a simple serialized version of the high scores table. -- The 'False' is used only as an EOF marker.@@ -136,12 +147,14 @@         (lines, _) = normalLevelSize         height = lines `div` 3         (msgCurrent, msgUnless) =-          if killed s-          then (" short-lived", " (score halved)")-          else if victor s-               then (" glorious",-                     if pos <= height then " among the greatest heroes" else "")-               else (" current", " (unless you are slain)")-        msg = printf "Your%s exploits award you place >> %d <<%s." msgCurrent pos 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     if write then save config h' else return ()     return (msg, slideshow pos h' height)
src/Item.hs view
@@ -1,146 +1,84 @@ module Item where  import Data.Binary-import Data.Map as M import Data.Set as S import Data.List as L+import qualified Data.IntMap as IM+import qualified Data.Map as M import Data.Maybe import Data.Char import Data.Function import Control.Monad -import Display-import Geometry import Random+import ItemKind+import qualified Color+import Flavour  data Item = Item-             { icount  :: Int,-               itype   :: ItemType,-               iletter :: Maybe Char }  -- inventory identifier+  { ikind    :: !ItemKindId,+    ipower   :: !Int,  -- TODO: see the TODO about jpower+    iletter  :: Maybe Char,  -- ^ inventory identifier+    icount   :: !Int }   deriving Show -data ItemType =-   Ring- | Scroll- | Potion PotionType- | Wand- | Amulet- | Gem- | Gold- | Sword Int- deriving (Eq, Ord, Show)--data PotionType =-   PotionWater- | PotionHealing- deriving (Eq, Ord, Show)--data Appearance =-   Clear- | White- deriving (Eq, Show)--type Assocs = M.Map ItemType Appearance-type Discoveries = S.Set ItemType--equalItemType :: Item -> Item -> Bool-equalItemType = (==) `on` itype--equalItemLetter :: Item -> Item -> Bool-equalItemLetter = (==) `on` iletter--potionType :: PotionType -> String -> String-potionType PotionWater   s = s ++ " of water"-potionType PotionHealing s = s ++ " of healing"--appearance :: Appearance -> String -> String-appearance Clear s = "clear " ++ s-appearance White s = "white " ++ s- instance Binary Item where-  put (Item icount itype iletter) = put icount >> put itype >> put iletter-  get = liftM3 Item get get get+  put (Item ikind ipower iletter icount ) =+    put ikind >> put ipower >> put iletter >> put icount+  get = liftM4 Item get get get get -instance Binary ItemType where-  put Ring       = putWord8 0-  put Scroll     = putWord8 1-  put (Potion t) = putWord8 2 >> put t-  put Wand       = putWord8 3-  put Amulet     = putWord8 4-  put Gem        = putWord8 5-  put Gold       = putWord8 6-  put (Sword i)  = putWord8 7 >> put i-  get = do-          tag <- getWord8-          case tag of-            0 -> return Ring-            1 -> return Scroll-            2 -> liftM Potion get-            3 -> return Wand-            4 -> return Amulet-            5 -> return Gem-            6 -> return Gold-            7 -> liftM Sword get+type Assocs = M.Map ItemKindId Flavour  -- TODO: rewrite and move elsewhere -instance Binary PotionType where-  put PotionWater   = putWord8 0-  put PotionHealing = putWord8 1-  get = do-          tag <- getWord8-          case tag of-            0 -> return PotionWater-            1 -> return PotionHealing+type Discoveries = S.Set ItemKindId -instance Binary Appearance where-  put Clear = putWord8 0-  put White = putWord8 1-  get = do-          tag <- getWord8-          case tag of-            0 -> return Clear-            1 -> return White+-- | Assinges flavours to item kinds. Assures no flavor is repeated,+-- except for items with only one permitted flavour.+rollAssocs :: ItemKindId -> [Flavour] ->+              Rnd (Assocs, S.Set Flavour) ->+              Rnd (Assocs, S.Set Flavour)+rollAssocs key flavours rnd =+  if L.length flavours == 1+  then rnd+  else do+    (assocs, available) <- rnd+    let proper = S.fromList flavours `S.intersection` available+    flavour <- oneOf (S.toList proper)+    return (M.insert key flavour assocs, S.delete flavour available) -itemFrequency :: Frequency ItemType-itemFrequency =-  Frequency-  [-    (100, Gold),-    (70,  Sword (-1)),-    (30,  Gem),-    (20,  Ring),-    (30,  Scroll),-    (10,  Wand),-    (10,  Amulet),-    (30,  Potion PotionWater),-    (20,  Potion PotionHealing)-  ]+-- | Randomly chooses flavour for all item kinds for this game.+dungeonAssocs :: Rnd Assocs+dungeonAssocs =+  liftM fst $+  M.foldWithKey rollAssocs (return (M.empty, S.fromList stdFlav)) itemFlavours -itemQuantity :: Int -> ItemType -> Rnd Int-itemQuantity n Gold = (2 * n) *~ d 8-itemQuantity _ _    = return 1+getFlavour :: Assocs -> ItemKindId -> Flavour+getFlavour assocs ik =+  let kind = ItemKind.getIK ik+  in  case jflavour kind of+        []  -> error "getFlavour"+        [f] -> f+        _:_ -> assocs M.! ik -itemStrength :: Int -> ItemType -> Rnd ItemType-itemStrength n (Sword _) =-  do-    r <- d (2 + n `div` 2)-    return $ Sword $ (n + 1) `div` 3 + r-itemStrength _ tp        = return tp+viewItem :: ItemKindId -> Assocs -> (Char, Color.Color)+viewItem ik assocs = (jsymbol (getIK ik), flavourToColor $ getFlavour assocs ik) -itemLetter :: ItemType -> Maybe Char-itemLetter Gold = Just '$'-itemLetter _    = Nothing+itemLetter :: ItemKind -> Maybe Char+itemLetter ik = if jsymbol ik == '$' then Just '$' else Nothing  -- | Generate an item.-newItem :: Int -> Frequency ItemType -> Rnd Item-newItem n ftp =-  do-    tp <- frequency ftp-    item <- itemStrength n tp-    nr <- itemQuantity n tp-    return (Item nr item (itemLetter tp))+newItem :: Int -> Rnd Item+newItem lvl = do+  ikChosen <- frequency itemFrequency+  let kind = getIK ikChosen+  count <- rollQuad lvl (jcount kind)+  if count == 0+    then newItem lvl  -- Rare item; beware of inifite loops.+    else do+      power <- rollQuad lvl (jpower kind)+      return $ Item ikChosen power (itemLetter kind) count  -- | Assigns a letter to an item, for inclusion--- in the inventory of the player. Takes a remembered+-- in the inventory of a hero. Takes a remembered -- letter and a starting letter. assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char assignLetter r c is =@@ -150,7 +88,9 @@   where     current    = S.fromList (concatMap (maybeToList . iletter) is)     allLetters = ['a'..'z'] ++ ['A'..'Z']-    candidates = take (length allLetters) (drop (fromJust (L.findIndex (==c) allLetters)) (cycle allLetters))+    candidates = take (length allLetters) $+                   drop (fromJust (L.findIndex (==c) allLetters)) $+                     cycle allLetters     free       = L.filter (\x -> not (x `S.member` current)) candidates     allowed    = '$' : free @@ -178,13 +118,12 @@   where     succLetter c d = ord d - ord c == 1 -    sectionBy []     Nothing                  = ""-    sectionBy []     (Just (c,d))             = finish (c,d)-    sectionBy (x:xs) Nothing                  = sectionBy xs (Just (x,x))-    sectionBy (x:xs) (Just (c,d)) | succLetter d x-                                              = sectionBy xs (Just (c,x))-                                  | otherwise-                                              = finish (c,d) ++ sectionBy xs (Just (x,x))+    sectionBy []     Nothing      = ""+    sectionBy []     (Just (c,d)) = finish (c,d)+    sectionBy (x:xs) Nothing      = sectionBy xs (Just (x,x))+    sectionBy (x:xs) (Just (c,d))+      | succLetter d x            = sectionBy xs (Just (c,x))+      | otherwise                 = finish (c,d) ++ sectionBy xs (Just (x,x))      finish (c,d) | c == d         = [c]                  | succLetter c d = [c,d]@@ -194,32 +133,20 @@ letterLabel Nothing  = "    " letterLabel (Just c) = c : " - " -viewItem :: ItemType -> Assocs -> (Char, Attr -> Attr)-viewItem i a = viewItem' i (M.lookup i a)-  where-    viewItem' (Sword {})  _            = (')', id)-    viewItem' Ring        _            = ('=', id)-    viewItem' Scroll      _            = ('?', id)-    viewItem' (Potion {}) (Just Clear) = ('!', setBold . setFG blue)-    viewItem' (Potion {}) (Just White) = ('!', setBold . setFG white)-    viewItem' (Potion {}) _            = ('!', id)-    viewItem' Wand        _            = ('/', id)-    viewItem' Gold        _            = ('$', setBold . setFG yellow)-    viewItem' Gem         _            = ('*', setFG red)-    viewItem' Amulet      _            = ('"', id)-    viewItem' _           _            = ('~', id)- -- | Adds an item to a list of items, joining equal items. -- Also returns the joined item.-joinItem :: Item -> [Item] -> (Item,[Item])-joinItem i is = case findItem (equalItemType i) is of-                  Nothing     -> (i, i : is)-                  Just (j,js) -> let n = i { icount = icount i + icount j,-                                             iletter = mergeLetter (iletter j) (iletter i) }-                                 in (n, n : js)+-- TODO: the resulting list can contain items with the same letter.+-- TODO: name [Item] Inventory and have some invariants, e.g. no equal letters.+joinItem :: Item -> [Item] -> (Item, [Item])+joinItem i is =+  case findItem (equalItemIdentity i) is of+    Nothing     -> (i, i : is)+    Just (j,js) -> let n = i { icount = icount i + icount j,+                               iletter = mergeLetter (iletter j) (iletter i) }+                   in (n, n : js) --- | Removes an item from a list of items. Takes an equality function (i.e., by letter or--- by type) as an argument.+-- | Removes an item from a list of items.+-- Takes an equality function (i.e., by letter or ny kind) as an argument. removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item] removeItemBy eq i = concatMap $ \ x ->                     if eq i x@@ -229,8 +156,15 @@                                  else []                       else [x] +equalItemIdentity :: Item -> Item -> Bool+equalItemIdentity i1 i2 = ipower i1 == ipower i2 && ikind i1 == ikind i2++removeItemByIdentity = removeItemBy equalItemIdentity++equalItemLetter :: Item -> Item -> Bool+equalItemLetter = (==) `on` iletter+ removeItemByLetter = removeItemBy equalItemLetter-removeItemByType   = removeItemBy equalItemType  -- | Finds an item in a list of items. findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])@@ -241,15 +175,17 @@       | p i              = Just (i, reverse acc ++ is)       | otherwise        = findItem' (i:acc) is -strongestSword :: [Item] -> Int-strongestSword l =-  let aux acc (Item { itype = Sword i }) = max acc i-      aux acc _ = acc-  in  foldl aux 0 l+strongestItem :: [Item] -> String -> Maybe Item+strongestItem is groupName =+  let cmp = compare `on` ipower+      igs = L.filter (\ i -> jname (getIK (ikind i)) == groupName) is+  in  case igs of+        [] -> Nothing+        _  -> Just $ L.maximumBy cmp igs -makeObject :: Int -> (String -> String) -> String -> String-makeObject 1 adj obj = let b = adj obj-                       in  case b of-                             (c:_) | c `elem` "aeio" -> "an " ++ b-                             _                       -> "a " ++ b-makeObject n adj obj = show n ++ " " ++ adj (obj ++ "s")+itemPrice :: Item -> Int+itemPrice i =+  case jname (getIK (ikind i)) of+    "gold piece" -> icount i+    "gem" -> 100+    _ -> 0
+ src/ItemAction.hs view
@@ -0,0 +1,326 @@+module ItemAction where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Function+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Set as S+import System.Time++import Action+import Display hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified ItemKind+import qualified Keys as K+import Level+import LevelState+import Message+import Actor+import ActorState+import ActorKind+import ActorAdd+import Perception+import Random+import State+import qualified Config+import qualified Save+import Terrain+import qualified Effect+import EffectAction++-- Item UI code with the Action type and everything it depends on+-- that is not already in Action.hs and EffectAction.hs.+-- This file should not depend on Action.hs.++-- | Display inventory+inventory :: Action a+inventory = do+  items <- gets (aitems . getPlayerBody)+  if L.null items+    then abortWith "Not carrying anything."+    else do+           displayItems "Carrying:" True items+           session getConfirm+           abortWith ""++-- | Let the player choose any item with a given group name.+-- Note that this does not guarantee an item from the group to be chosen,+-- as the player can override the choice.+-- TODO: There should be a datatype for item groups instead of strings+-- or perhaps the functionality should be implemented differently,+-- e.g., based on equipment slot, as soon as it's specified for item kinds.+getGroupItem :: [Item] ->  -- all objects in question+                String ->  -- name of the group+                String ->  -- prompt+                String ->  -- how to refer to the collection of objects+                Action (Maybe Item)+getGroupItem is groupName prompt packName =+  let choice i = groupName == ItemKind.jname (ItemKind.getIK (ikind i))+      header = capitalize $ suffixS groupName+  in  getItem prompt choice header is packName++applyGroupItem :: ActorId ->  -- actor applying the item; on current level+                  String ->   -- how the "applying" is called+                  Item ->     -- the item to be applied+                  Action ()+applyGroupItem actor verb item = do+  state <- get+  body  <- gets (getActor actor)+  per   <- currentPerception+  -- only one item consumed, even if several in inventory+  let consumed = item { icount = 1 }+      msg = subjectVerbIObject state body verb consumed ""+      loc = aloc body+  removeFromInventory actor consumed loc+  when (loc `S.member` ptvisible per) $ messageAdd msg+  itemEffectAction 5 actor actor consumed+  advanceTime actor++playerApplyGroupItem :: String -> Action ()+playerApplyGroupItem groupName = do+  is   <- gets (aitems . getPlayerBody)+  iOpt <- getGroupItem is groupName+            ("What to " ++ applyToVerb groupName ++ "?") "in inventory"+  pl   <- gets splayer+  case iOpt of+    Just i  ->+      let verb = applyToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))+      in  applyGroupItem pl verb i+    Nothing -> neverMind True++applyToVerb :: String -> String+applyToVerb "potion" = "quaff"+applyToVerb "scroll" = "read"+applyToVerb _ = "destructively apply"++quaffPotion :: Action ()+quaffPotion = playerApplyGroupItem "potion"++readScroll :: Action ()+readScroll = playerApplyGroupItem "scroll"++zapGroupItem :: ActorId ->  -- actor zapping the item; on current level+                Loc ->      -- target location for the zapping+                String ->   -- how the "zapping" is called+                Item ->     -- the item to be zapped+                Action ()+zapGroupItem source loc verb item = do+  state <- get+  sm    <- gets (getActor source)+  per   <- currentPerception+  let consumed = item { icount = 1 }+      sloc = aloc sm+      subject = if sloc `S.member` ptvisible per+                then sm+                else template (hero {bname = "somebody"}) 99 sloc+      msg = subjectVerbIObject state subject verb consumed ""+  removeFromInventory source consumed sloc+  case locToActor loc state of+    Just ta -> do+      -- The message describes the source part of the action.+      when (sloc `S.member` ptvisible per || isAHero ta) $ messageAdd msg+      -- Messages inside itemEffectAction describe the target part.+      b <- itemEffectAction 10 source ta consumed+      when (not b) $+        modify (updateLevel (dropItemsAt [consumed] loc))+    Nothing -> do+      when (sloc `S.member` ptvisible per) $ messageAdd msg+      modify (updateLevel (dropItemsAt [consumed] loc))+  advanceTime source++playerZapGroupItem :: String -> Action ()+playerZapGroupItem groupName = do+  state <- get+  is    <- gets (aitems . getPlayerBody)+  iOpt  <- getGroupItem is groupName+             ("What to " ++ zapToVerb groupName ++ "?") "in inventory"+  pl    <- gets splayer+  per   <- currentPerception+  case iOpt of+    Just i  ->+      case targetToLoc (ptvisible per) state of+        Nothing  -> abortWith "target invalid"+        Just loc ->+          -- TODO: draw digital line and see if obstacles prevent firing+          if actorReachesLoc pl loc per (Just pl)+          then let verb = zapToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))+               in  zapGroupItem pl loc verb i+          else abortWith "target not reachable"+    Nothing -> neverMind True++zapToVerb :: String -> String+zapToVerb "wand" = "aim"+zapToVerb "dart" = "throw"+zapToVerb _ = "furiously zap"++aimItem :: Action ()+aimItem = playerZapGroupItem "wand"++throwItem :: Action ()+throwItem = playerZapGroupItem "dart"++-- | Drop a single item.+-- TODO: allow dropping a given number of identical items.+dropItem :: Action ()+dropItem = do+  pl    <- gets splayer+  state <- get+  pbody <- gets getPlayerBody+  ploc  <- gets (aloc . getPlayerBody)+  items <- gets (aitems . getPlayerBody)+  iOpt  <- getAnyItem "What to drop?" items "inventory"+  case iOpt of+    Just stack -> do+      let i = stack { icount = 1 }+      removeOnlyFromInventory pl i (aloc pbody)+      messageAdd (subjectVerbIObject state pbody "drop" i "")+      modify (updateLevel (dropItemsAt [i] ploc))+    Nothing -> neverMind True+  playerAdvanceTime++-- TODO: this is a hack for dropItem, because removeFromInventory+-- makes it impossible to drop items if the floor not empty.+removeOnlyFromInventory :: ActorId -> Item -> Loc -> Action ()+removeOnlyFromInventory actor i loc = do+  updateAnyActor actor (\ m -> m { aitems = removeItemByLetter i (aitems m) })++-- | Remove given item from an actor's inventory or floor.+-- TODO: this is subtly wrong: if identical items are on the floor and in+-- inventory, the floor one will be chosen, regardless of player intention.+-- TODO: right now it ugly hacks (with the ploc) around removing items+-- of dead heros/monsters. The subtle incorrectness helps here a lot,+-- because items of dead heroes land on the floor, so we use them up+-- in inventory, but remove them after use from the floor.+removeFromInventory :: ActorId -> Item -> Loc -> Action ()+removeFromInventory actor i loc = do+  b <- removeFromLoc i loc+  when (not b) $+    updateAnyActor actor (\ m -> m { aitems = removeItemByLetter i (aitems m) })++-- | Remove given item from the given location. Tell if successful.+removeFromLoc :: Item -> Loc -> Action Bool+removeFromLoc i loc = do+  lmap  <- gets (lmap . slevel)+  if not $ L.any (equalItemIdentity i) (titems (lmap `at` loc))+    then return False+    else+      modify (updateLevel (updateLMap adj)) >>+      return True+        where+          adj = M.adjust (\ (t, rt) -> (remove t, rt)) loc+          remove t = t { titems = removeItemByIdentity i (titems t) }++actorPickupItem :: ActorId -> Action ()+actorPickupItem actor = do+  state <- get+  pl    <- gets splayer+  per   <- currentPerception+  lmap  <- gets (lmap . slevel)+  body  <- gets (getActor actor)+  let loc       = aloc body+      t         = lmap `at` loc -- the map tile in question+      perceived = loc `S.member` ptvisible per+      isPlayer  = actor == pl+  -- check if something is here to pick up+  case titems t of+    []   -> abortIfWith isPlayer "nothing here"+    i:rs -> -- pick up first item; TODO: let player select item;not for monsters+      case assignLetter (iletter i) (aletter body) (aitems body) of+        Just l -> do+          let (ni, nitems) = joinItem (i { iletter = Just l }) (aitems body)+          -- message depends on who picks up and if a hero can perceive it+          if isPlayer+            then messageAdd (letterLabel (iletter ni) ++ objectItem state ni)+            else when perceived $+                   messageAdd $ subjCompoundVerbIObj state body "pick" "up" i ""+          assertTrue $ removeFromLoc i loc+          -- add item to actor's inventory:+          updateAnyActor actor $ \ m ->+            m { aitems = nitems, aletter = maxLetter l (aletter body) }+        Nothing -> abortIfWith isPlayer "cannot carry any more"+  advanceTime actor++pickupItem :: Action ()+pickupItem = do+  pl <- gets splayer+  actorPickupItem pl++-- TODO: I think that player handlers should be wrappers+-- around more general actor handlers, but+-- the actor handlers should be performing+-- specific actions, i.e., already specify the item to be+-- picked up. It doesn't make sense to invoke dialogues+-- for arbitrary actors, and most likely the+-- decision for a monster is based on perceiving+-- a particular item to be present, so it's already+-- known. In actor handlers we should make sure+-- that messages are printed to the player only if the+-- hero can perceive the action.+-- Perhaps this means half of this code should be split and moved+-- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed.++-- | Let the player choose any item from a list of items.+-- TODO: you can drop an item on the floor, which works correctly,+-- but is weird and useless.+getAnyItem :: String ->  -- prompt+              [Item] ->  -- all objects in question+              String ->  -- how to refer to the collection of objects+              Action (Maybe Item)+getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn++-- | Let the player choose a single item from a list of items.+getItem :: String ->              -- prompt message+           (Item -> Bool) ->      -- which items to consider suitable+           String ->              -- how to describe suitable objects+           [Item] ->              -- all objects in question+           String ->              -- how to refer to the collection of objects+           Action (Maybe Item)+getItem prompt p ptext is0 isn = do+  lmap  <- gets (lmap . slevel)+  body  <- gets getPlayerBody+  let loc       = aloc body+      t         = lmap `at` loc -- the map tile in question+      tis       = titems t+      floorMsg  = if L.null tis then "" else " -,"+      is = L.filter p is0+      choice = if L.null is+               then "[*," ++ floorMsg ++ " ESC]"+               else let r = letterRange (concatMap (maybeToList . iletter) is)+                    in  "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]"+      interact = do+        when (L.null is0 && L.null tis) $+          abortWith "Not carrying anything."+        messageReset (prompt ++ " " ++ choice)+        display+        session nextCommand >>= perform+      perform command = do+        messageClear+        case command of+          K.Char '?' -> do+            -- filter for supposedly suitable objects+            b <- displayItems (ptext ++ " " ++ isn) True is+            if b then session (getOptionalConfirm (const interact) perform)+                 else interact+          K.Char '*' -> do+            -- show all objects+            b <- displayItems ("Objects " ++ isn) True is0+            if b then session (getOptionalConfirm (const interact) perform)+                 else interact+          K.Char '-' ->+            case tis of+              []   -> return Nothing+              i:rs -> -- use first item; TODO: let player select item+                      return $ Just i+          K.Char l   ->+            return (find (\ i -> maybe False (== l) (iletter i)) is0)+          K.Return   ->  -- TODO: i should be the first displayed (except $)+            return (case is of [] -> Nothing ; i : _ -> Just i)+          _          -> return Nothing+  interact
+ src/ItemKind.hs view
@@ -0,0 +1,189 @@+module ItemKind+  (ItemKind(..), ItemKindId, getIK, itemFrequency, itemFlavours, swordKindId)+  where++import Data.Binary+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Control.Monad+import Data.Maybe++import Color+import Effect+import Random+import Flavour++-- TODO: jpower is out of place here. It doesn't make sense for all items,+-- and will mean different things for different items. Perhaps it should+-- be part of the Effect, but then we have to be careful to distinguish+-- parts of the Effect that are rolled on item creation and those rolled+-- at each use (e.g., sword magical +damage vs. sword damage dice).+-- Another thing to keep in minds is that jpower will heavily determine+-- the value of the item for shops, treasure chests, artifact set rebalancing,+-- etc., so if we make jpower complex, the value computation gets complex too.+data ItemKind = ItemKind+  { jsymbol  :: !Char      -- ^ map symbol+  , jflavour :: [Flavour]  -- ^ possible flavours+  , jname    :: String     -- ^ item group name+  , jeffect  :: Effect     -- ^ the effect when activated+  , jcount   :: RollQuad   -- ^ created in that quantify+  , jfreq    :: !Int       -- ^ created that often+  , jpower   :: RollQuad   -- ^ created with that power+  }+  deriving (Show, Eq, Ord)++newtype ItemKindId = ItemKindId Int+  deriving (Show, Eq, Ord)++instance Binary ItemKindId where+  put (ItemKindId i) = put i+  get = liftM ItemKindId get++itemAssocs :: [(Int, ItemKind)]+itemAssocs = L.zip [0..] loot++itemContent :: IM.IntMap ItemKind+itemContent = IM.fromDistinctAscList itemAssocs++getIK :: ItemKindId -> ItemKind+getIK (ItemKindId i) = itemContent IM.! i++itemFrequency :: Frequency ItemKindId+itemFrequency = Frequency [(jfreq ik, ItemKindId i) | (i, ik) <- itemAssocs]++itemFlavours :: M.Map ItemKindId [Flavour]+itemFlavours =+  M.fromDistinctAscList [(ItemKindId i, jflavour ik) | (i, ik) <- itemAssocs]++swordKindId :: ItemKindId+swordKindId = ItemKindId $ fromJust $ L.elemIndex sword loot++loot :: [ItemKind]+loot =+  [amulet,+   dart,+   gem1, gem2, gem3, gem4,+   gold,+   potion1, potion2, potion3,+   ring,+   scroll1, scroll2,+   sword,+   wand]++-- rollQuad (a, b, x, y) = a * d b + (lvl * x * d y) / 10++amulet, dart, gem, gem1, gem2, gem3, gem4, gold :: ItemKind+potion, potion1, potion2, potion3 :: ItemKind+ring, scroll, scroll1, scroll2, sword, wand :: ItemKind+amulet = ItemKind+  { jsymbol  = '"'+  , jflavour = [(BrGreen, True)]+  , jname    = "amulet"+  , jeffect  = Regneration+  , jcount   = intToQuad 1+  , jfreq    = 10+  , jpower   = (2, 1, 2, 2)+  }+dart = ItemKind+  { jsymbol  = ')'+  , jflavour = [(Yellow, False)]+  , jname    = "dart"+  , jeffect  = Wound (1, 1)+  , jcount   = (3, 3, 0, 0)+  , jfreq    = 30+  , jpower   = intToQuad 0+  }+gem = ItemKind+  { jsymbol  = '*'+  , jflavour = zipPlain brightCol  -- natural, so not fancy+  , jname    = "gem"+  , jeffect  = NoEffect+  , jcount   = intToQuad 0+  , jfreq    = 20  -- x4, but rare on shallow levels+  , jpower   = intToQuad 0+  }+gem1 = gem+  { jcount   = (1, 1, 0, 0)  -- appears on lvl 1+  }+gem2 = gem+  { jcount   = (0, 0, 2, 1)  -- appears on lvl 5, doubled on lvl 10+  }+gem3 = gem+  { jcount   = (0, 0, 1, 1)  -- appears on lvl 10+  }+gem4 = gem+  { jcount   = (0, 0, 1, 1)  -- appears on lvl 10+  }+gold = ItemKind+  { jsymbol  = '$'+  , jflavour = [(BrYellow, False)]+  , jname    = "gold piece"+  , jeffect  = NoEffect+  , jcount   = (0, 0, 10, 10)+  , jfreq    = 80+  , jpower   = intToQuad 0+  }+potion = ItemKind+  { jsymbol  = '!'+  , jflavour = zipFancy stdCol+  , jname    = "potion"+  , jeffect  = NoEffect+  , jcount   = intToQuad 1+  , jfreq    = 10+  , jpower   = intToQuad 0+  }+potion1 = potion+  { jeffect  = ApplyPerfume+  }+potion2 = potion+  { jeffect  = Heal+  , jpower   = (10, 1, 0, 0)+  }+potion3 = potion+  { jeffect  = Wound (0, 0)+  , jpower   = (10, 1, 0, 0)+  }+ring = ItemKind+  { jsymbol  = '='+  , jflavour = [(White, False)]+  , jname    = "ring"+  , jeffect  = Searching+  , jcount   = intToQuad 1+  , jfreq    = 10+  , jpower   = (1, 1, 2, 2)+  }+scroll = ItemKind+  { jsymbol  = '?'+  , jflavour = zipFancy darkCol  -- arcane and old+  , jname    = "scroll"+  , jeffect  = NoEffect+  , jcount   = intToQuad 1+  , jfreq    = 10+  , jpower   = intToQuad 0+  }+scroll1 = scroll+  { jeffect  = SummonFriend+  , jfreq    = 20+  }+scroll2 = scroll+  { jeffect  = SummonEnemy+  }+sword = ItemKind+  { jsymbol  = ')'+  , jflavour = [(BrCyan, False)]+  , jname    = "sword"+  , jeffect  = Wound (3, 1)+  , jcount   = intToQuad 1+  , jfreq    = 60+  , jpower   = (1, 2, 4, 2)+  }+wand = ItemKind+  { jsymbol  = '/'+  , jflavour = [(BrRed, True)]+  , jname    = "wand"+  , jeffect  = Dominate+  , jcount   = intToQuad 1+  , jfreq    = 10+  , jpower   = intToQuad 0+  }
− src/ItemState.hs 
@@ -1,16 +0,0 @@-module ItemState where--import Data.Set as S-import Data.Map as M--import Item-import State--identified :: Assocs -> Discoveries -> ItemType -> String -> String-identified a d i-  | i `S.member` d = case i of-                       Potion t -> potionType t-                       _        -> ("really strange " ++)-  | otherwise      = case M.lookup i a of-                       Just ap  -> appearance ap-                       _        -> ("really strange " ++)
src/Keybindings.hs view
@@ -3,11 +3,11 @@ import Control.Monad import Control.Monad.State hiding (State) import Data.Map as M+import Data.List as L  import Action import Command-import Display2-import Keys as K+import qualified Keys as K  -- | Keybindings. data Keybindings = Keybindings@@ -19,22 +19,23 @@ handleKey :: Keybindings -> K.Key -> Action () handleKey kb k =   do-    handleDirection k (caction $ kdir kb) $-      handleUDirection k (caction $ kudir kb) $+    K.handleDirection k (caction $ kdir kb) $+      K.handleUDirection k (caction $ kudir kb) $         case M.lookup k (kother kb) of           Just c  -> caction c           Nothing -> abortWith $ "unknown command (" ++ K.showKey k ++ ")" -keyHelp :: Keybindings -> String-keyHelp kb =+keyHelp :: (K.Key -> [K.Key]) -> Keybindings -> String+keyHelp aliases kb =   let-    fmt k h = replicate 15 ' ' ++ k ++ replicate ((13 - length k) `max` 1) ' ' ++-                                  h ++ replicate ((30 - length h) `max` 1) ' '-    fmts s  = replicate 15 ' ' ++ s ++ replicate ((43 - length s) `max` 1) ' '+    fmt k h = replicate 15 ' ' ++ k ++ replicate ((13 - length k) `max` 1) ' '+                               ++ h ++ replicate ((35 - length h) `max` 1) ' '+    fmts s  = replicate 15 ' ' ++ s ++ replicate ((48 - length s) `max` 1) ' '     blank   = fmt "" ""-    title   = fmt "key" "command"+    title   = fmt "keys" "command"     footer  = fmts "(See file PLAYING.markdown.)"-    rest    = [ fmt (K.showKey k) h | (k, Described h _) <- M.toAscList (kother kb) ]+    disp k  = L.concatMap show $ aliases k+    rest    = [ fmt (disp k) h+              | (k, Described h _) <- M.toAscList (kother kb) ]   in     unlines ([blank, title] ++ rest ++ [blank, footer, blank])-
src/Keys.hs view
@@ -2,10 +2,16 @@  import Prelude hiding (Left, Right) +import Geometry hiding (Up, Down)+import Data.Maybe+import Data.List as L+import Data.Map as M+ -- | Library-independent datatype to represent keys. data Key =     Esc   | Return+  | Tab   | PgUp   | PgDn   | Left@@ -15,13 +21,17 @@   | End   | Begin   | Home-  | Char Char    -- ^ a single printable character+  | KP Char        -- ^ a keypad key for a character (digits and operators)+  | Char Char      -- ^ a single printable character+  | Unknown String -- ^ an unknown key, collected to warn the user later   deriving (Ord, Eq)  showKey :: Key -> String+showKey (Char ' ') = "<space>"  -- warnings about "command ( )" look wrong showKey (Char c) = [c]-showKey Esc      = "<escape>"-showKey Return   = "<return>"+showKey Esc      = "ESC"  -- these three are common and terse abbreviations+showKey Return   = "RET"+showKey Tab      = "TAB" showKey PgUp     = "<page-up>" showKey PgDn     = "<page-down>" showKey Left     = "<left>"@@ -29,4 +39,118 @@ showKey Up       = "<up>" showKey Down     = "<down>" showKey End      = "<end>"+showKey Begin    = "<begin>" showKey Home     = "<home>"+showKey (KP c)   = "<KeyPad " ++ [c] ++ ">"+showKey (Unknown s) = s++instance Show Key where+  show = showKey++-- | Maps a keypad movement key to the canonical form.+-- Hard-coded not to bloat config files.+canonMoveKey :: Key -> Key+canonMoveKey e =+  case e of+    KP '8' -> Char 'K'+    KP '2' -> Char 'J'+    KP '4' -> Char 'H'+    KP '6' -> Char 'L'+    KP '7' -> Char 'Y'+    KP '9' -> Char 'U'+    KP '1' -> Char 'B'+    KP '3' -> Char 'N'+    KP '5' -> Char '.'+    Up     -> Char 'k'+    Down   -> Char 'j'+    Left   -> Char 'h'+    Right  -> Char 'l'+    Home   -> Char 'y'+    PgUp   -> Char 'u'+    End    -> Char 'b'+    PgDn   -> Char 'n'+    Begin  -> Char '.'+    k      -> k++-- | Configurable event handler for the direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleDirection :: Key -> (Dir -> a) -> a -> a+handleDirection e h k =+  case e of+    Char 'k' -> h up+    Char 'j' -> h down+    Char 'h' -> h left+    Char 'l' -> h right+    Char 'y' -> h upleft+    Char 'u' -> h upright+    Char 'b' -> h downleft+    Char 'n' -> h downright+    _          -> k++-- | Configurable event handler for the upper direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleUDirection :: Key -> (Dir -> a) -> a -> a+handleUDirection e h k =+  case e of+    Char 'K' -> h up+    Char 'J' -> h down+    Char 'H' -> h left+    Char 'L' -> h right+    Char 'Y' -> h upleft+    Char 'U' -> h upright+    Char 'B' -> h downleft+    Char 'N' -> h downright+    _          -> k++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the macros in the config file.+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "comma"         = Char ','+keyTranslate "space"         = Char ' '+keyTranslate "question"      = Char '?'+keyTranslate "dollar"        = Char '$'+keyTranslate "asterisk"      = Char '*'+keyTranslate "KP_Multiply"   = Char '*'+keyTranslate "slash"         = Char '/'+keyTranslate "KP_Divide"     = Char '/'+keyTranslate "underscore"    = Char '_'+keyTranslate "minus"         = Char '-'+keyTranslate "KP_Subtract"   = Char '-'+keyTranslate "Escape"        = Esc+keyTranslate "Return"        = Return+keyTranslate "Tab"           = Tab+keyTranslate "KP_Up"         = Up+keyTranslate "KP_Down"       = Down+keyTranslate "KP_Left"       = Left+keyTranslate "KP_Right"      = Right+keyTranslate "KP_Home"       = Home+keyTranslate "KP_End"        = End+keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "KP_Begin"      = Begin+keyTranslate "KP_Enter"      = Return+keyTranslate ['K','P','_',c] = KP c+keyTranslate [c]             = Char c+keyTranslate s               = Unknown s++-- | Maps a key to the canonical key for the command it denotes.+-- Takes into account the keypad and any macros from a config file.+-- Macros cannot depend on each other, but they can on canonMoveKey.+-- This has to be fully evaluated to catch errors in macro definitions early.+macroKey :: [(String, String)] -> M.Map Key Key+macroKey section =+  let trans k = case keyTranslate k of+                  Unknown s -> error $ "unknown macro key " ++ s+                  kt -> kt+      trMacro (from, to) = let fromTr = trans from+                               !toTr  = canonMoveKey $ trans to+                           in  if fromTr == toTr+                               then error $ "degenerate alias for " ++ show toTr+                               else (fromTr, toTr)+  in  M.fromList $ L.map trMacro section
− src/LambdaHack.hs 
@@ -1,79 +0,0 @@-module Main where--import System.Directory-import Control.Monad-import Data.Map as M-import Data.Maybe--import Action-import State-import Geometry-import Level-import Dungeon-import Perception-import Display2-import Random-import qualified Save-import Turn-import Item-import qualified Config--main :: IO ()-main = startup start---- | Either restore a saved game, or setup a new game.-start :: Session -> IO ()-start session =-    do-      -- check if we have a savegame-      config <- Config.config-      f <- Save.file config-      x <- doesFileExist f-      restored <- if x then do-                              displayBlankConfirm session "Restoring save game"-                              Save.restoreGame config-                       else return $ Right "Welcome to LambdaHack!"  -- new game-      case restored of-        Right msg  -> generate config session msg-        Left state -> handlerToIO session state "Welcome back to LambdaHack."-                        handle---- | Generate the dungeon for a new game, and start the game loop.-generate :: Config.CP -> Session -> String -> IO ()-generate config session msg =-  let matchGenerator n Nothing =-        if n == 3 then bigroom else-          if n == 10 then noiseroom else  -- access to stairs may be blocked-            level-      matchGenerator n (Just "bigroom")   = bigroom-      matchGenerator n (Just "noiseroom") = noiseroom-      matchGenerator n (Just s) =-        error $ "findGenerator: unknown: " ++ show n ++ ", " ++ s--      findGenerator n =-        let genName = Config.getOption config "dungeon" ("level" ++ show n)-            generator = matchGenerator n genName-        in  rndToIO $ generator (defaultLevelConfig n) (LambdaCave n)--      connect :: Maybe (Maybe DungeonLoc) ->-                 [(Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) ->-                   Level, Loc, Loc)] ->-                 [Level]-      connect au [(x,_,_)] = [x au Nothing]-      connect au ((x,_,d):ys@((_,u,_):_)) =-        let (z:zs) = connect (Just (Just (lname x',d))) ys-            x'     = x au (Just (Just (lname z,u)))-        in  x' : z : zs-  in-   do-     let depth = fromMaybe 10 $ Config.getOption config "dungeon" "depth"-     levels <- mapM findGenerator [1..depth]-     let lvls = connect (Just Nothing) levels-         (lvl,dng) = (head lvls, dungeon (tail lvls))-         -- generate item associations-         assocs = M.fromList-                    [ (Potion PotionWater,   Clear),-                      (Potion PotionHealing, White) ]-         defState = defaultState ((\ (_,x,_) -> x) (head levels)) dng lvl-         state = defState { sassocs = assocs, config = config }-     handlerToIO session state msg handle
src/Level.hs view
@@ -1,38 +1,24 @@ module Level where -import qualified System.Random as R import Control.Monad  import Data.Binary-import Data.Binary.Put-import Data.Binary.Get import Data.Map as M-import Data.Set as S import Data.List as L-import Data.Ratio-import Data.Maybe+import qualified Data.IntMap as IM  import Geometry-import Monster+import GeometryRnd+import Actor import Item import Random-import Display+import qualified Terrain  -- | Names of the dungeon levels are represented using a -- custom data structure. data LevelName = LambdaCave Int | Exit   deriving (Show, Eq, Ord) --- | Chance that a new monster is generated. Currently depends on the--- number of monsters already present, and on the level. In the future,--- the strength of the character and the strength of the monsters present--- could further influence the chance, and the chance could also affect--- which monster is generated.-monsterGenChance :: LevelName -> [Monster] -> Rnd Bool-monsterGenChance (LambdaCave n) [] = chance $ 1%25-monsterGenChance (LambdaCave n) l  = chance $ 1%((400 + (fromIntegral (L.length l) * 100) - (fromIntegral n * 50)) `max` 50)-monsterGenChance _              _  = return False- instance Binary LevelName where   put (LambdaCave n) = put n   get = liftM LambdaCave get@@ -45,38 +31,19 @@ levelNumber :: LevelName -> Int levelNumber (LambdaCave n) = n --- | The complete dungeon is a map from level names to levels.--- We usually store all but the current level in this data structure.-data Dungeon = Dungeon (M.Map LevelName Level)-  deriving Show---- | Create a dungeon from a list of levels.-dungeon :: [Level] -> Dungeon-dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))---- | Extract a level from a dungeon.-getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)-getDungeonLevel ln (Dungeon dng) = (fromJust (M.lookup ln dng), Dungeon (M.delete ln dng))---- | Put a level into a dungeon.-putDungeonLevel :: Level -> Dungeon -> Dungeon-putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)--instance Binary Dungeon where-  put (Dungeon dng) = put (M.elems dng)-  get = liftM dungeon get---- | A dungeon location is a level together with a location on--- that level.+-- | A dungeon location is a level together with a location on that level. type DungeonLoc = (LevelName, Loc) +type Party = IM.IntMap Actor+ data Level = Level-              { lname     :: LevelName,-                lsize     :: (Y,X),-                lmonsters :: [Monster],-                lsmell    :: SMap,-                lmap      :: LMap,-                lmeta     :: String }+  { lname     :: LevelName,+    lheroes   :: Party,      -- ^ all heroes on the level+    lsize     :: (Y,X),+    lmonsters :: Party,      -- ^ all monsters on the level+    lsmell    :: SMap,+    lmap      :: LMap,+    lmeta     :: String }   deriving Show  updateLMap :: (LMap -> LMap) -> Level -> Level@@ -85,13 +52,20 @@ updateSMap :: (SMap -> SMap) -> Level -> Level updateSMap f lvl = lvl { lsmell = f (lsmell lvl) } -updateMonsters :: ([Monster] -> [Monster]) -> Level -> Level+updateMonsters :: (Party -> Party) -> Level -> Level updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) } +updateHeroes :: (Party -> Party) -> Level -> Level+updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) }++emptyParty :: Party+emptyParty = IM.empty+ instance Binary Level where-  put (Level nm sz@(sy,sx) ms lsmell lmap lmeta) =+  put (Level nm hs sz@(sy,sx) ms lsmell lmap lmeta) =         do           put nm+          put hs           put sz           put ms           put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]@@ -99,6 +73,7 @@           put lmeta   get = do           nm <- get+          hs <- get           sz@(sy,sx) <- get           ms <- get           xs <- get@@ -106,13 +81,13 @@           xs <- get           let lmap   = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)           lmeta <- get-          return (Level nm sz ms lsmell lmap lmeta)+          return (Level nm hs sz ms lsmell lmap lmeta)  type LMap = Map (Y,X) (Tile,Tile) type SMap = Map (Y,X) Time  data Tile = Tile-              { tterrain :: Terrain,+              { tterrain :: Terrain.Terrain DungeonLoc,                 titems   :: [Item] }   deriving Show @@ -124,221 +99,63 @@ rememberAt l p = snd (findWithDefault (unknown, unknown) p l)  unknown :: Tile-unknown = Tile Unknown []--data Terrain = Rock-             | Opening Pos-             | Floor DL-             | Unknown-             | Corridor-             | Wall Pos-             | Stairs DL VDir (Maybe DungeonLoc)-             | Door Pos (Maybe Int)  -- Nothing: open, Just 0: closed, otherwise secret-  deriving Show--instance Binary Terrain where-  put Rock            = putWord8 0-  put (Opening p)     = putWord8 1 >> put p-  put (Floor dl)      = putWord8 2 >> put dl-  put Unknown         = putWord8 3-  put Corridor        = putWord8 4-  put (Wall p)        = putWord8 5 >> put p-  put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n-  put (Door p o)      = putWord8 7 >> put p >> put o-  get = do-          tag <- getWord8-          case tag of-            0 -> return Rock-            1 -> liftM Opening get-            2 -> liftM Floor get-            3 -> return Unknown-            4 -> return Corridor-            5 -> liftM Wall get-            6 -> liftM3 Stairs get get get-            7 -> liftM2 Door get get-            _ -> fail "no parse (Tile)"--data DL = Dark | Light-  deriving (Eq, Show, Bounded)---- | All the wall types that are possible:------     * 'UL': upper left------     * 'U': upper------     * 'UR': upper right------     * 'L': left------     * 'R': right------     * 'DL': lower left------     * 'D': lower------     * 'DR': lower right------     * 'O': lower right------ I am tempted to add even more (T-pieces and crossings),--- but currently, we don't need them.-data Pos = UL | U | UR | L | R | DL | D | DR | O-  deriving (Eq, Show, Bounded)--instance Binary Pos where-  put UL = putWord16le 0-  put U  = putWord16le 1-  put UR = putWord16le 2-  put L  = putWord16le 3-  put R  = putWord16le 4-  put DL = putWord16le 5-  put D  = putWord16le 6-  put DR = putWord16le 7-  put O  = putWord16le 8--  get = do-          tag <- getWord16le-          case tag of-            0 -> return UL-            1 -> return U-            2 -> return UR-            3 -> return L-            4 -> return R-            5 -> return DL-            6 -> return D-            7 -> return DR-            8 -> return O--data HV = Horiz | Vert-  deriving (Eq, Show, Bounded)--fromHV Horiz = True-fromHV Vert  = False--toHV True  = Horiz-toHV False = Vert--instance R.Random HV where-  randomR (a,b) g = case R.randomR (fromHV a,fromHV b) g of-                      (b,g') -> (toHV b,g')-  random g = R.randomR (minBound, maxBound) g--instance Binary HV where-  put Horiz = put True-  put Vert  = put False-  get = get >>= \ b -> if b then return Horiz else return Vert--instance Binary DL where-  put Dark  = put False-  put Light = put True-  get = get >>= \ b -> if b then return Light else return Dark--data VDir = Up | Down-  deriving (Eq, Show)--instance Binary VDir where-  put Up   = put True-  put Down = put False-  get = get >>= \ b -> if b then return Up else return Down--instance Eq Terrain where-  Rock == Rock = True-  Opening d == Opening d' = d == d'-  Floor l == Floor l' = l == l'-  Unknown == Unknown = True-  Corridor == Corridor = True-  Wall p == Wall p' = p == p'-  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'-  Door p o == Door p' o' = p == p' && o == o'-  _ == _ = False+unknown = Tile Terrain.Unknown []  -- | blocks moves and vision closed :: Tile -> Bool closed = not . open  floor :: Tile -> Bool-floor (Tile { tterrain = Floor _ }) = True-floor _                             = False+floor = Terrain.isFloor . tterrain +canBeDoor :: Tile -> Bool+canBeDoor t =+  case t of+    Tile d@(Terrain.Door hv o) _ | secret o -> True+    _ ->+      Terrain.isWall (tterrain t) ||+      Terrain.isRock (tterrain t) ||+      Terrain.isUnknown (tterrain t)+ secret :: Maybe Int -> Bool secret (Just n) | n /= 0 = True secret _ = False +isUnknown :: Tile -> Bool+isUnknown = Terrain.isUnknown . tterrain+ toOpen :: Bool -> Maybe Int toOpen True = Nothing toOpen False = Just 0 -fromDL :: DL -> Bool-fromDL Dark = False-fromDL Light = True--toDL :: Bool -> DL-toDL False = Dark-toDL True  = Light- -- | allows moves and vision open :: Tile -> Bool-open (Tile (Floor {}) _)     = True-open (Tile (Opening {}) _)   = True-open (Tile (Door _ o) _)     = isNothing o-open (Tile Corridor _)       = True-open (Tile (Stairs {}) _)    = True-open _                       = False+open = Terrain.isOpen . tterrain  -- | is lighted on its own light :: Tile -> Bool-light (Tile (Floor l) _)        = fromDL l-light (Tile (Stairs l _ _) _)   = fromDL l-light _                         = False+light = Terrain.isAlight . tterrain  -- | can be lighted by sourrounding tiles reflects :: Tile -> Bool-reflects (Tile (Opening _) _) = True-reflects (Tile (Wall _) _)    = True-reflects (Tile (Door _ _) _)  = True-reflects _                    = False+reflects = Terrain.reflects . tterrain  -- | Passive tiles reflect light from some other (usually adjacent) -- positions. This function returns the offsets from which light is -- reflected. Not all passively lighted tiles reflect from all directions. -- Walls, for instance, cannot usually be seen from the outside. passive :: Tile -> [Dir]-passive (Tile (Wall p) _)          = posToDir p-passive (Tile (Opening _) _)       = moves-passive (Tile (Door p Nothing) _)  = moves-passive (Tile (Door p (Just 0)) _) = moves-                                     -- doors can be seen from all sides-passive (Tile (Door p (Just n)) _) = posToDir p-                                     -- secret doors are like walls-passive (Tile (Stairs _ _ _) _)    = moves-passive _                          = []+passive = Terrain.passive . tterrain  -- | Perceptible is similar to passive, but describes which tiles can -- be seen from which adjacent fields in the dark. perceptible :: Tile -> [Dir]-perceptible (Tile Rock _) = []-perceptible p = case passive p of-                 [] -> moves-                 ds -> ds---- | Maps wall types to lists of expected floor positions.-posToDir :: Pos -> [Dir]-posToDir UL = [downright]-posToDir U  = [down]-posToDir UR = [downleft]-posToDir L  = [right]-posToDir R  = [left]-posToDir DL = [upright]-posToDir D  = [up]-posToDir DR = [upleft]-posToDir O  = moves+perceptible = Terrain.perceptible . tterrain --- checks for the presence of monsters (and items); it does *not* check--- if the tile is open ...-unoccupied :: [Monster] -> LMap -> Loc -> Bool-unoccupied monsters _lmap loc =-  all (\ m -> mloc m /= loc) monsters+-- Checks for the presence of actors. Does *not* check if the tile is open.+unoccupied :: [Actor] -> Loc -> Bool+unoccupied actors loc =+  all (\ body -> aloc body /= loc) actors  -- check whether one location is accessible from the other -- precondition: the two locations are next to each other@@ -352,29 +169,18 @@   in  open tgt &&       (not (diagonal dir) ||        case (tterrain src, tterrain tgt) of-         (Door {}, _)  -> False-         (_, Door {})  -> False+         (Terrain.Door {}, _)  -> False+         (_, Terrain.Door {})  -> False          _             -> True) --- check whether the location contains a door of at most secrecy level k+-- check whether the location contains a door of secrecy level lower than k openable :: Int -> LMap -> Loc -> Bool openable k lmap target =   let tgt = lmap `at` target   in  case tterrain tgt of-        Door _ (Just n) -> n <= k+        Terrain.Door _ (Just n) -> n < k         _               -> False -findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc-findLocInArea a@((y0,x0),(y1,x1)) p =-  do-    rx <- randomR (x0,x1)-    ry <- randomR (y0,y1)-    let loc = (ry,rx)-    if p loc then return loc else findLocInArea a p--locInArea :: Area -> Rnd Loc-locInArea a = findLocInArea a (const True)- findLoc :: Level -> (Loc -> Tile -> Bool) -> Rnd Loc findLoc l@(Level { lsize = sz, lmap = lm }) p =   do@@ -399,146 +205,10 @@              then findLocTry (k - 1) l p pTry              else findLoc l p -grid :: (Y,X) -> Area -> Map (Y,X) Area-grid (ny,nx) ((y0,x0),(y1,x1)) =-  let yd = y1 - y0-      xd = x1 - x0-  in M.fromList [ ((y,x), ((y0 + (yd * y `div` ny), x0 + (xd * x `div` nx)),-                           (y0 + (yd * (y + 1) `div` ny - 1), x0 + (xd * (x + 1) `div` nx - 1))))-                | x <- [0..nx-1], y <- [0..ny-1] ]---connectGrid :: (Y,X) -> Rnd [((Y,X),(Y,X))]-connectGrid (ny,nx) =-  do-    let unconnected = S.fromList [ (y,x) | x <- [0..nx-1], y <- [0..ny-1] ]-    -- candidates are neighbors that are still unconnected; we start with-    -- a random choice-    rx <- randomR (0,nx-1)-    ry <- randomR (0,ny-1)-    let candidates  = S.fromList [ (ry,rx) ]-    connectGrid' (ny,nx) unconnected candidates []--randomConnection :: (Y,X) -> Rnd ((Y,X),(Y,X))-randomConnection (ny,nx) =-  do-    rb  <- randomR (False,True)-    if rb then do-                 rx  <- randomR (0,nx-2)-                 ry  <- randomR (0,ny-1)-                 return (normalize ((ry,rx),(ry,rx+1)))-          else do-                 ry  <- randomR (0,ny-2)-                 rx  <- randomR (0,nx-1)-                 return (normalize ((ry,rx),(ry+1,rx)))--normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))-normalize (a,b) | a <= b    = (a,b)-                | otherwise = (b,a)--normalizeArea :: Area -> Area-normalizeArea a@((y0,x0),(y1,x1)) = ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))--connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X),(Y,X))] -> Rnd [((Y,X),(Y,X))]-connectGrid' (ny,nx) unconnected candidates acc-  | S.null candidates = return (L.map normalize acc)-  | otherwise = do-                  c <- oneOf (S.toList candidates)-                  let ns = neighbors ((0,0),(ny-1,nx-1)) c  -- potential new candidates-                  let nu = S.delete c unconnected  -- new unconnected-                  let (nc,ds) = S.partition (`S.member` nu) ns-                                  -- (new candidates, potential connections)-                  new <- if S.null ds then return id-                                      else do-                                             d <- oneOf (S.toList ds)-                                             return ((c,d) :)-                  connectGrid' (ny,nx) nu-                                       (S.delete c (candidates `S.union` nc)) (new acc)--neighbors :: Area ->        {- size limitation -}-             Loc ->         {- location to find neighbors of -}-             Set Loc-neighbors area (y,x) =-  let cs = [ (y + dy, x + dx) | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ]-  in  S.fromList (L.filter (`inside` area) cs)--inside :: Loc -> Area -> Bool-inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0---fromTo :: Loc -> Loc -> [Loc]-fromTo (y0,x0) (y1,x1)-  | y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1)-  | x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1)--fromTo1 :: X -> X -> [X]-fromTo1 x0 x1-  | x0 <= x1  = [x0..x1]-  | otherwise = [x0,x0-1..x1]---- | Produces a textual description for terrain, used if no objects--- are present.-lookTerrain :: Terrain -> String-lookTerrain (Floor _)          = "Floor."-lookTerrain Corridor           = "Corridor."-lookTerrain (Opening _)        = "An opening."-lookTerrain (Stairs _ Up _)    = "A staircase up."-lookTerrain (Stairs _ Down _)  = "A staircase down."-lookTerrain (Door _ Nothing)   = "An open door."-lookTerrain _                  = ""---- | The parameter "n" is the level of evolution:------ 0: final--- 1: stairs added--- 2: doors added--- 3: corridors and openings added--- 4: only rooms------ The Bool indicates whether the loc is currently visible.-viewTerrain :: Int -> Bool -> Terrain -> (Char, Attr -> Attr)-viewTerrain n b Rock              = (' ', id)-viewTerrain n b (Opening d)-  | n <= 3                        = ('.', id)-  | otherwise                     = viewTerrain 0 b (Wall d)-viewTerrain n b (Floor Light)     = ('.', id)-viewTerrain n b (Floor Dark)      = if b then ('.', id) else (' ', id)-viewTerrain n b Unknown           = (' ', id)-viewTerrain n b Corridor-  | n <= 3                        = ('#', id)-  | otherwise                     = viewTerrain 0 b Rock-viewTerrain n b (Wall p)-  | p == O                        = ('O', id)-  | p `elem` [L, R]               = ('|', id)-  | otherwise                     = ('-', id)-viewTerrain n b (Stairs _ Up _)-  | n <= 1                        = ('<', id)-  | otherwise                     = viewTerrain 0 b (Floor Dark)-viewTerrain n b (Stairs _ Down _)-  | n <= 1                        = ('>', id)-  | otherwise                     = viewTerrain 0 b (Floor Dark)-viewTerrain n b (Door d (Just 0))-  | n <= 2                        = ('+', setFG yellow)-  | otherwise                     = viewTerrain n b (Opening d)-viewTerrain n b (Door d (Just _))-  | n <= 2                        = viewTerrain n b (Wall d)  -- secret door-  | otherwise                     = viewTerrain n b (Opening d)-viewTerrain n b (Door p Nothing)-  | n <= 2                        = (if p `elem` [L, R] then '-' else '|', setFG yellow)-  | otherwise                     = viewTerrain n b (Opening p)--viewSmell :: Int -> (Char, Attr -> Attr)-viewSmell n = let k | n > 9    = '*'-                    | n < 0    = '-'-                    | otherwise = head . show $ n-              in  (k, setFG black . setBG green)---- TODO: Really scatter around, if more than one or location occupied.---       Scatter randomly or not?---       Perhaps starting in the direction opposite to the player?-scatterItems :: [Item] -> Loc -> Level -> Level-scatterItems items loc lvl@(Level { lmap = lmap }) =-  let joinItems items = foldl (\ acc i -> snd (joinItem i acc)) items+-- Actually, do not scatter items around, it's too much work for the player.+dropItemsAt :: [Item] -> Loc -> Level -> Level+dropItemsAt items loc lvl@(Level { lmap = lmap }) =+  let joinItems items = L.foldl' (\ acc i -> snd (joinItem i acc)) items       t = lmap `at` loc       nt = t { titems = joinItems items (titems t) }       ntRemember = lmap `rememberAt` loc
src/LevelState.hs view
@@ -1,33 +1,34 @@ module LevelState where -import Display+import qualified Color import Geometry import Level import State import Item-import ItemState import Grammar+import qualified Terrain -viewTile :: Bool -> Tile -> Assocs -> (Char, Attr -> Attr)-viewTile b (Tile t [])    a = viewTerrain 0 b t-viewTile b (Tile t (i:_)) a = viewItem (itype i) a+viewTile :: Bool -> Tile -> Assocs -> (Char, Color.Color)+viewTile b (Tile t [])    a = Terrain.viewTerrain 0 b t+viewTile b (Tile t (i:_)) a = Item.viewItem (ikind i) a --- | Produces a textual description of the items at a location. It's--- probably correct to use 'at' rather than 'rememberAt' at this point,--- although we could argue that 'rememberAt' reflects what the player can--- perceive more correctly ...------ The "detailed" variant is for use with an explicit look command.-lookAt :: Bool -> State -> LMap -> Loc -> String-lookAt detailed s lmap loc-  | detailed  = lookTerrain (tterrain (lmap `at` loc)) ++ " " ++ isd-  | otherwise = isd+-- | Produces a textual description of the terrain and items at an already+-- explored location. Mute for unknown locations.+-- The "detailed" variant is for use in the targeting mode.+lookAt :: Bool -> Bool -> State -> LMap -> Loc -> String -> String+lookAt detailed canSee s lmap loc msg+  | detailed  =+    Terrain.lookTerrain (tterrain (lmap `rememberAt` loc)) ++ " " ++ msg ++ isd+  | otherwise = msg ++ isd   where-    is  = titems (lmap `at` loc)+    is  = titems (lmap `rememberAt` loc)+    prefixSee = if canSee then "You see " else "You remember "+    prefixThere = if canSee+                  then "There are several objects here"+                  else "You remember several objects here"     isd = case is of             []    -> ""-            [i]   -> "You see " ++ objectItem s (icount i) (itype i) ++ "."-            [i,j] -> "You see " ++ objectItem s (icount i) (itype i) ++ " and "-                                ++ objectItem s (icount j) (itype j) ++ "."-            _     -> "There are several objects here" ++-                     if detailed then ":" else "."+            [i]   -> prefixSee ++ objectItem s i ++ "."+            [i,j] -> prefixSee ++ objectItem s i ++ " and "+                               ++ objectItem s j ++ "."+            _     -> prefixThere ++ if detailed then ":" else "."
+ src/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import System.Directory+import Data.Map as M++import Action+import State+import DungeonState+import qualified Display+import Random+import qualified Save+import Turn+import qualified Config+import ActorAdd+import Item+import qualified Keys as K++main :: IO ()+main = Display.startup start++-- | Either restore a saved game, or setup a new game.+start :: Display.InternalSession -> IO ()+start internalSession = do+  config <- Config.config+  let section = Config.getItems config "macros"+      !macros = K.macroKey section+      session = (internalSession, macros)+  -- check if we have a savegame+  f <- Save.file config+  b <- doesFileExist f+  restored <- if b+              then do+                     Display.displayBlankConfirm session "Restoring save game"+                     Save.restoreGame config+              else return $ Right "Welcome to LambdaHack!"  -- new game+  case restored of+    Right msg  -> do+      (ploc, lvl, dng) <- rndToIO $ generate config+      assocs <- rndToIO $ dungeonAssocs+      let defState = defaultState dng lvl+          state = defState { sconfig = config, sassocs = assocs }+          hstate = initialHeroes ploc state+      handlerToIO session hstate msg handle+    Left state ->+      handlerToIO session state "Welcome back to LambdaHack." handle
src/Message.hs view
@@ -20,11 +20,13 @@ splitMsg w xs   | w <= m = [xs]   -- border case, we cannot make progress   | l <= w = [xs]   -- no problem, everything fits-  | otherwise = let (pre, post) = splitAt (w - m) xs-                    (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre-                    rpost = dropWhile isSpace ppost-                in  if L.null rpost then pre : splitMsg w post-                                    else reverse rpost : splitMsg w (reverse ppre ++ post)+  | otherwise =+      let (pre, post) = splitAt (w - m) xs+          (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre+          rpost = dropWhile isSpace ppost+      in  if L.null rpost+          then pre : splitMsg w post+          else reverse rpost : splitMsg w (reverse ppre ++ post)   where     m = length more     l = length xs
− src/Monster.hs 
@@ -1,134 +0,0 @@-module Monster where--import Data.Char-import Data.Binary-import Control.Monad--import Geometry-import Display-import Item-import Random---- | Hit points of the player. TODO: Should not be hardcoded.-playerHP :: Int-playerHP = 50---- | Time the player can be traced by monsters. TODO: Make configurable.-smellTimeout :: Time-smellTimeout = 1000---- | Initial player.-defaultPlayer :: Loc -> Player-defaultPlayer ploc =-  Monster Player playerHP playerHP Nothing ploc [] 'a' 10 0--type Player = Monster--data Monster = Monster-                { mtype   :: !MonsterType,-                  mhpmax  :: !Int,-                  mhp     :: !Int,-                  mdir    :: Maybe Dir,  -- for monsters: the dir the monster last moved;-                                         -- for the player: the dir the player is running-                  mloc    :: !Loc,-                  mitems  :: [Item],     -- inventory-                  mletter :: !Char,      -- next inventory letter-                  mspeed  :: !Time,      -- speed (i.e., delay before next action)-                  mtime   :: !Time }     -- time of next action-  deriving Show--instance Binary Monster where-  put (Monster mt mhpm mhp md ml minv mletter mspeed mtime) =-    do-      put mt-      put mhpm-      put mhp-      put md-      put ml-      put minv-      put mletter-      put mspeed-      put mtime-  get = do-          mt      <- get-          mhpm    <- get-          mhp     <- get-          md      <- get-          ml      <- get-          minv    <- get-          mletter <- get-          mspeed  <- get-          mtime   <- get-          return (Monster mt mhpm mhp md ml minv mletter mspeed mtime)--data MonsterType =-    Player-  | Eye-  | FastEye-  | Nose-  deriving (Show, Eq)--instance Binary MonsterType where-  put Player  = putWord8 0-  put Eye     = putWord8 1-  put FastEye = putWord8 2-  put Nose    = putWord8 3-  get = do-          tag <- getWord8-          case tag of-            0 -> return Player-            1 -> return Eye-            2 -> return FastEye-            3 -> return Nose-            _ -> fail "no parse (MonsterType)"---- | Monster frequencies (TODO: should of course vary much more--- on local circumstances).-monsterFrequency :: Frequency MonsterType-monsterFrequency =-  Frequency-  [-    (2, Nose),-    (6, Eye),-    (1, FastEye)-  ]---- | Generate monster.-newMonster :: Loc -> Frequency MonsterType -> Rnd Monster-newMonster loc ftp =-    do-      tp <- frequency ftp-      hp <- hps tp-      let s = speed tp-      return (template tp hp loc s)-  where-    -- 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-    template tp hp loc s = Monster tp hp hp Nothing loc [] 'a' s 0--    hps Eye      = randomR (1,12)  -- falls in 1--4 unarmed rounds-    hps FastEye  = randomR (1,6)   -- 1--2-    hps Nose     = randomR (6,13)  -- 2--5 and in 1 round of the strongest sword--    speed Eye      = 10-    speed FastEye  = 4-    speed Nose     = 11---- | Insert a monster in an mtime-sorted list of monsters.--- Returns the position of the inserted monster and the new list.-insertMonster :: Monster -> [Monster] -> (Int, [Monster])-insertMonster = insertMonster' 0-  where-    insertMonster' n m []      = (n, [m])-    insertMonster' n m (m':ms)-      | mtime m <= mtime m'    = (n, m : m' : ms)-      | otherwise              = let (n', ms') = insertMonster' (n + 1) m ms-                                 in  (n', m' : ms')--viewMonster :: MonsterType -> (Char, Attr -> Attr)-viewMonster Player  = ('@', setBG white . setFG black)-viewMonster Eye     = ('e', setFG red)-viewMonster FastEye = ('e', setFG blue)-viewMonster Nose    = ('n', setFG green)
+ src/Multiline.hs view
@@ -0,0 +1,8 @@+module Multiline (multiline) where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TQ++-- | Used to handle multiline verbatim string expressions, see ConfigDefault.hs.+multiline :: TQ.QuasiQuoter+multiline  = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined
src/Perception.hs view
@@ -1,49 +1,107 @@ module Perception where -import Data.Set as S+import qualified Data.Set as S import Data.List as L+import qualified Data.IntMap as IM import Data.Maybe+import Control.Monad  import Geometry import State import Level-import Monster+import Actor+import ActorState+import qualified ActorKind import FOV import qualified Config  data Perception =-  Perception { preachable :: Set Loc, pvisible :: Set Loc }+  Perception { preachable :: S.Set Loc, pvisible :: S.Set Loc } -perception_ :: State -> Perception-perception_ (State { splayer = Monster { mloc = ploc },-                     slevel  = Level { lmap = lmap},-                     config  = config,-                     ssensory = ssensory }) =-  let mode   = Config.getOption config "engine" "fov_mode"-      radius = fromMaybe 40 $ Config.getOption config "engine" "fov_radius"-      fovMode =+-- The pplayer field is void if player not on the current level,+-- or if the player controls a blind monster (TODO. But perhaps only non-blind+-- monsters should be controllable?). Right now, the field is used only+-- for player-controlled monsters on the current level.+data Perceptions =+  Perceptions { pplayer :: Maybe Perception,+                pheroes :: IM.IntMap Perception,+                ptotal  :: Perception }++ptreachable, ptvisible :: Perceptions -> S.Set Loc+ptreachable = preachable . ptotal+ptvisible   = pvisible . ptotal++actorPrLoc :: (Perception -> S.Set Loc) ->+              ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool+actorPrLoc projection actor loc per pl =+  let tryHero = case actor of+                  AMonster _ -> Nothing+                  AHero i -> do+                    hper <- IM.lookup i (pheroes per)+                    return $ loc `S.member` (projection hper)+      tryPl   = do  -- the case for a monster under player control+                  guard $ Just actor == pl+                  pper <- pplayer per+                  return $ loc `S.member` projection pper+      tryAny  = tryHero `mplus` tryPl+  in  fromMaybe False tryAny  -- assume not visible, if no perception found++actorSeesLoc    :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool+actorSeesLoc    = actorPrLoc pvisible++actorReachesLoc :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool+actorReachesLoc = actorPrLoc preachable++-- Not quite correct if FOV not symmetric (Shadow).+actorReachesActor :: ActorId -> ActorId -> Loc -> Loc+                     -> Perceptions -> Maybe ActorId+                     -> Bool+actorReachesActor actor1 actor2 loc1 loc2 per pl =+  actorReachesLoc actor1 loc2 per pl ||+  actorReachesLoc actor2 loc1 per pl++perception_ :: State -> Perceptions+perception_ state@(State { splayer = pl,+                           slevel   = Level { lmap = lmap, lheroes = hs },+                           sconfig  = config,+                           ssensory = sensory }) =+  let mode   = Config.get config "engine" "fovMode"+      radius = Config.get config "engine" "fovRadius"+      fovMode m = if not $ ActorKind.bsight (akind m) then Blind else         -- terrible, temporary hack-        case ssensory of-          Vision 3 -> Diagonal radius+        case sensory of+          Vision 3 -> Digital radius           Vision 2 -> Permissive radius           Vision 1 -> Shadow           _        ->             -- this is not a hack             case mode of-              Just "permissive" -> Permissive radius-              Just "diagonal"   -> Diagonal radius-              _                 -> Shadow-  in  perception fovMode ploc lmap+              "permissive" -> Permissive radius+              "digital"    -> Digital radius+              "shadow"     -> Shadow+              _            -> error $ "perception_: unknown mode: " ++ show mode +      -- Perception for a player-controlled monster on the current level.+      pper = if isAMonster pl && memActor pl state+             then let m = getPlayerBody state+                  in Just $ perception (fovMode m) (aloc m) lmap+             else Nothing+      pers = IM.map (\ h -> perception (fovMode h) (aloc h) lmap) hs+      lpers = maybeToList pper ++ IM.elems pers+      reachable = S.unions (L.map preachable lpers)+      visible = S.unions (L.map pvisible lpers)+  in  Perceptions { pplayer = pper,+                    pheroes = pers,+                    ptotal = Perception reachable visible }+ perception :: FovMode -> Loc -> LMap -> Perception perception fovMode ploc lmap =   let     -- This part is simple. "reachable" contains everything that is on an-    -- unblocked path from the player position.+    -- unblocked path from the hero position.     reachable  = fullscan fovMode ploc lmap     -- In "actVisible", we store the locations that have light and are-    -- reachable. Furthermore, the player location itself is always-    -- visible.+    -- reachable. Furthermore, the hero location itself is always visible.     litVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable     actVisible = S.insert ploc litVisible     srnd       = S.fromList $ surroundings ploc@@ -67,7 +125,7 @@     -- A simpler way to make walls of lit rooms visible, at the cost of making     -- them reflect light from all sides, also from corridors.     -- Can be hacked around by checking for corridors in the condition below.-    -- The version in the comment assumes player light has diameter 3, not 1,+    -- The version in the comment assumes hero light has diameter 3, not 1,     -- which looks a bit differently in dark rooms, revealing more walls.     openSurroundings = S.filter (\ loc -> open (lmap `at` loc)) srnd     openVisible = S.union actVisible openSurroundings@@ -82,4 +140,5 @@   in     case fovMode of       Shadow -> Perception reachable visible+      Blind  -> Perception reachable visible       _      -> Perception reachable simpleVisible
src/Random.hs view
@@ -1,6 +1,8 @@ module Random (module Frequency, module Random) where +import qualified Data.Binary as Binary import Data.Ratio+import Data.List as L import qualified System.Random as R import Control.Monad.State @@ -72,3 +74,27 @@  (*~) :: Num a => Int -> Rnd a -> Rnd a x *~ r = liftM sum (replicateM x r)++-- RollDice: 1d7, 3d3, etc. (a, b) represent (a *~ d b).+type RollDice = (Binary.Word8, Binary.Word8)++rollDice :: RollDice -> Rnd Int+rollDice (a', b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in  a *~ d b++-- rollQuad (a, b, x, y) = a *~ d b + (lvl * (x *~ d y)) / 10+type RollQuad = (Binary.Word8, Binary.Word8, Binary.Word8, Binary.Word8)++rollQuad :: Int -> RollQuad -> Rnd Int+rollQuad lvl (a, b, x, y) = do+  aDb <- rollDice (a, b)+  xDy <- rollDice (x, y)+  return $ aDb + (lvl * xDy) `div` 10++intToQuad :: Int -> RollQuad+intToQuad 0 = (0, 0, 0, 0)+intToQuad n = let n' = fromIntegral n+              in  if n' > maxBound || n' < minBound+                  then error "intToQuad"+                  else (n', 1, 0, 0)
src/Save.hs view
@@ -9,16 +9,16 @@ import qualified Config  -- | Name of the save game.-file :: Config.CP -> IO String-file config = Config.getFile config "LambdaHack.save" "files" "savegame"+file :: Config.CP -> IO FilePath+file config = Config.getFile config "files" "saveGame"  -- | We save a simple serialized version of the current level and -- the current state. The 'False' is used only as an EOF marker. saveGame :: State -> IO () saveGame state =   do-    f <- file (config state)-    encodeCompressedFile f (state,False)+    f <- file (sconfig state)+    encodeCompressedFile f (state, False)  -- | Restore a saved game. Returns either the current level and -- game state, or a string containing an error message if restoring@@ -26,11 +26,27 @@ restoreGame :: Config.CP -> IO (Either State String) restoreGame config =   E.catch (do+             mvBkp config              f <- file config-             r <- strictDecodeCompressedFile f-             removeFile f-             case r of-               (x,z) -> (z :: Bool) `seq` return $ Left x)+             (x, z) <- strictDecodeCompressedFile (f ++ ".bkp")+             (z :: Bool) `seq` return $ Left x)           (\ e -> case e :: IOException of-                    _ -> return (Right $ "Restore failed: " ++-                                 (unwords . lines) (show e)))+                    _ -> return (Right $+                                   "Restore failed: "+                                   ++ (unwords . lines) (show e)))++-- | Move the savegame file to a backup slot.+mvBkp :: Config.CP -> IO ()+mvBkp config =+  do+    f <- file config+    renameFile f (f ++ ".bkp")++-- | Remove the backup of the savegame. Should be called before any+-- non-error exit from the game.+rmBkp :: Config.CP -> IO ()+rmBkp config =+  do+    f <- file config+    E.catch (removeFile (f ++ ".bkp"))+      (\ e -> case e :: IOException of _ -> return ())
src/State.hs view
@@ -2,37 +2,53 @@  import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.IntMap as IM import Control.Monad import Data.Binary import qualified Config -import Monster+import Actor import Geometry import Level+import Dungeon import Item import Message+import qualified ItemKind  -- | The 'State' contains all the game state that has to be saved. -- In practice, we maintain extra state, but that state is state -- accumulated during a turn or relevant only to the current session.+-- TODO: consider changing slevel to LevelName, removing the lname field+-- and not removing the current level from the dungeon. data State = State-               { splayer      :: Player,-                 shistory     :: [Message],-                 ssensory     :: SensoryMode,-                 sdisplay     :: DisplayMode,-                 stime        :: Time,-                 sassocs      :: Assocs,       -- ^ how does every item appear-                 sdiscoveries :: Discoveries,  -- ^ items (types) have been discovered-                 sdungeon     :: Dungeon,      -- ^ all but current dungeon level-                 slevel       :: Level,-                 config       :: Config.CP-               }+  { splayer      :: ActorId,      -- ^ represents the player-controlled actor+    scursor      :: Cursor,       -- ^ cursor location and level to return to+    shistory     :: [Message],+    ssensory     :: SensoryMode,+    sdisplay     :: DisplayMode,+    stime        :: Time,+    sassocs      :: Assocs,       -- ^ how every item appears+    sdiscoveries :: Discoveries,  -- ^ items (kinds) that have been discovered+    sdungeon     :: Dungeon,      -- ^ all but the current dungeon level+    slevel       :: Level,+    scounter     :: (Int, Int),   -- ^ stores next hero index and monster index+    sconfig      :: Config.CP+  }   deriving Show -defaultState :: Loc -> Dungeon -> Level -> State-defaultState ploc dng lvl =+data Cursor = Cursor+  { ctargeting :: Bool,       -- ^ are we in targeting mode?+    clocLn     :: LevelName,  -- ^ cursor level+    clocation  :: Loc,        -- ^ cursor coordinates+    creturnLn  :: LevelName   -- ^ the level current player resides on+  }+  deriving Show++defaultState :: Dungeon -> Level -> State+defaultState dng lvl =   State-    (defaultPlayer ploc)+    (AHero 0)+    (Cursor False (LambdaCave (-1)) (-1, -1) (lname lvl))     []     Implicit Normal     0@@ -40,39 +56,48 @@     S.empty     dng     lvl-    Config.empty_CP+    (0, 0)+    (Config.defaultCP) -updatePlayer :: (Monster -> Monster) -> State -> State-updatePlayer f s = s { splayer = f (splayer s) }+updateCursor :: (Cursor -> Cursor) -> State -> State+updateCursor f s = s { scursor = f (scursor s) }  updateHistory :: ([String] -> [String]) -> State -> State updateHistory f s = s { shistory = f (shistory s) } +updateTime :: (Time -> Time) -> State -> State+updateTime f s = s { stime = f (stime s) }+ updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State updateDiscoveries f s = s { sdiscoveries = f (sdiscoveries s) }  updateLevel :: (Level -> Level) -> State -> State updateLevel f s = s { slevel = f (slevel s) } -updateTime :: (Time -> Time) -> State -> State-updateTime f s = s { stime = f (stime s) }+updateDungeon :: (Dungeon -> Dungeon) -> State -> State+updateDungeon f s = s {sdungeon = f (sdungeon s)}  toggleVision :: State -> State-toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Implicit; Vision n -> Vision (n-1); _ -> Vision 3 }--toggleSmell :: State -> State-toggleSmell s = s { ssensory = if ssensory s == Smell then Implicit else Smell }+toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Smell+                                                   Vision n -> Vision (n-1)+                                                   Smell    -> Implicit+                                                   Implicit -> Vision 3 }  toggleOmniscient :: State -> State-toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient then Normal else Omniscient }+toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient+                                    then Normal+                                    else Omniscient }  toggleTerrain :: State -> State-toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal; Terrain n -> Terrain (n-1); _ -> Terrain 4 }+toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal+                                                    Terrain n -> Terrain (n-1)+                                                    _         -> Terrain 4 }  instance Binary State where-  put (State player hst sense disp time assocs discs dng lvl config) =+  put (State player cursor hst sense disp time assocs discs dng lvl ct config) =     do       put player+      put cursor       put hst       put sense       put disp@@ -81,10 +106,12 @@       put discs       put dng       put lvl+      put ct       put config   get =     do       player <- get+      cursor <- get       hst    <- get       sense  <- get       disp   <- get@@ -93,8 +120,25 @@       discs  <- get       dng    <- get       lvl    <- get+      ct     <- get       config <- get-      return (State player hst sense disp time assocs discs dng lvl config)+      return+        (State player cursor hst sense disp time assocs discs dng lvl ct config)++instance Binary Cursor where+  put (Cursor act cln loc rln) =+    do+      put act+      put cln+      put loc+      put rln+  get =+    do+      act <- get+      cln <- get+      loc <- get+      rln <- get+      return (Cursor act cln loc rln)  data SensoryMode =     Implicit
src/Strategy.hs view
@@ -15,14 +15,15 @@   return x = Strategy $ return (Frequency [(1, x)])   m >>= f  = Strategy $                filter (\ (Frequency xs) -> not (null xs))-               [ Frequency [ (p * q, b) +               [ Frequency [ (p * q, b)                            | (p, a) <- runFrequency x,                              y <- runStrategy (f a),-                             (q, b) <- runFrequency y ] +                             (q, b) <- runFrequency y ]                | x <- runStrategy m ]  liftFrequency :: Frequency a -> Strategy a-liftFrequency f = Strategy [f]+liftFrequency f  =+  Strategy $ filter (\ (Frequency xs) -> not (null xs)) $ return f  instance MonadPlus Strategy where   mzero = Strategy []
src/StrategyState.hs view
@@ -3,64 +3,177 @@ import Data.List as L import Data.Map as M import Data.Set as S+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad+import Control.Monad.State hiding (State)+import Control.Exception (assert)  import Geometry import Level-import Monster+import Actor+import ActorState+import ActorKind import Random import Perception import Strategy import State+import Action+import Actions+import ItemAction+import qualified ItemKind+import Item+import qualified Effect -strategy :: Monster -> State -> Perception -> Strategy Dir-strategy m@(Monster { mtype = mt, mloc = me, mdir = mdir })-         (state@(State { splayer = player@(Monster { mloc = ploc }),-                         stime   = time,-                         slevel  = lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap }) }))+-- import Debug.Trace++strategy :: ActorId -> State -> Perceptions -> Strategy (Action ())+strategy actor+         oldState@(State { scursor = cursor,+                           splayer = pl,+                           stime   = time,+                           slevel  = Level { lname = ln,+                                             lsmell = nsmap,+                                             lmap = lmap } })          per =-    case mt of-      Eye     -> slowEye-      FastEye -> fastEye-      Nose    -> nose-      _       -> onlyAccessible moveRandomly+--  trace (show time ++ ": " ++ show actor) $+    strategy   where-    -- we check if the monster is visible by the player rather than if the-    -- player is visible by the monster -- this is more efficient, but-    -- won't be correct in the general situation-    playerVisible      =  me `S.member` pvisible per-    playerAdjacent     =  adjacent me ploc-    towardsPlayer      =  towards (me, ploc)-    onlyTowardsPlayer  =  only (\ x -> distance (towardsPlayer, x) <= 1)-    lootPresent        =  (\ x -> not $ L.null $ titems $ lmap `at` x)-    onlyLootPresent    =  onlyMoves lootPresent me-    onlyPreservesDir   =  only (\ x -> maybe True (\ d -> distance (neg d, x) > 1) mdir)-    onlyUnoccupied     =  onlyMoves (unoccupied ms lmap) me-    onlyAccessible     =  onlyMoves (accessible lmap me) me-    onlyOpenable       =  onlyMoves (openable 10 lmap) me-    smells             =  L.map fst $-                          L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $-                          L.filter (\ (_,s) -> s > 0) $-                          L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves--    eye                =  onlyUnoccupied $-                            playerVisible .=> onlyTowardsPlayer moveRandomly-                            .| lootPresent me .=> return (0,0)-                            .| onlyLootPresent moveRandomly-                            .| onlyPreservesDir moveRandomly--    slowEye            =  playerAdjacent .=> return towardsPlayer-                          .| not playerVisible .=> onlyOpenable eye-                          .| onlyAccessible eye+    Actor { akind = mk, aloc = me, adir = adir,+            atarget = tgt, aitems = items } =+      getActor actor oldState+    delState = deleteActor actor oldState+    enemyVisible a l =+      -- We assume monster sight is infravision, so light has no significance.+      bsight mk && actorReachesActor a actor l me per Nothing ||+      -- Any enemy is visible if adjacent (e. g., a monster player).+      memActor a delState && adjacent me l+    -- If no heroes on the level, monsters go at each other. TODO: let them+    -- earn XP by killing each other to make this dangerous to the player.+    hs = L.map (\ (i, m) -> (AHero i, aloc m)) $+         IM.assocs $ lheroes $ slevel delState+    ms = L.map (\ (i, m) -> (AMonster i, aloc m)) $+         IM.assocs $ lmonsters $ slevel delState+    -- Below, "foe" is the hero (or a monster, or loc) chased by the actor.+    (newTgt, floc) =+      case tgt of+        TEnemy a ll | focusedMonster ->+          case findActorAnyLevel a delState of+            Just (_, m) ->+              let l = aloc m+              in  if enemyVisible a l+                  then (TEnemy a l, Just l)+                  else if isJust (snd closest) || me == ll+                       then closest         -- prefer visible foes+                       else (tgt, Just ll)  -- last known location of enemy+            Nothing -> closest  -- enemy dead, monsters can feel it+        TLoc loc -> if me == loc+                    then closest+                    else (tgt, Just loc)  -- ignore everything and go to loc+        _  -> closest+    closest =+      let hsAndTraitor = if isAMonster pl+                         then (pl, aloc $ getPlayerBody delState) : hs+                         else hs+          foes = if L.null hsAndTraitor then ms else hsAndTraitor+          -- We assume monster sight is infravision, so light has no effect.+          foeVisible = L.filter (\ (a, l) -> enemyVisible a l) foes+          foeDist = L.map (\ (a, l) -> (distance (me, l), l, a)) foeVisible+      in  case foeDist of+            [] -> (TCursor, Nothing)+            _  -> let (_, l, a) = L.minimum foeDist+                  in  (TEnemy a l, Just l)+    onlyFoe        = onlyMoves (maybe (const False) (==) floc) me+    towardsFoe     = case floc of+                       Nothing -> const mzero+                       Just loc ->+                         let foeDir = towards (me, loc)+                         in  only (\ x -> distance (foeDir, x) <= 1)+    lootHere       = (\ x -> not $ L.null $ titems $ lmap `at` x)+    onlyLoot       = onlyMoves lootHere me+    exitHere       = (\ x -> let t = lmap `at` x in open t && reflects t)+    onlyExit       = onlyMoves exitHere me+    onlyKeepsDir k = only (\ x -> maybe True (\ d -> distance (d, x) <= k) adir)+    onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) adir)+    onlyNoMs       = onlyMoves (unoccupied (levelMonsterList 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      = case strongestItem items "ring" of+                       Just i  -> biq mk + ipower i+                       Nothing -> biq mk+    openableHere   = openable openPower lmap+    onlyOpenable   = onlyMoves openableHere me+    accessibleHere = accessible lmap me+    onlySensible   = onlyMoves (\ l -> accessibleHere l || openableHere l) me+    focusedMonster = biq mk > 10+    smells         =+      L.map fst $+      L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $+      L.filter (\ (_, s) -> s > 0) $+      L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves+    fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d -    fastEye            =  playerAdjacent .=> return towardsPlayer-                          .| onlyAccessible eye+    strategy =+      fromDir True (onlyFoe moveFreely)+      .| isJust floc .=> liftFrequency (msum freqs)+      .| lootHere me .=> actionPickup+      .| fromDir True moveAround+    actionPickup = return $ actorPickupItem actor+    tis = titems $ lmap `at` me+    freqs = [applyFreq items 1, applyFreq tis 2,+             throwFreq items 2, throwFreq tis 5, towardsFreq]+    applyFreq is multi = Frequency+      [ (benefit * multi, actionApply (ItemKind.jname ik) i)+      | i <- is,+        let ik = ItemKind.getIK (ikind i),+        let benefit =+              (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+        benefit > 0,+        bsight mk || not (ItemKind.jname ik == "scroll")]+    actionApply groupName item =+      applyGroupItem actor (applyToVerb groupName) item+    throwFreq is multi = if not $ bsight mk then mzero else Frequency+      [ (benefit * multi, actionThrow (ItemKind.jname ik) i)+      | i <- is,+        let ik = ItemKind.getIK (ikind i),+        let benefit =+              - (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+        benefit > 0,+        -- Wasting swords would be too cruel to the player.+        not (ItemKind.jname ik == "sword")]+    actionThrow groupName item =+      zapGroupItem actor (fromJust floc) (zapToVerb groupName) item+    towardsFreq =+      let freqs = runStrategy $ fromDir False moveTowards+      in  if bsight mk && not (L.null freqs)+          then scale 30 $ head freqs+          else mzero+    moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely)+    moveAround =+      onlySensible $+        (if bsight mk then onlyNoMs else id) $+          bsmell mk .=> L.foldr (.|) reject (L.map return smells)+          .| onlyOpenable moveFreely+          .| moveFreely+    moveFreely = onlyLoot moveRandomly+                 .| onlyExit (onlyKeepsDir 2 moveRandomly)+                 .| biq mk > 15 .=> onlyKeepsDir 0 moveRandomly+                 .| biq mk > 10 .=> onlyKeepsDir 1 moveRandomly+                 .| biq mk > 5  .=> onlyKeepsDir 2 moveRandomly+                 .| onlyKeepsDir_9 moveRandomly+                 .| moveRandomly -    nose               =  playerAdjacent .=> return towardsPlayer-                          .| (onlyAccessible $-                              lootPresent me .=> return (0,0)-                              .| foldr (.|) reject (L.map return smells)-                              .| onlyLootPresent moveRandomly-                              .| moveRandomly)+dirToAction :: ActorId -> Target -> Bool -> Dir -> Action ()+dirToAction actor tgt allowAttacks dir =+  assert (dir /= (0,0)) $ do+  -- set new direction+  updateAnyActor actor $ \ m -> m { adir = Just dir, atarget = tgt }+  -- perform action+  tryWith (advanceTime actor) $+    -- if the following action aborts, we just advance the time and continue+    -- TODO: ensure time is taken for other aborted actions in this file+    moveOrAttack allowAttacks True actor dir  onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir onlyMoves p l = only (\ x -> p (l `shift` x))@@ -68,5 +181,5 @@ moveRandomly :: Strategy Dir moveRandomly = liftFrequency $ uniform moves -wait :: Strategy Dir-wait = return (0,0)+wait :: ActorId -> Strategy (Action ())+wait actor = return $ advanceTime actor
+ src/Terrain.hs view
@@ -0,0 +1,234 @@+module Terrain where++import Control.Monad++import Data.Binary+import Data.Maybe++import qualified Color+import Geometry++-- TODO: let terrain kinds be defined in a config file. Group them+-- and assign frequency so that they can be used for dungeon building.+-- Goal: Have 2 tileset configs, one small, Rouge/Nethack style,+-- the other big, Angband/UFO style. The problem is that the Rogue walls+-- are very complex, while Angband style is much simpler, and I love KISS. Hmmm.++data Terrain a =+    Rock+  | Opening Pos+  | Floor DL+  | Unknown+  | Corridor+  | Wall Pos+  | Stairs DL VDir (Maybe a)+  | Door Pos (Maybe Int)  -- Nothing: open, Just 0: closed, otherwise secret+  deriving Show++instance Binary VDir where+  put = putWord8 . fromIntegral . fromEnum+  get = liftM (toEnum . fromIntegral) getWord8++instance Binary a => Binary (Terrain a) where+  put Rock            = putWord8 0+  put (Opening p)     = putWord8 1 >> put p+  put (Floor dl)      = putWord8 2 >> put dl+  put Unknown         = putWord8 3+  put Corridor        = putWord8 4+  put (Wall p)        = putWord8 5 >> put p+  put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n+  put (Door p o)      = putWord8 7 >> put p >> put o+  get = do+          tag <- getWord8+          case tag of+            0 -> return Rock+            1 -> liftM Opening get+            2 -> liftM Floor get+            3 -> return Unknown+            4 -> return Corridor+            5 -> liftM Wall get+            6 -> liftM3 Stairs get get get+            7 -> liftM2 Door get get+            _ -> fail "no parse (Terrain)"++instance Eq a => Eq (Terrain a) where+  Rock == Rock = True+  Opening d == Opening d' = d == d'+  Floor l == Floor l' = l == l'+  Unknown == Unknown = True+  Corridor == Corridor = True+  Wall p == Wall p' = p == p'+  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'+  Door p o == Door p' o' = p == p' && o == o'+  _ == _ = False++data DL = Dark | Light+  deriving (Eq, Show, Enum, Bounded)++instance Binary DL where+  put = putWord8 . fromIntegral . fromEnum+  get = liftM (toEnum . fromIntegral) getWord8++-- | All the wall kinds that are possible:+--+--     * 'UL': upper left+--+--     * 'U': upper+--+--     * 'UR': upper right+--+--     * 'L': left+--+--     * 'R': right+--+--     * 'DL': lower left+--+--     * 'D': lower+--+--     * 'DR': lower right+--+--     * 'O': a pillar+--+-- I am tempted to add even more (T-pieces and crossings),+-- but currently, we don't need them.+data Pos = UL | U | UR | L | R | DL | D | DR | O+  deriving (Eq, Show, Enum, Bounded)++instance Binary Pos where+  put = putWord8 . fromIntegral . fromEnum+  get = liftM (toEnum . fromIntegral) getWord8++isFloor :: Terrain a -> Bool+isFloor (Floor _) = True+isFloor _         = False++isWall :: Terrain a -> Bool+isWall (Wall _) = True+isWall _        = False++isRock :: Terrain a -> Bool+isRock Rock = True+isRock _    = False++isUnknown :: Terrain a -> Bool+isUnknown Unknown = True+isUnknown _       = False++-- | allows moves and vision+isOpen :: Terrain a -> Bool+isOpen (Floor {})    = True+isOpen (Opening {}) = True+isOpen (Door _ o)   = isNothing o+isOpen Corridor     = True+isOpen (Stairs {})  = True+isOpen _            = False++fromDL :: DL -> Bool+fromDL Dark = False+fromDL Light = True++toDL :: Bool -> DL+toDL False = Dark+toDL True  = Light++-- | is lighted on its own+isAlight :: Terrain a -> Bool+isAlight (Floor l)      = fromDL l+isAlight (Stairs l _ _) = fromDL l+isAlight _              = False++-- | can be lighted by sourrounding tiles+reflects :: Terrain a -> Bool+reflects (Opening _) = True+reflects (Wall _)    = True+reflects (Door _ _)  = True+reflects _           = False++-- | Maps wall kinds to lists of expected floor positions.+posToDir :: Pos -> [Dir]+posToDir UL = [downright]+posToDir U  = [down]+posToDir UR = [downleft]+posToDir L  = [right]+posToDir R  = [left]+posToDir DL = [upright]+posToDir D  = [up]+posToDir DR = [upleft]+posToDir O  = moves++-- | Passive tiles reflect light from some other (usually adjacent)+-- positions. This function returns the offsets from which light is+-- reflected. Not all passively lighted tiles reflect from all directions.+-- Walls, for instance, cannot usually be seen from the outside.+passive :: Terrain a -> [Dir]+passive (Wall p)          = posToDir p+passive (Opening _)       = moves+passive (Door p Nothing)  = moves+passive (Door p (Just 0)) = moves      -- doors can be seen from all sides+passive (Door p (Just n)) = posToDir p -- secret doors are like walls+passive (Stairs _ _ _)    = moves+passive _                 = []++-- | Perceptible is similar to passive, but describes which tiles can+-- be seen from which adjacent fields in the dark.+perceptible :: Terrain a -> [Dir]+perceptible Rock = []+perceptible p = case passive p of+                 [] -> moves+                 ds -> ds++-- | Produces a textual description for terrain, used if no objects+-- are present.+lookTerrain :: Terrain a -> String+lookTerrain (Floor _)          = "Floor."+lookTerrain Corridor           = "Corridor."+lookTerrain (Opening _)        = "An opening."+lookTerrain (Stairs _ Up _)    = "A staircase up."+lookTerrain (Stairs _ Down _)  = "A staircase down."+lookTerrain (Door _ Nothing)   = "An open door."+lookTerrain (Door _ (Just 0))  = "A closed door."+lookTerrain (Door _ (Just _))  = "A wall."  -- secret+lookTerrain (Wall _ )          = "A wall."+lookTerrain _                  = ""++-- | The parameter "n" is the level of evolution:+--+-- 0: final+-- 1: stairs added+-- 2: doors added+-- 3: corridors and openings added+-- 4: only rooms+--+-- The Bool indicates whether the loc is currently visible.+viewTerrain :: Int -> Bool -> Terrain a -> (Char, Color.Color)+viewTerrain n b t =+  let def =     if b then Color.BrWhite else Color.defFG+      defDark = if b then Color.BrYellow else Color.BrBlack+      defDoor = if b then Color.Yellow else Color.BrBlack+  in case t of+       Rock                -> (' ', def)+       (Opening d)+         | n <= 3          -> ('.', def)+         | otherwise       -> viewTerrain 0 b (Wall d)+       (Floor d)           -> ('.', if d == Light then def else defDark)+       Unknown             -> (' ', def)+       Corridor+         | n <= 3          -> ('#', if b then Color.BrWhite else Color.defFG)+         | otherwise       -> viewTerrain 0 b Rock+       (Wall p)+         | p == O          -> ('O', def)+         | p `elem` [L, R] -> ('|', def)+         | otherwise       -> ('-', def)+       (Stairs d p _)+         | n <= 1          -> (if p == Up then '<' else '>',+                               if d == Light then def else defDark)+         | otherwise       -> viewTerrain 0 b (Floor Dark)+       (Door p (Just 0))+         | n <= 2          -> ('+', defDoor)+         | otherwise       -> viewTerrain n b (Opening p)+       (Door p (Just _))+         | n <= 2          -> viewTerrain n b (Wall p)  -- secret door+         | otherwise       -> viewTerrain n b (Opening p)+       (Door p Nothing)+         | n <= 2          -> (if p `elem` [L, R] then '-' else '|', defDoor)+         | otherwise       -> viewTerrain n b (Opening p)
src/Turn.hs view
@@ -2,22 +2,28 @@  import Control.Monad import Control.Monad.State hiding (State)+import Data.List as L import Data.Map as M+import Data.Set as S+import qualified Data.Ord as Ord+import qualified Data.IntMap as IM+import qualified Data.Char as Char  import Action import Actions-import Actor import Command-import Display2 hiding (display)+import qualified Config+import Display hiding (display)+import EffectAction import Keybindings import qualified Keys as K import Level-import Monster+import Actor+import ActorState import Random import State import Strategy import StrategyState-import Version  -- One turn proceeds through the following functions: --@@ -36,32 +42,31 @@ -- -- What's happening where: ----- handle: check for hero's death, HP regeneration, determine who moves next,+-- handle: determine who moves next, --   dispatch to handleMonsters or handlePlayer -- -- handlePlayer: remember, display, get and process commmand(s),---   advance player time, update smell map, update perception+--   update smell map, update perception ----- handleMonsters: find monsters that can move or die+-- handleMonsters: find monsters that can move -- -- handleMonster: determine and process monster action, advance monster time ----- nextMove: advance global game time, monster generation+-- nextMove: advance global game time, HP regeneration, monster generation -- -- This is rather convoluted, and the functions aren't named very aptly, so we -- should clean this up later. TODO. --- | Decide if the hero is ready for another move. Dispatch to either 'handleMonsters'--- or 'handlePlayer'.+-- | Decide if the hero is ready for another move.+-- Dispatch to either 'handleMonsters' or 'handlePlayer'. handle :: Action () handle =   do     debug "handle"     state <- get-    let ptime = mtime (splayer state)  -- time of hero's next move-    let time  = stime state            -- current game time-    checkHeroDeath     -- hero can die even if it's not the hero's turn-    regenerate APlayer -- hero can regenerate even if it's not the hero's turn+    pl <- gets splayer+    let ptime = atime (getPlayerBody state)  -- time of player's next move+    let time  = stime state                  -- current game time     debug $ "handle: time check. ptime = " ++ show ptime ++ ", time = " ++ show time     if ptime > time       then do@@ -70,7 +75,9 @@              -- monsters can be traced on the map; we disable this functionality if the              -- player is currently running, as it would slow down the running process              -- unnecessarily-             ifRunning (const $ return True) display+             ifRunning+               (const $ return True)+               (displayGeneric ColorFull (const ""))              handleMonsters       else do              handlePlayer -- it's the hero's turn!@@ -78,56 +85,35 @@ -- | Handle monster moves. Perform moves for individual monsters as long as -- there are monsters that have a move time which is less than or equal to -- the current time.+-- TODO: We should replace thi structure using a priority search queue/tree. handleMonsters :: Action () handleMonsters =   do     debug "handleMonsters"-    ms   <- gets (lmonsters . slevel)     time <- gets stime-    case ms of-      [] -> nextMove-      (m@(Monster { mtime = mt }) : ms)-        | mt > time  -> -- no monster is ready for another move-                        nextMove-        | mhp m <= 0 -> -- the monster dies-                        do-                          modify (updateLevel (updateMonsters (const ms)))-                          -- place the monster's possessions on the map-                          modify (updateLevel (scatterItems (mitems m) (mloc m)))-                          handleMonsters-        | otherwise  -> -- monster m should move; we temporarily remove m from the level-                        -- TODO: removal isn't nice. Actor numbers currently change during-                        -- a move. This could be cleaned up.-                        do-                          modify (updateLevel (updateMonsters (const ms)))-                          handleMonster m+    ms   <- gets (lmonsters . slevel)+    pl   <- gets splayer+    if IM.null ms+      then nextMove+      else let order  = Ord.comparing (atime . snd)+               (i, m) = L.minimumBy order (IM.assocs ms)+               actor = AMonster i+           in  if atime m > time || actor == pl+               then nextMove  -- no monster is ready for another move+               else handleMonster actor  -- | Handle the move of a single monster.--- Precondition: monster must not currently be in the monster list of the level.-handleMonster :: Monster -> Action ()-handleMonster m =+handleMonster :: ActorId -> Action ()+handleMonster actor =   do     debug "handleMonster"     state <- get-    let time = stime state-    let ms   = lmonsters (slevel state)     per <- currentPerception-    -- run the AI; it currently returns a direction; TODO: it should return an action-    dir <- liftIO $ rndToIO $ frequency (head (runStrategy (strategy m state per .| wait)))-    let waiting    = dir == (0,0)-    let nmdir      = if waiting then Nothing else Just dir-    -- advance time and reinsert monster-    let nm         = m { mtime = time + mspeed m, mdir = nmdir }-    let (act, nms) = insertMonster nm ms-    modify (updateLevel (updateMonsters (const nms)))-    let actor      = AMonster act-    try $ -- if the following action aborts, we just continue-      if waiting-        then-          -- monster is not moving, let's try to pick up an object-          actorPickupItem actor-        else-          moveOrAttack True True actor dir+    -- Run the AI: choses an action from those given by the AI strategy.+    action <-+      liftIO $ rndToIO $+        frequency (head (runStrategy (strategy actor state per .| wait actor)))+    action     handleMonsters  -- | After everything has been handled for the current game time, we can@@ -141,6 +127,7 @@   do     debug "nextMove"     modify (updateTime (+1))+    regenerateLevelHP     generateMonster     handle @@ -149,17 +136,26 @@ handlePlayer =   do     debug "handlePlayer"-    remember      -- the hero perceives his (potentially new) surroundings-    playerCommand -- get and process a player command-    -- at this point, the command was successful-    advanceTime APlayer     -- TODO: the command handlers should advance the move time-    state <- get-    let time = stime state-    let loc  = mloc (splayer state)-    -- update smell-    modify (updateLevel (updateSMap (M.insert loc (time + smellTimeout))))-    -- determine player perception and continue with monster moves-    withPerception handleMonsters+    remember  -- the hero perceives his (potentially new) surroundings+    -- determine perception before running player command, in case monsters+    -- have opened doors ...+    oldPlayerTime <- gets (atime . getPlayerBody)+    withPerception playerCommand -- get and process a player command+    -- at this point, the command was successful and possibly took some time+    newPlayerTime <- gets (atime . getPlayerBody)+    if newPlayerTime == oldPlayerTime+      then withPerception handlePlayer  -- no time taken, repeat+      else do+        state <- get+        pl    <- gets splayer+        let time = stime state+            ploc = aloc (getPlayerBody state)+            sTimeout = Config.get (sconfig state) "monsters" "smellTimeout"+        -- update smell+        when (isAHero pl) $  -- only humans leave strong scent+          modify (updateLevel (updateSMap (M.insert ploc (time + sTimeout))))+        -- determine player perception and continue with monster moves+        withPerception handleMonsters  -- | Determine and process the next player command. playerCommand :: Action ()@@ -210,15 +206,30 @@  -- | Display command help. TODO: Should be defined in Actions module. displayHelp :: Action ()-displayHelp = messageOverlayConfirm "Basic keys:" helpString >> abort-  where-  helpString = keyHelp stdKeybindings+displayHelp = do+  let coImage session k =+        let macros = snd session+            domain = M.keysSet macros+        in  if k `S.member` domain then [] else [k]+            ++ [ from | (from, to) <- M.assocs macros, to == k ]+  aliases <- session (return . coImage)+  let helpString = keyHelp aliases stdKeybindings+  messageOverlayConfirm "Basic keys:" helpString+  abort +heroSelection :: [(K.Key, Command)]+heroSelection =+  let heroSelect k = (K.Char (Char.intToDigit k),+                      Undescribed $+                      selectPlayer (AHero k) >> withPerception playerCommand)+  in  fmap heroSelect [0..9]+ stdKeybindings :: Keybindings stdKeybindings = Keybindings   { kdir   = moveDirCommand,     kudir  = runDirCommand,     kother = M.fromList $+             heroSelection ++              [ -- interaction with the dungeon                (K.Char 'o',  openCommand),                (K.Char 'c',  closeCommand),@@ -227,35 +238,39 @@                (K.Char '<',  ascendCommand),                (K.Char '>',  descendCommand), -               (K.Char ':',  lookCommand),+               (K.Char '*',  monsterCommand),+               (K.Char '/',  floorCommand),+               (K.Tab     ,  heroCommand),                 -- items-               (K.Char ',',  pickupCommand),+               (K.Char 'g',  pickupCommand),                (K.Char 'd',  dropCommand),                (K.Char 'i',  inventoryCommand),-               (K.Char 'q',  drinkCommand),+               (K.Char 'q',  quaffCommand),+               (K.Char 'r',  readCommand),+               (K.Char 't',  throwCommand),+               (K.Char 'a',  aimCommand),                 -- wait-               -- (K.Char ' ',  waitCommand),+               -- (K.Char ' ',  waitCommand),  -- dangerous, space is -more- key                (K.Char '.',  waitCommand),                 -- saving or ending the game-               (K.Char 'S',  saveCommand),+               (K.Char 'X',  saveCommand),                (K.Char 'Q',  quitCommand),-               (K.Esc     ,  Undescribed $ abortWith "Press Q to quit."),                 -- debug modes-               (K.Char 'V',  Undescribed $ modify toggleVision     >> withPerception playerCommand),-               (K.Char 'R',  Undescribed $ modify toggleSmell      >> playerCommand),-               (K.Char 'O',  Undescribed $ modify toggleOmniscient >> playerCommand),-               (K.Char 'T',  Undescribed $ modify toggleTerrain    >> playerCommand),+               (K.Char 'R',  Undescribed $ modify toggleVision),+               (K.Char 'O',  Undescribed $ modify toggleOmniscient),+               (K.Char 'T',  Undescribed $ modify toggleTerrain),                (K.Char 'I',  Undescribed $ gets (lmeta . slevel) >>= abortWith),                 -- information for the player-               (K.Char 'v',  Undescribed $ abortWith version),-               (K.Char 'M',  historyCommand),+               (K.Char 'V',  versionCommand),+               (K.Char 'P',  historyCommand),+               (K.Char 'D',  dumpCommand),                (K.Char '?',  helpCommand),-               (K.Return  ,  helpCommand)+               (K.Return  ,  acceptCommand displayHelp),+               (K.Esc     ,  cancelCommand)              ]   }-
src/Version.hs view
@@ -5,8 +5,7 @@ -- Cabal import qualified Paths_LambdaHack as Self (version) -import Display+import qualified Display  version :: String-version = showVersion Self.version ++ " (" ++ displayId ++ " frontend)"-+version = showVersion Self.version ++ " (" ++ Display.displayId ++ " frontend)"
+ src/config.default view
@@ -0,0 +1,60 @@+; This is the default config file, included in the binary itself.+; The game looks for the user config file in ~/.LambdaHack/config.+; We restricts the config file format by insisting that+; options are case-sensitive and permitting only ';' comments.++; If you contribute to the game, please create directory ~/.LambdaHack/+; as described in README.markdown. In this way, you will not accidentally+; commit your private high scores (nor your save files) to the game+; git repository.++[dungeon]+; the hardcoded default for levels with no specified layout:+LambdaCave_1: rogueRoom+; access to stairs may be blocked, so only suitable for the last level:+LambdaCave_10: noiseRoom+LambdaCave_3: bigRoom+depth: 10++[engine]+fovMode: shadow+;fovMode: digital+;fovMode: permissive+fovRadius: 40++; paths to various game files; relative to ~/.LambdaHack/+; (or analogous prefixes for other OSes, see getAppUserDataDirectory)+[files]+highScores: scores+saveGame: save++[heroes]+HeroName_0: you+HeroName_1: Haskell Alvin+HeroName_2: Alonzo Barkley+HeroName_3: Ernst Abraham+HeroName_4: Samuel Saunders+HeroName_5: Roger Robin+baseHP: 50+extraHeroes: 0+firstDeathEnds: False++[macros]+; TODO: the following does not work yet:+; ; throw a dart at the closest monster+; t: asterisk Return t Return+; TODO: in gtk it could be implemented via unGetChan,+; unless we prefer an explicit command queue, with flushing, etc.+;+; NetHack compatibility+S: X+colon: slash+comma: g+; Angband compatibility+v: t++[monsters]+smellTimeout: 1000++[ui]+historyMax: 500