packages feed

Allure 0.4.1 → 0.4.2

raw patch · 76 files changed

+4007/−3390 lines, 76 filesdep +arraydep +transformersdep −MissingHdep ~ConfigFiledep ~binarydep ~bytestringnew-component:exe:BotAllure

Dependencies added: array, transformers

Dependencies removed: MissingH

Dependency ranges changed: ConfigFile, binary, bytestring, containers, directory, filepath, gtk, hscurses, mtl, old-time, random, template-haskell, vty, zlib

Files

Allure.cabal view
@@ -1,21 +1,25 @@-cabal-version: >= 1.6+cabal-version: >= 1.10 name:          Allure-version:       0.4.1+version:       0.4.2 license:       BSD3 license-file:  LICENSE-tested-with:   GHC==7.0.3-data-files:    LICENSE, CREDITS, PLAYING.markdown,-               README.markdown, src/config.default, scores+tested-with:   GHC == 7.2.1, GHC == 7.3+data-files:    LICENSE, CREDITS, PLAYING.md,+               README.md, src/config.default, src/config.bot, scores author:        Andres Loeh, Mikolaj Konarski and others maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com>-description:   This is an alpha prerelease of Allure of the Stars,+description:   This is an alpha pre-release of Allure of the Stars,                a near-future Sci-Fi roguelike and tactical squad game.                Long term goals are high replayability and auto-balancing                through procedural content generation and persistent content                modification based on player behaviour.-               The game is based on the LambdaHack roguelike game engine,+               .+               The game is based (for the time being, as a fork)+               on the LambdaHack roguelike game engine available+               at <http://hackage.haskell.org/package/Allure>. synopsis:      Near-future roguelike game in early development homepage:      http://github.com/Mikolaj/Allure+bug-reports:   http://github.com/Mikolaj/Allure/issues category:      Game build-type:    Simple @@ -27,43 +31,71 @@   description:   enable vty support   default:       False +flag std+  description:   enable stdin/stdout support+  default:       False+ executable Allure   main-is:       Main.hs-  hs-source-dirs:src-  other-modules: Action, Actions, Color, Command, Config, ConfigDefault,-                 Display, Dungeon, DungeonState, Effect, EffectAction, File,+  hs-source-dirs: src+  other-modules: Action, Actions, ActorAdd, Actor, ActorState, Area, AreaRnd,+                 Cave, Color, Command, Config, ConfigDefault,+                 Content.Content, Content.ActorKind, Content.CaveKind,+                 Content.ItemKind, Content.TileKind,+                 Dir, Display, Dungeon, DungeonState,+                 Effect, EffectAction, Feature, Flavour,                  FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,-                 Frequency, Geometry, GeometryRnd, Grammar,-                 HighScores, Item, ItemKind, ItemAction,-                 Keys, Keybindings, Level, LevelState,-                 Main, Message, MovableAdd, MovableKind, Movable, MovableState,-                 Multiline, Perception, Random,-                 Save, State, Strategy, StrategyState,-                 Tile, Turn, Terrain, Version, WorldLoc-  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 && < 2,-                 template-haskell >= 2.5-  extensions:    CPP, FlexibleContexts, QuasiQuotes, MultiParamTypeClasses,-                 RankNTypes, BangPatterns+                 Frequency, Geometry, Grammar,+                 HighScores, Item, ItemAction,+                 Keys, Keybindings, Kind, Level, LevelState, Loc+                 Message, Perception, Random,+                 Save, State, Strategy, StrategyState, Tile, Turn,+                 Utils.Assert, Utils.File, Utils.Multiline,+                 Version, WorldLoc+  build-depends: ConfigFile >= 1.1.1 && < 2,+                 array >= 0.3.0.3 && < 1, base >= 4 && < 5,+                 binary >= 0.5.0.2 && < 1, bytestring >= 0.9.2 && < 1,+                 containers >= 0.4.1 && < 1, directory >= 1.1.0.1 && < 2,+                 filepath >= 1.2.0.1 && < 2, mtl >= 2.0.1 && < 3,+                 old-time >= 1.0.0.7 && < 2, random >= 1.0.1 && < 2,+                 template-haskell >= 2.6 && < 3, transformers >= 0.2.2 && < 1,+                 zlib >= 0.5.3.1 && < 1++  default-language: Haskell2010+  default-extensions: BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions: CPP, QuasiQuotes, MultiParamTypeClasses, RankNTypes+  ghc-options:   -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:   -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind+  ghc-options:   -fno-ignore-asserts -funbox-strict-fields+   if flag(curses) {     other-modules: Display.Curses-    build-depends: hscurses >= 1.3 && < 2+    build-depends: hscurses >= 1.4.1 && < 2     cpp-options:   -DCURSES     extra-libraries: curses   } else { if flag(vty) {     other-modules: Display.Vty-    build-depends: vty >= 4.4+    build-depends: vty >= 4.7.0.6+    cpp-options:   -DVTY+  } else { if flag(std) {+    cpp-options:   -DSTD   } else {     other-modules: Display.Gtk-    build-depends: gtk >= 0.11 && < 0.13-    cpp-options:   -DGTK+    build-depends: gtk >= 0.12.1 && < 0.13     ghc-options:   -threaded-  } }+  } } } -Source-repository head+executable BotAllure+  main-is:       Bot.hs+  hs-source-dirs: src+  build-depends: base >= 4 && < 5, random >= 1.0.1 && < 2+  default-language: Haskell2010+  default-extensions: BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions: CPP, QuasiQuotes, MultiParamTypeClasses, RankNTypes+  ghc-options:   -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:   -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind+  ghc-options:   -fno-ignore-asserts -funbox-strict-fields++source-repository head   type:              git   location:          git://github.com/Mikolaj/Allure.git
− PLAYING.markdown 
@@ -1,152 +0,0 @@-Playing Allure of the Stars-===========================--Playing Allure of the Stars involves walking around the dungeon-(err, a Solar System space-ship that incidentally closely resembles-a fantasy dungeon, in this prerelease version of the game),-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.--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, battle the horrors within,-gather as much gold and gems as possible, and escape to tell the tale.-The dungeon consists of 10 levels and each level consists of 80 by 21 tiles.-The basic tiles are as follows.--               dungeon terrain type               on-screen symbol-               floor                              .-               wall                               #-               stairs up                          <-               stairs down                        >-               open door                          '-               closed door                        +--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-------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 (alternatively, you can bump into a door)-               q      quaff a potion-               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").--               key    command-               k      up-               j      down-               h      left-               l      right-               y      up-left-               u      up-right-               b      down-left-               n      down-right--Pressing a capital letter corresponding to a direction key will have-the hero run in that direction until something interesting occurs.--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 has problems, while xterm works fine.)--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-               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      inform about level meta-data-               R      rotate display modes---Monsters-----------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 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-----------------------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).--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.
+ PLAYING.md view
@@ -0,0 +1,146 @@+Playing Allure of the Stars+===========================++Playing Allure of the Stars involves walking around the dungeon+(err, a Solar System space-ship that incidentally closely resembles+a fantasy dungeon, in this pre-release version of the game),+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.++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, a lot of imagination is required+right now, but the game is already playable and winnable.+Contributions welcome.+++Dungeon+-------++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 are as follows.++               dungeon terrain type               on-screen symbol+               floor                              .+               wall                               #+               stairs up                          <+               stairs down                        >+               open door                          '+               closed door                        +++The game world is persistent, i.e., every time the player visits a level+during a single game, the level layout is 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+----++You move throughout the level using the numerical keypad or+the vi text editor keys (also known as "Rogue-like keys").++               7 8 9     y k u+                \|/       \|/+               4-5-6     h-.-l+                /|\       /|\+               1 2 3     b j n++Shift and a movement key make the hero run in the indicated direction,+until anything of interest is spotted. '5' and '.' skip a turn.+(Note that If you are using the curses or vty frontends,+numerical keypad may not work correctly depending on the versions+of curses, terminfo and terminal emulators. Vi keys should work regardless.)++Below are the basic default keys form common commands.++               key    command+               <      ascend a level+               >      descend a level+               ?      display help+               Q      quit without saving+               X      save and exit the game+               c      close a door+               d      drop an object+               g      get an object+               i      display inventory+               q      quaff a potion+               r      read a scroll+               a      aim a wand+               t      throw a weapon++Searching for secret doors and opening closed doors have no keys assigned.+Instead, bump into a wall to search and bump into a door to open.++To make a distance attack, you need to set your target first.+The targeting commands are listed below, together with all the other+less used commands.++               key    command+               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++There are also some debug and cheat keys. Use at your peril!++               key    command+               O      toggle "omniscience"+               I      inform about level meta-data+               R      rotate display modes+++Monsters+--------++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 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 kepad.+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+--------------------++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).++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 
@@ -1,58 +0,0 @@-Allure of the Stars-===================--This is an alpha prerelease of Allure of the Stars,-a near-future Sci-Fi [roguelike] [1] and tactical squad game.-Long term goals are high replayability and auto-balancing-through procedural content generation and persistent content-modification based on player behaviour.-The game is written in [Haskell] [2] and based-on the [LambdaHack roguelike engine] [3],---Compilation and installation-------------------------------The game is best compiled and installed via Cabal, which also takes care-of all dependencies. The latest official version of the game can be downloaded-automatically by Cabal from [Hackage] [4] as follows--    cabal install Allure--For a more current snapshot, download the source from [github] [5]-and run Cabal from the main directory--    cabal install--The best frontend (keyboard support and colours) is gtk,-but if needed, you may try one of the terminal frontends with, e.g,--    cabal install -fvty---Savegame directory---------------------If you don't want Allure of the Stars to write to the current directory,-create a personal savegame directory (on Linux it's ~/.Allure/).-and copy the scores file there. You may also want to-copy the configuration file src/config.default to-~/.Allure/config and modify it, but be careful changing-gameplay options --- they can easily unbalance or break the game.---Further information----------------------For more information, visit the wiki at https://github.com/Mikolaj/Allure/wiki-and see the files PLAYING.markdown, CREDITS and LICENSE.--Have fun!----[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation-[2]: http://www.haskell.org/-[3]: http://github.com/kosmikus/LambdaHack-[4]: http://hackage.haskell.org/package/Allure-[5]: http://github.com/Mikolaj/Allure
+ README.md view
@@ -0,0 +1,70 @@+Allure of the Stars+===================++This is an alpha pre-release of Allure of the Stars,+a near-future Sci-Fi [roguelike] [1] and tactical squad game.+Long-term goals are high replayability and auto-balancing+through procedural content generation and persistent content+modification based on player behaviour.+The game is written in [Haskell] [2] and based+on the [LambdaHack roguelike engine] [3].+++Compilation and installation+----------------------------++The game is best compiled and installed via Cabal, which also takes care+of all dependencies. The latest official version of the game can be downloaded+automatically by Cabal from [Hackage] [4] as follows++    cabal install Allure++For a more current snapshot, download the source from [github] [5]+and run Cabal from the main directory++    cabal install++The best frontend (keyboard support and colours) is gtk,+but if needed, you may try one of the terminal frontends with, e.g,++    cabal install -fvty++To use a crude bot for testing the game, you have to compile with+the standard input/output frontend, as follows++    cabal install -fstd++and run the bot, for example, in the following way++    BotAllure 42 20000000 | Allure > /tmp/log++You may wish to tweak the game configuration file to let the bot play longer,+e.g., by making the dungeon much deeper, as in the supplied config.bot.+++Savegame directory+------------------++If you don't want Allure of the Stars to write to the current directory,+create a personal savegame directory (on Linux it's ~/.Allure/).+and copy the scores file there. You may also want to+copy the configuration file src/config.default to+~/.Allure/config and modify it, but be careful changing+gameplay options --- they can easily unbalance or break the game.+++Further information+-------------------++For more information, visit the wiki at https://github.com/Mikolaj/Allure/wiki+and see the files PLAYING.md, CREDITS and LICENSE.++Have fun!++++[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation+[2]: http://www.haskell.org/+[3]: http://github.com/kosmikus/LambdaHack+[4]: http://hackage.haskell.org/package/Allure+[5]: http://github.com/Mikolaj/Allure
scores view

binary file changed (144 → 61 bytes)

src/Action.hs view
@@ -2,8 +2,7 @@ module Action where  import Control.Monad-import Control.Monad.State hiding (State)-import Data.List as L+import Control.Monad.State hiding (State, state) import qualified Data.IntMap as IM -- import System.IO (hPutStrLn, stderr) -- just for debugging @@ -12,10 +11,12 @@ import Message import State import Level-import Movable-import MovableState-import MovableKind+import Actor+import ActorState+import Content.ActorKind import qualified Save+import qualified Kind+import Random  newtype Action a = Action   { runAction ::@@ -30,13 +31,15 @@       IO r   } +-- TODO: check if it's strict enough, if we don't keep old states for too long,+-- Perhaps make state type fields strict for that, too? instance Monad Action where   return = returnAction   (>>=)  = bindAction  -- | Invokes the continuation. returnAction :: a -> Action a-returnAction x = Action (\ s e p k a st m -> k st m x)+returnAction x = Action (\ _s _e _p k _a st m -> k st m x)  -- | Distributes the session and shutdown continuation, -- threads the state and message.@@ -47,84 +50,76 @@                            in  runAction m s e p next a st ms)  instance MonadIO Action where-  liftIO x = Action (\ s e p k a st ms -> x >>= k st ms)+  liftIO x = Action (\ _s _e _p k _a st ms -> x >>= k st ms)  instance MonadState State Action where-  get     = Action (\ s e p k a st ms -> k  st ms st)-  put nst = Action (\ s e p k a st ms -> k nst ms ())+  get     = Action (\ _s _e _p k _a  st ms -> k st  ms st)+  put nst = Action (\ _s _e _p k _a _st ms -> k nst ms ())  -- | Exported function to run the monad. handlerToIO :: Session -> State -> Message -> Action () -> IO ()-handlerToIO session state msg h =+handlerToIO sess state msg h =   runAction h-    session-    (Save.rmBkp (sconfig state) >> shutdown session)  -- get out of the game+    sess+    (Save.rmBkp (sconfig state) >> shutdown sess)  -- get out of the game     (perception_ state)        -- cached perception     (\ _ _ x -> return x)      -- final continuation returns result     (ioError $ userError "unhandled abort")     state     msg +-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: Rnd a -> Action a+rndToAction r = do+  g <- gets srandom+  let (a, ng) = runState r g+  modify (\ state -> state {srandom = ng})+  return a+ -- | Invoking a session command. session :: (Session -> Action a) -> Action a session f = Action (\ s e p k a st ms -> runAction (f s) s e p k a st ms)  -- | Invoking a session command. sessionIO :: (Session -> IO a) -> Action a-sessionIO f = Action (\ s e p k a st ms -> f s >>= k st ms)+sessionIO f = Action (\ s _e _p k _a st ms -> f s >>= k st ms) --- | Display the current level, without any message.-displayWithoutMessage :: Action Bool-displayWithoutMessage = Action (\ s e p k a st ms -> displayLevel False s p st "" Nothing >>= k st ms)+-- | 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.+-- | 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 False s p st ms Nothing >>= k st ms)---- | Display the current level in black and white, and the current message,-displayBW :: Action Bool-displayBW = Action (\ s e p k a st ms -> displayLevel True 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 False 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.-messageWipeAndSet :: Message -> Action ()-messageWipeAndSet 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) ())+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-currentMessage = Action (\ s e p k a st ms -> k st ms ms)+currentMessage = Action (\ _s _e _p k _a st ms -> k st ms ms)  -- | End the game, i.e., invoke the shutdown continuation. end :: Action ()-end = Action (\ s e p k a st ms -> e)+end = Action (\ _s e _p _k _a _st _ms -> e)  -- | Reset the state and resume from the last backup point, i.e., invoke -- the failure continuation. abort :: Action a-abort = Action (\ s e p k a st ms -> a)---- | 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"+abort = Action (\ _s _e _p _k a _st _ms -> a)  -- | Set the current exception handler. First argument is the handler, -- second is the computation the handler scopes over.@@ -146,12 +141,12 @@  -- | Print a debug message or ignore. debug :: String -> Action ()-debug x = return () -- liftIO $ hPutStrLn stderr x+debug _x = return () -- liftIO $ hPutStrLn stderr _x  -- | Print the given message, then abort. abortWith :: Message -> Action a abortWith msg = do-  messageWipeAndSet msg+  messageReset msg   display   abort @@ -165,21 +160,21 @@  -- | Print message, await confirmation. Return value indicates -- if the player tried to abort/escape.-messageMoreConfirm :: Bool -> Message -> Action Bool-messageMoreConfirm blackAndWhite msg = do+messageMoreConfirm :: ColorMode -> Message -> Action Bool+messageMoreConfirm dm msg = do   messageAdd (msg ++ more)-  if blackAndWhite then displayBW else display+  displayGeneric dm id   session getConfirm  -- | Print message, await confirmation, ignore confirmation. messageMore :: Message -> Action ()-messageMore msg = resetMessage >> messageMoreConfirm False msg >> return ()+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-  messageWipeAndSet (msg ++ yesno)-  displayBW  -- turn player's attention to the choice+  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@@ -190,26 +185,25 @@ -- | Prints several overlays, one per page, and awaits confirmation. -- Return value indicates if the player tried to abort/escape. messageOverlaysConfirm :: Message -> [String] -> Action Bool-messageOverlaysConfirm msg [] =+messageOverlaysConfirm _msg [] =   do-    resetMessage+    messageClear     display     return True messageOverlaysConfirm msg (x:xs) =   do-    messageWipeAndSet msg-    b <- overlay (x ++ more)-    if b+    messageReset msg+    b0 <- overlay (x ++ more)+    if b0       then do         b <- session getConfirm         if b-          then do-            messageOverlaysConfirm msg xs+          then messageOverlaysConfirm msg xs           else stop       else stop   where     stop = do-      resetMessage+      messageClear       display       return False @@ -220,37 +214,37 @@  -- | Get the current perception. currentPerception :: Action Perceptions-currentPerception = Action (\ s e p k a st ms -> k st ms p)+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+  slid <- gets slid+  if creturnLn cursor == slid     then h     else abortWith "this command does not work on remote levels" -updateAnyActor :: Actor -> (Movable -> Movable) -> Action ()+updateAnyActor :: ActorId -> (Actor -> Actor) -> Action () updateAnyActor actor f = modify (updateAnyActorBody actor f) -updatePlayerBody :: (Movable -> Movable) -> Action ()+updatePlayerBody :: (Actor -> Actor) -> Action () updatePlayerBody f = do   pl <- gets splayer   updateAnyActor pl f  -- | Advance the move time for the given actor.-advanceTime :: Actor -> Action ()+advanceTime :: ActorId -> Action () advanceTime actor = do   time <- gets stime-  let upd m = m { mtime = time + (nspeed (mkind m)) }+  let upd m = m { btime = time + aspeed (Kind.getKind (bkind m)) }   -- A hack to synchronize the whole party:   pl <- gets splayer-  if (actor == pl || isAHero actor)+  if actor == pl || isAHero actor     then do            modify (updateLevel (updateHeroes (IM.map upd)))-           when (not $ isAHero pl) $ updatePlayerBody upd+           unless (isAHero pl) $ updatePlayerBody upd     else updateAnyActor actor upd  playerAdvanceTime :: Action ()
src/Actions.hs view
@@ -1,41 +1,37 @@ module Actions where  import Control.Monad-import Control.Monad.State hiding (State)-import Data.Function-import Data.List as L-import Data.Map as M+import Control.Monad.State hiding (State, state)+import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe-import Data.Set as S-import System.Time+import qualified Data.Set as S +import Utils.Assert import Action import Display hiding (display)-import Dungeon-import Geometry+import Loc+import Dir import Grammar import qualified HighScores as H import Item-import qualified ItemKind import qualified Keys as K import Level import LevelState-import Message-import Movable-import MovableState-import MovableKind-import MovableAdd+import Actor+import ActorState+import Content.ActorKind+import ActorAdd import Perception-import Random import State import qualified Config import qualified Save-import qualified Terrain-import qualified Effect import EffectAction import WorldLoc import Tile  -- TODO: qualified+import qualified Kind+import qualified Feature as F+import DungeonState  -- The Action stuff that is independent from ItemAction.hs. -- (Both depend on EffectAction.hs).@@ -62,10 +58,10 @@     if b       then do         -- Save the game state-        st <- get-        liftIO $ Save.saveGame st-        ln <- gets (lname . slevel)-        let total = calculateTotal st+        state <- get+        liftIO $ Save.saveGame state+        ln <- gets slid+        let total = calculateTotal state             status = H.Camping ln         go <- handleScores False status total         when go $ messageMore "See you soon, stronger and braver!"@@ -84,31 +80,32 @@ endTargeting :: Bool -> Action () endTargeting accept = do   returnLn <- gets (creturnLn . scursor)-  target   <- gets (mtarget . getPlayerBody)+  target   <- gets (btarget . getPlayerBody)   cloc     <- gets (clocation . scursor)-  lvlSwitch returnLn  -- return to the original level of the player+  -- return to the original level of the player+  modify (\ state -> state{slid = returnLn})   modify (updateCursor (\ c -> c { ctargeting = False }))   let isEnemy = case target of TEnemy _ _ -> True ; _ -> False-  when (not isEnemy) $+  unless isEnemy $     if accept-       then updatePlayerBody (\ p -> p { mtarget = TLoc cloc })-       else updatePlayerBody (\ p -> p { mtarget = TCursor })+       then updatePlayerBody (\ p -> p { btarget = TLoc cloc })+       else updatePlayerBody (\ p -> p { btarget = TCursor })   endTargetingMsg  endTargetingMsg :: Action () endTargetingMsg = do-  pkind    <- gets (mkind . getPlayerBody)-  target <- gets (mtarget . getPlayerBody)+  pbody  <- gets getPlayerBody   state  <- get+  lxsize <- gets (lxsize . slevel)   let verb = "target"-      targetMsg = case target of+      targetMsg = case btarget pbody of                     TEnemy a _ll ->-                      case findActorAnyLevel a state of-                        Just (_, m) -> objectMovable (mkind m)-                        Nothing     -> "a long gone adversary"-                    TLoc loc -> "location " ++ show loc+                      if memActor a state+                      then objectActor $ getActor a state+                      else "a fear of the past"+                    TLoc loc -> "location " ++ show (fromLoc lxsize loc)                     TCursor  -> "current cursor position continuously"-  messageAdd $ subjectMovableVerb pkind verb ++ " " ++ targetMsg ++ "."+  messageAdd $ subjectActorVerb pbody verb ++ " " ++ targetMsg ++ "."  -- | Cancel something, e.g., targeting mode, resetting the cursor -- to the position of the player. Chosen target is not invalidated.@@ -130,14 +127,22 @@  moveCursor :: Dir -> Int -> Action () moveCursor dir n = do-  (sy, sx) <- gets (lsize . slevel)+  lxsize <- gets (lxsize . slevel)+  lysize <- gets (lysize . 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 }+        let boundedShift loc =+              let (sx, sy) = fromLoc lxsize (loc `shift` dir)+                  (bx, by) = (max 1 $ min sx (lxsize - 2),+                              max 1 $ min sy (lysize - 2))+              in toLoc lxsize (bx, by)+            cloc = iterate boundedShift (clocation cursor) !! n+        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 dir = do   pl <- gets splayer@@ -151,7 +156,7 @@   if targeting     then moveCursor dir 10     else do-      updatePlayerBody (\ p -> p { mdir = Just dir })+      updatePlayerBody (\ p -> p { bdir = Just dir })       -- attacks and opening doors disallowed while running       moveOrAttack False False pl dir @@ -161,147 +166,176 @@ continueRun :: Dir -> Action () continueRun dir =   do-    state <- get-    loc   <- gets (mloc . getPlayerBody)-    per   <- currentPerception-    msg   <- currentMessage-    ms    <- gets (lmonsters . slevel)-    hs    <- gets (lheroes . slevel)-    lmap  <- gets (lmap . slevel)-    pl    <- gets splayer+    loc <- gets (bloc . getPlayerBody)+    per <- currentPerception+    msg <- currentMessage+    ms  <- gets (lmonsters . slevel)+    hs  <- gets (lheroes . slevel)+    lxsize <- gets (lxsize . slevel)+    lvl <- gets 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 mloc (IM.elems dms))+        mslocs = S.fromList (L.map bloc (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 mloc (IM.elems hs))-        dirOK     = accessible lmap loc (loc `shift` dir)+        tile      = lvl `rememberAt` loc  -- tile at current location+        itemsHere = not (L.null (lvl `irememberAt` loc))+        heroThere = (loc `shift` dir) `elem` L.map bloc (IM.elems hs)+        dirOK     = accessible lvl loc (loc `shift` dir)+        isTExit   = Tile.isExit tile+        isWalkableDark = Tile.isWalkable tile && not (Tile.isLit tile)     -- What happens next is mostly depending on the terrain we're currently on.-    let hop t-          | monstersVisible || heroThere-            || newsReported || itemsHere || Terrain.isExit t = abort-        hop t | Terrain.isFloorDark t =+    let hop | (monstersVisible || heroThere || newsReported ||+               itemsHere || isTExit) = abort+            | isWalkableDark =           -- 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))-                            moves-              allCloseTo main = L.all (\ d -> distance (main, d) <= 1) ns+          let ns = L.filter (\ x -> dirDistSq lxsize (neg dir) x > 1+                                    && (accessible lvl loc (loc `shift` x))+                                        || openable lvl (SecretStrength 1) (loc `shift` x))+                            (moves lxsize)+              allCloseTo main = L.all (\ d -> dirDistSq lxsize main d <= 1) ns           in  case ns of                 [onlyDir] -> run onlyDir  -- can be diagonal                 _         ->                   -- prefer orthogonal to diagonal dirs, for hero's safety-                  case L.filter (\ x -> not $ diagonal x) ns of+                  case L.filter (not . diagonal lxsize) ns of                     [ortoDir]                       | allCloseTo ortoDir -> run ortoDir                     _ -> abort-        hop _  -- outside corridors, never change direction-          | not dirOK = abort-        hop _         =-          let ns = L.filter (\ x -> x /= dir && distance (neg dir, x) > 1) moves+            | not dirOK =+          abort -- outside corridors never change direction+            | otherwise =+          let ns = L.filter (\ x -> x /= dir && dirDistSq lxsize (neg dir) x > 1) (moves lxsize)               ls = L.map (loc `shift`) ns-              as = L.filter (\ x -> accessible lmap loc x-                                    || openable 1 lmap x) ls-              ts = L.map (tterrain . (lmap `at`)) as-          in  if L.any Terrain.isExit ts then abort else run dir-    hop (tterrain t)+              as = L.filter (\ x -> accessible lvl loc x+                                    || openable lvl (SecretStrength 1) x) ls+              ts = L.map (lvl `rememberAt`) as+          in if L.any Tile.isExit ts then abort else run dir+    hop  ifRunning :: (Dir -> Action a) -> Action a -> Action a ifRunning t e =   do-    mdir <- gets (mdir . getPlayerBody)-    maybe e t mdir+    ad <- gets (bdir . getPlayerBody)+    maybe e t ad  -- | Update player memory. remember :: Action () remember =   do     per <- currentPerception-    let vis         = S.toList (ptvisible per)-    let rememberLoc = M.update (\ (t,_) -> Just (t,t))-    modify (updateLevel (updateLMap (\ lmap -> L.foldr rememberLoc lmap vis)))+    lvl <- gets slevel+    let vis = S.toList (ptvisible per)+    let rememberTile = [(loc, lvl `at` loc) | loc <- vis]+    modify (updateLevel (updateLRMap (Kind.// rememberTile)))+    let alt Nothing      = Nothing+        alt (Just ([], _)) = Nothing+        alt (Just (t, _))  = Just (t, t)+        rememberItem = IM.alter alt+    modify (updateLevel (updateIMap (\ m -> L.foldr rememberItem m vis))) --- | Open and close doors-openclose :: Bool -> Action ()-openclose o =-  do-    messageWipeAndSet "direction?"-    display-    e  <- session nextCommand-    pl <- gets splayer-    K.handleDirection e (actorOpenClose pl True o) (neverMind True)+-- | Ask for a direction and close the door, if any+closeDoor :: Action ()+closeDoor = do+  messageReset "direction?"+  display+  e <- session nextCommand+  lxsize <- gets (lxsize . slevel)+  K.handleDirection lxsize e playerCloseDoor (neverMind True) -actorOpenClose :: Actor ->-                  Bool ->    -- ^ verbose?-                  Bool ->    -- ^ open?-                  Dir -> Action ()-actorOpenClose actor v o dir =-  do-    state <- get-    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 = mloc body-    let isPlayer  = actor == pl-    let isVerbose = v && isPlayer-    let dloc = shift loc dir  -- location we act upon-    let openPower = case strongestItem (mitems body) "ring" of-                      Just i  -> niq (mkind body) + ipower i-                      Nothing -> niq (mkind body)-      in case lmap `at` dloc of-           Tile (Terrain.Door o') []-             | secret o' && isPlayer -> -- door is secret, cannot be opened or closed by the player-                                       neverMind isVerbose-             | maybe o ((|| not o) . (>= openPower)) o' ->-                                       -- door is in unsuitable state-                                       abortIfWith isVerbose ("already " ++ txt)-             | not (unoccupied hms dloc) ->-                                       -- door is blocked by a movable-                                       abortIfWith isVerbose "blocked"-             | otherwise            -> -- door can be opened / closed-                                       -- TODO: print message if action performed by monster and perceived-                                       let nt  = Tile (Terrain.door (toOpen o)) []-                                           adj = M.adjust (\ (_, mt) -> (nt, mt)) dloc-                                       in  modify (updateLevel (updateLMap adj))-           Tile (Terrain.Door o') _    -> -- door is jammed by items-                                       abortIfWith isVerbose "jammed"-           _                        -> -- there is no door here-                                       neverMind isVerbose-    advanceTime actor+-- | Player closes a door. AI never does.+playerCloseDoor :: Dir -> Action ()+playerCloseDoor dir = do+  state <- get+  lvl   <- gets slevel+  pl    <- gets splayer+  body  <- gets (getActor pl)+  let hms = levelHeroList state ++ levelMonsterList state+      dloc = shift (bloc body) dir  -- the location we act upon+      t = lvl `at` dloc+  if hasFeature F.Closable t+    then+      case lvl `iat` dloc of+        [] ->+          if unoccupied hms dloc+          then let adj = (Kind.// [(dloc, Tile.doorClosedId)])+               in modify (updateLevel (updateLMap adj))+          else abortWith "blocked"  -- by monsters or heroes+        _:_ -> abortWith "jammed"  -- by items+    else if hasFeature F.Openable t+         then abortWith "already closed"+         else neverMind True  -- no visible doors (can be secret)+  advanceTime pl --- | Attempt a level switch to k levels deeper.+-- | An actor closes a door. Player (hero or monster) or enemy.+actorOpenDoor :: ActorId -> Dir -> Action ()+actorOpenDoor actor dir = do+  lvl  <- gets slevel+  pl   <- gets splayer+  body <- gets (getActor actor)+  let dloc = shift (bloc body) dir  -- the location we act upon+      t = lvl `at` dloc+      isPlayer = actor == pl+      isVerbose = isPlayer  -- don't report enemy failures, if it's not player+      iq = aiq $ Kind.getKind $ bkind body+      openPower = SecretStrength $+        if isPlayer+        then 1  -- player can't open secret doors+        else case strongestItem (bitems body) "ring" of  -- TODO: hack+               Just i  -> iq + jpower i+               Nothing -> iq+  unless (openable lvl openPower dloc) $ neverMind isVerbose+  if hasFeature F.Closable t+    then abortIfWith isVerbose "already open"+    else if not (hasFeature F.Closable t ||+                 hasFeature F.Openable t ||+                 hasFeature F.Hidden t)+         then neverMind isVerbose  -- not doors at all+         else+           let adj = (Kind.// [(dloc, Tile.doorOpenId)])+           in  modify (updateLevel (updateLMap adj))+  advanceTime actor++-- | Attempt a level switch to k levels shallower. -- 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 =+lvlAscend :: Int -> Action ()+lvlAscend k =   do-    state <- get-    let n = levelNumber (lname (slevel state))-        nln = n + k-    when (nln < 1 || nln > sizeDungeon (sdungeon state) + 1) $+    slid   <- gets slid+    config <- gets sconfig+    let n = levelNumber slid+        nln = n - k+        depth = Config.get config "dungeon" "depth"+    when (nln < 1 || nln > depth) $       abortWith "no more levels in this direction"-    assertTrue $ liftM (k == 0 ||)  (lvlSwitch (LambdaCave nln))+    modify (\ state -> state{slid = (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 =+lvlGoUp :: Bool -> Action ()+lvlGoUp isUp =   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 mloc pbody-    case Terrain.deStairs $ tterrain $ map `at` loc of-      Just (vdir', next)+    slid      <- gets slid+    lvl       <- gets slevel+    st        <- get+    let loc = if targeting then clocation cursor else bloc pbody+        tile = lvl `at` loc+        vdir = if isUp then 1 else -1+        sdir | hasFeature F.Climbable tile = Just 1+             | hasFeature F.Descendable tile = Just (-1)+             | otherwise = Nothing+    case sdir of+      Just vdir'         | vdir == vdir' -> -- stairs are in the right direction-          case next of+          case whereTo st loc of             Nothing ->               -- we are at the "end" of the dungeon               if targeting@@ -311,51 +345,58 @@                 if b                   then fleeDungeon                   else abortWith "Game resumed."-            Just (nln, nloc) -> do+            Just (nln, nloc) ->               if targeting                 then do-                  -- this assertion says no stairs go back to the same level-                  assertTrue $ lvlSwitch nln+                  assert (nln /= slid `blame` (nln, "stairs looped")) $+                    modify (\ state -> state{slid = nln})                   -- do not freely reveal the other end of the stairs-                  map <- gets (lmap . slevel)  -- lvlSwitch modifies map-                  let upd cursor =-                        let cloc = if isUnknown (rememberAt map nloc)-                                   then loc-                                   else nloc-                        in  cursor { clocation = cloc, clocLn = nln }+                  lvl2 <- gets slevel+                  let upd cur =+                        let clocation = if isUnknown (lvl2 `rememberAt` nloc)+                                        then loc+                                        else nloc+                        in  cur { clocation, clocLn = nln }                   modify (updateCursor upd)                   doLook                 else tryWith (abortWith "somebody blocks the staircase") $ do                   -- Remove the player from the old level.                   modify (deleteActor pl)+                  hs <- gets levelHeroList+                  -- Monsters hear that players not on the level. Cancel smell.+                  -- Reduces memory load and savefile size.+                  when (L.null hs) $+                    modify (updateLevel (updateSmell (const IM.empty)))                   -- At this place the invariant that the player exists fails.                   -- Change to the new level (invariant not needed).-                  assertTrue $ lvlSwitch nln+                  assert (nln /= slid `blame` (nln, "stairs looped")) $+                    modify (\ state -> state{slid = 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 { mloc = nloc })+                  updatePlayerBody (\ p -> p { bloc = 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 movable on a tile" restored.+                  -- 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)+                  liftIO $ do+                    Save.saveGame state+                    Save.mvBkp (sconfig state)                   playerAdvanceTime       _ -> -- no stairs in the right direction         if targeting         then do-          lvlDescend (if vdir == Up then -1 else 1)-          ln <- gets (lname . slevel)-          let upd cursor = cursor { clocLn = ln }+          lvlAscend vdir+          let upd cur = cur {clocLn = slid}           modify (updateCursor upd)           doLook         else-          let txt = if vdir == Up then "up" else "down"+          let txt = if isUp then "up" else "down"           in  abortWith ("no stairs " ++ txt)  -- | Hero has left the dungeon.@@ -364,10 +405,10 @@   do     state <- get     let total = calculateTotal state-        items = L.concatMap mitems (levelHeroList state)+        items = L.concatMap bitems (levelHeroList state)     if total == 0       then do-             go <- resetMessage >> messageMoreConfirm False "Coward!"+             go <- messageClear >> messageMoreConfirm ColorFull "Coward!"              when go $                messageMore "Next time try to grab some loot before escape!"              end@@ -377,8 +418,8 @@              displayItems winMsg True items              go <- session getConfirm              when go $ do-               go <- handleScores True H.Victor total-               when go $ messageMore "Can it be done better, though?"+               go2 <- handleScores True H.Victor total+               when go2 $ messageMore "Can it be done better, though?"              end  -- | Switches current hero to the next hero on the level, if any, wrapping.@@ -391,38 +432,49 @@         (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)+      ni : _ -> selectPlayer (AHero ni)+                  >>= assert `trueM` (pl, ni, "hero duplicated")  -- | Search for secret doors search :: Action () search =   do-    lmap   <- gets (lmap . slevel)-    ploc   <- gets (mloc . getPlayerBody)-    pitems <- gets (mitems . getPlayerBody)+    lm     <- gets (lmap . slevel)+    le     <- gets (lsecret . slevel)+    lxsize <- gets (lxsize . slevel)+    ploc   <- gets (bloc . getPlayerBody)+    pitems <- gets (bitems . getPlayerBody)     let delta = case strongestItem pitems "ring" of-                  Just i  -> 1 + ipower i+                  Just i  -> 1 + jpower i                   Nothing -> 1-        searchTile (Tile (Terrain.Door (Just n)) x, t') =-          (Tile (Terrain.door (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)))+        searchTile loc (slm, sle) =+          let t = lm Kind.! loc+              k = secretStrength (le IM.! loc) - delta+          in if hasFeature F.Hidden t+             then if k > 0+                  then (slm,+                        IM.insert loc (SecretStrength k) sle)+                  else ((loc, Tile.doorClosedId) : slm,+                        IM.delete loc sle)+             else (slm, sle)+        f (slm, sle) m = searchTile (shift ploc m) (slm, sle)+        (lmDiff, lemap) = L.foldl' f ([], le) (moves lxsize)+        lmNew = if L.null lmDiff then lm else lm Kind.// lmDiff+    modify (updateLevel (\ l -> l{lmap = lmNew, lsecret = lemap}))     playerAdvanceTime  -- | Start the floor targeting mode or reset the cursor location to the player. targetFloor :: Action () targetFloor = do-  ploc      <- gets (mloc . getPlayerBody)-  target    <- gets (mtarget . getPlayerBody)+  ploc      <- gets (bloc . getPlayerBody)+  target    <- gets (btarget . 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 { mtarget = tgt })-  setCursor tgt+  updatePlayerBody (\ p -> p { btarget = tgt })+  setCursor  -- | Start the monster targeting mode. Cycle between monster targets. -- TODO: also target a monster by moving the cursor, if in target monster mode.@@ -432,7 +484,7 @@   pl        <- gets splayer   ms        <- gets (lmonsters . slevel)   per       <- currentPerception-  target    <- gets (mtarget . getPlayerBody)+  target    <- gets (btarget . getPlayerBody)   targeting <- gets (ctargeting . scursor)   let i = case target of             TEnemy (AMonster n) _ | targeting -> n  -- try next monster@@ -443,25 +495,23 @@               AHero _ -> ms       (lt, gt) = IM.split i dms       gtlt     = IM.assocs gt ++ IM.assocs lt-      lf = L.filter (\ (_, m) -> actorSeesLoc pl (mloc m) per (Just pl)) gtlt+      lf = L.filter (\ (_, m) -> actorSeesLoc pl (bloc m) per (Just pl)) gtlt       tgt = case lf of               [] -> target  -- no monsters in sight, stick to last target-              (ni, nm) : _ -> TEnemy (AMonster ni) (mloc nm)  -- pick the next-  updatePlayerBody (\ p -> p { mtarget = tgt })-  setCursor tgt+              (na, nm) : _ -> TEnemy (AMonster na) (bloc nm)  -- pick the next+  updatePlayerBody (\ p -> p { btarget = tgt })+  setCursor  -- | Set, activate and display cursor information.-setCursor :: Target -> Action ()-setCursor tgt = do+setCursor :: Action ()+setCursor = do   state <- get   per   <- currentPerception-  ploc  <- gets (mloc . getPlayerBody)-  ln    <- gets (lname . slevel)+  ploc  <- gets (bloc . getPlayerBody)+  clocLn <- gets slid   let upd cursor =-        let cloc = case targetToLoc (ptvisible per) state of-                     Nothing -> ploc-                     Just l  -> l-        in  cursor { ctargeting = True, clocation = cloc, clocLn = ln }+        let clocation = fromMaybe ploc (targetToLoc (ptvisible per) state)+        in cursor { ctargeting = True, clocation, clocLn }   modify (updateCursor upd)   doLook @@ -472,29 +522,29 @@   do     loc    <- gets (clocation . scursor)     state  <- get-    lmap   <- gets (lmap . slevel)+    lvl    <- gets slevel     per    <- currentPerception-    target <- gets (mtarget . getPlayerBody)+    target <- gets (btarget . getPlayerBody)     let canSee = S.member loc (ptvisible per)         monsterMsg =           if canSee-          then case L.find (\ m -> mloc m == loc) (levelMonsterList state) of-                 Just m  -> subjectMovable (mkind m) ++ " is here. "+          then case L.find (\ m -> bloc m == loc) (levelMonsterList state) of+                 Just m  -> subjectActor m ++ " is here. "                  Nothing -> ""           else ""         mode = case target of                  TEnemy _ _ -> "[targeting monster] "-                 TLoc _   -> "[targeting location] "-                 TCursor  -> "[targeting current] "+                 TLoc _     -> "[targeting location] "+                 TCursor    -> "[targeting current] "         -- general info about current loc-        lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg+        lookMsg = mode ++ lookAt True canSee state lvl loc monsterMsg         -- check if there's something lying around at current loc-        t = lmap `at` loc-    if length (titems t) <= 2+        is = lvl `irememberAt` loc+    if length is <= 2       then do              messageAdd lookMsg       else do-             displayItems lookMsg False (titems t)+             displayItems lookMsg False is              session getConfirm              messageAdd "" @@ -502,62 +552,56 @@ -- 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-      -- monsters attack themselves by accident.-      advanceTime actor-  | otherwise = do+moveOrAttack allowAttacks autoOpen actor dir = do       -- We start by looking at the target position.       state <- get       pl    <- gets splayer-      lmap  <- gets (lmap . slevel)+      lvl   <- gets slevel       sm    <- gets (getActor actor)-      let sloc = mloc sm           -- source location+      let sloc = bloc 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 $ \ m -> m { mloc = 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 ""+        Just target+          | allowAttacks ->+              -- Attacking does not require full access, adjacency is enough.+              actorAttackActor actor target+          | accessible lvl sloc tloc -> do+              -- Switching positions requires full access.+              actorRunActor actor target+              when (actor == pl) $+                messageAdd $ lookAt False True state lvl tloc ""+          | otherwise -> abortWith ""+        Nothing+          | accessible lvl sloc tloc -> do+              -- perform the move+              updateAnyActor actor $ \ body -> body {bloc = tloc}+              when (actor == pl) $+                messageAdd $ lookAt False True state lvl tloc ""+              advanceTime actor+          | allowAttacks && actor == pl+            && canBeSecretDoor (lvl `rememberAt` tloc)+            -> do+              messageAdd "You search your surroundings."  -- TODO: proper msg+              search+          | autoOpen -> actorOpenDoor actor dir  -- try to open a door+          | otherwise -> abortWith ""  -- | Resolves the result of an actor moving into another. Usually this -- involves melee attack, but with two heroes it just changes focus.--- Movables on blocked locations can be attacked without any restrictions.--- For instance, a movable capable of moving through walls+-- Actors on blocked locations can be attacked without any restrictions.+-- For instance, 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 :: Actor -> Actor -> Action ()-actorAttackActor (AHero _) target@(AHero _) =+actorAttackActor :: ActorId -> ActorId -> Action ()+actorAttackActor source@(AHero _) target@(AHero _) =   -- Select adjacent hero by bumping into him. Takes no time.-  assertTrue $ selectPlayer target+  selectPlayer target+    >>= assert `trueM` (source, target, "player bumps into himself") actorAttackActor source target = do   state <- get   sm    <- gets (getActor source)@@ -565,13 +609,12 @@   per   <- currentPerception   let groupName = "sword"       verb = attackToVerb groupName-      sloc = mloc sm-      swordKindIndex = fromJust $ L.elemIndex ItemKind.sword ItemKind.loot+      sloc = bloc sm       -- The hand-to-hand "weapon", equivalent to +0 sword.-      h2h = Item swordKindIndex 0 Nothing 1-      str = strongestItem (mitems sm) groupName+      h2h = Item Item.fistKindId 0 Nothing 1+      str = strongestItem (bitems sm) groupName       stack  = fromMaybe h2h str-      single = stack { icount = 1 }+      single = stack { jcount = 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"@@ -580,7 +623,7 @@               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 source target single+  itemEffectAction 0 source target single   advanceTime source  attackToVerb :: String -> String@@ -589,42 +632,41 @@ attackToVerb _ = "hit"  -- | Resolves the result of an actor running into another.--- This involves switching positions of the two movables.-actorRunActor :: Actor -> Actor -> Action ()+-- This involves switching positions of the two actors.+actorRunActor :: ActorId -> ActorId -> Action () actorRunActor source target = do-  pl    <- gets splayer-  sloc  <- gets (mloc . getActor source)  -- source location-  tloc  <- gets (mloc . getActor target)  -- target location-  updateAnyActor source $ \ m -> m { mloc = tloc }-  updateAnyActor target $ \ m -> m { mloc = sloc }+  pl   <- gets splayer+  sloc <- gets (bloc . getActor source)  -- source location+  tloc <- gets (bloc . getActor target)  -- target location+  updateAnyActor source $ \ m -> m { bloc = tloc }+  updateAnyActor target $ \ m -> m { bloc = sloc }   if source == pl     then stopRunning  -- do not switch positions repeatedly-    else if isAMonster source-         then focusIfAHero target-         else return ()+    else when (isAMonster source) $ focusIfAHero target   advanceTime source  -- | Generate a monster, possibly. generateMonster :: Action ()-generateMonster =-  do  -- TODO: simplify-    state  <- get-    nstate <- liftIO $ rndToIO $ rollMonster state-    modify (const nstate)+generateMonster = do+  state  <- get+  nstate <- rndToAction $ rollMonster state+  srandom <- gets srandom+  put $ nstate{srandom} --- | Possibly regenerate HP for all movables on the current level.+-- | Possibly regenerate HP for all actors on the current level. regenerateLevelHP :: Action () regenerateLevelHP =   do-    time  <- gets stime+    time <- gets stime     let upd m =-          let regen = nregen (mkind m) `div`-                      case strongestItem (mitems m) "amulet" of-                        Just i  -> ipower i+          let ak = Kind.getKind $ bkind m+              regen = aregen ak `div`+                      case strongestItem (bitems m) "amulet" of+                        Just i  -> jpower i                         Nothing -> 1           in if time `mod` regen /= 0              then m-             else m { mhp = min (nhpMax (mkind m)) (mhp m + 1) }+             else addHp 1 m     -- 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
+ src/Actor.hs view
@@ -0,0 +1,114 @@+module Actor where++import Data.Binary+import Control.Monad+import qualified Data.IntMap as IM++import Utils.Assert+import Geometry+import Dir+import Loc+import Item+import Content.ActorKind+import qualified Kind+import Random++-- | Monster properties that are changing a lot. If they are dublets+-- of properties form ActorKind, the intention is they may be modified+-- temporarily, but tend to return to the original value over time. E.g., HP.+data Actor = Actor+  { bkind   :: !(Kind.Id ActorKind)  -- ^ the kind of the actor+  , bname   :: !(Maybe String)  -- ^ individual name+  , bsymbol :: !(Maybe Char)    -- ^ individual map symbol+  , bhp     :: !Int             -- ^ current hit pints+  , bdir    :: !(Maybe Dir)     -- ^ the direction of running+  , btarget :: Target           -- ^ the target for distance attacks and AI+  , bloc    :: !Loc             -- ^ current location+  , bitems  :: [Item]           -- ^ inventory+  , bletter :: !Char            -- ^ next inventory letter+  , btime   :: !Time            -- ^ time of next action+  }+  deriving Show++instance Binary Actor where+  put (Actor ak an as ah ad at al ai ale ati) = do+    put ak+    put an+    put as+    put ah+    put ad+    put at+    put al+    put ai+    put ale+    put ati+  get = do+    ak  <- get+    an  <- get+    as  <- get+    ah  <- get+    ad  <- get+    at  <- get+    al  <- get+    ai  <- get+    ale <- get+    ati <- get+    return (Actor ak an as ah ad at al ai ale ati)++data ActorId = AHero !Int     -- ^ hero index (on the lheroes intmap)+             | AMonster !Int  -- ^ monster index (on the lmonsters intmap)+  deriving (Show, Eq, Ord)++type Party = IM.IntMap Actor++isAHero :: ActorId -> Bool+isAHero (AHero _) = True+isAHero (AMonster _) = False++isAMonster :: ActorId -> Bool+isAMonster = not . isAHero++addHp :: Int -> Actor -> Actor+addHp extra m =+  assert (extra >= 0 `blame` extra) $+  let maxHP = maxDice (ahp $ Kind.getKind $ bkind m)+      currentHP = bhp m+  in if currentHP > maxHP+     then m+     else m{bhp = min maxHP (currentHP + extra)}++-- Checks for the presence of actors. Does *not* check if the tile is open.+unoccupied :: [Actor] -> Loc -> Bool+unoccupied actors loc =+  all (\ body -> bloc body /= loc) actors++heroKindId :: Kind.Id ActorKind+heroKindId = Kind.getId ((== "hero") . aname)++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,114 @@+module ActorAdd where++import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.List as L+import Data.Ratio+import Data.Maybe+import qualified Data.Char as Char++import Utils.Assert+import Loc+import State+import Level+import Actor+import ActorState+import Content.ActorKind+import Random+import qualified Config+import WorldLoc+import qualified Tile+import qualified Kind++-- 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 :: Kind.Id ActorKind -> Maybe String -> Maybe Char -> Int -> Loc+            -> Actor+template mk ms mc hp loc = Actor mk ms mc hp Nothing TCursor loc [] 'a' 0++nearbyFreeLoc :: Loc -> State -> Loc+nearbyFreeLoc origin state =+  let lvl@Level{lxsize, lysize} = slevel state+      hs = levelHeroList state+      ms = levelMonsterList state+      places = origin : L.nub (concatMap (surroundings lxsize lysize) places)+      good loc = Tile.isWalkable (lvl `at` loc)+                 && loc `L.notElem` L.map bloc (hs ++ ms)+  in  fromMaybe (assert `failure` "too crowded map") $ 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"+      loc = nearbyFreeLoc ploc state+      n = fst (scounter state)+      symbol = if n < 1 || n > 9 then Nothing else Just $ Char.intToDigit n+      name = findHeroName config n+      startHP = bHP `div` min 10 (n + 1)+      m = template Actor.heroKindId (Just name) symbol startHP loc+      state' = state { scounter = (n + 1, snd (scounter state))+                     , sparty = IS.insert n (sparty 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 :: LevelId -> Int -> Rnd Bool+monsterGenChance (LambdaCave d) numMonsters =+  chance $ 1%(fromIntegral (250 + 200 * (numMonsters - d)) `max` 50)++-- | Create a new monster in the level, at a random position.+addMonster :: Kind.Id ActorKind -> Int -> Loc -> State -> State+addMonster mk hp ploc state = do+  let loc = nearbyFreeLoc ploc state+      n = snd (scounter state)+      m = template mk Nothing Nothing 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 = do+  let lvl = slevel state+      hs = levelHeroList state+      ms = levelMonsterList state+  rc <- monsterGenChance (slid state) (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 2000 (lmap lvl)+             (\ l t -> Tile.isWalkable t+                       && l `L.notElem` L.map bloc (hs ++ ms))+             (\ l t -> not (Tile.isLit t)  -- try a dark, distant place first+                       && L.all (\ pl -> distance+                                           (lxsize lvl)+                                           (bloc pl) l > 30) hs)+      (mk, k) <- frequency Kind.frequency+      hp <- rollDice $ ahp k+      return $ addMonster mk hp loc state
+ src/ActorState.hs view
@@ -0,0 +1,136 @@+module ActorState where++import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.IntSet as IS+import qualified Data.IntMap as IM+import Control.Monad+import Data.Maybe++import Utils.Assert+import Loc+import Actor+import Level+import qualified Dungeon+import State+import WorldLoc++-- The operations with "Any", and those that use them, consider all the dungeon.+-- All the other actor and level operations only consider the current level.++-- | Finds an actor body on any level. Fails if not found.+findActorAnyLevel :: ActorId -> State -> (LevelId, Actor)+findActorAnyLevel actor state@State{slid, sdungeon} =+  assert (not (absentHero actor state) `blame` actor) $+  let chk (ln, lvl) =+        fmap (\ m -> (ln, m)) $+        case actor of+          AHero n    -> IM.lookup n (lheroes lvl)+          AMonster n -> IM.lookup n (lmonsters lvl)+  in case mapMaybe chk (Dungeon.currentFirst slid sdungeon) of+    []    -> assert `failure` actor+    res:_ -> res  -- checking if res is unique would break laziness++-- | Checks whether an actor is a hero, but not a member of the party.+absentHero :: ActorId -> State -> Bool+absentHero a State{sparty} =+  case a of+    AHero n    -> IS.notMember n sparty+    AMonster _ -> False++getPlayerBody :: State -> Actor+getPlayerBody state =+  let pl = splayer state+  in snd $ findActorAnyLevel pl state++-- | The list of actors and levels for all heroes in the dungeon.+allHeroesAnyLevel :: State -> [(ActorId, LevelId)]+allHeroesAnyLevel State{slid, sdungeon} =+  let one (ln, Level{lheroes}) =+        L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs lheroes)+  in L.concatMap one (Dungeon.currentFirst slid sdungeon)++updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State+updateAnyActorBody actor f state =+  let (ln, _) = findActorAnyLevel actor state+  in case actor of+       AHero n    -> updateAnyLevel (updateHeroes   $ IM.adjust f n) ln state+       AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state++updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State+updateAnyLevel f ln state@State{slid, sdungeon}+  | ln == slid = updateLevel f state+  | otherwise = updateDungeon (const $ Dungeon.adjust f ln sdungeon) state++-- | Calculate the location of player's target.+targetToLoc :: S.Set Loc -> State -> Maybe Loc+targetToLoc visible state =+  case btarget (getPlayerBody state) of+    TLoc loc -> Just loc+    TCursor  ->+      if slid 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 = bloc (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 =+  case a of+    AHero n    -> IM.member n (lheroes (slevel state))+    AMonster n -> IM.member n (lmonsters (slevel state))++-- | Gets actor body from the current level. Error if not found.+getActor :: ActorId -> State -> Actor+getActor a state =+  case a of+    AHero n    -> lheroes   (slevel state) IM.! n+    AMonster n -> lmonsters (slevel state) IM.! n++-- | 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))++-- | Removes a player from the current level and party list.+deletePlayer :: State -> State+deletePlayer state@State{splayer, sparty} =+  let s = deleteActor splayer state+  in case splayer of+    AHero n    -> s{sparty = IS.delete n sparty}+    AMonster _ -> s++levelHeroList, levelMonsterList :: State -> [Actor]+levelHeroList    state = IM.elems $ lheroes   $ slevel state+levelMonsterList state = IM.elems $ lmonsters $ slevel state++-- | 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 `blame` l) $+     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) -> bloc m == loc) l+        in  fmap (injection . fst) im
+ src/Area.hs view
@@ -0,0 +1,51 @@+module Area+  ( Area, neighbors, fromTo, normalize, normalizeArea, grid ) where++import qualified Data.List as L++import Geometry+import Utils.Assert++type Area = (X, Y, X, Y)++neighbors :: Area ->        {- size limitation -}+             (X, Y) ->      {- location to find neighbors of -}+             [(X, Y)]+neighbors area xy =+  let cs = [ xy `shiftXY` (dx, dy)+           | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ]+  in  L.filter (`inside` area) cs++inside :: (X, Y) -> Area -> Bool+inside (x, y) (x0, y0, x1, y1) =+  x1 >= x && x >= x0 && y1 >= y && y >= y0++fromTo :: (X, Y) -> (X, Y) -> [(X, Y)]+fromTo (x0, y0) (x1, y1) =+ let result+       | x0 == x1 = L.map (\ y -> (x0, y)) (fromTo1 y0 y1)+       | y0 == y1 = L.map (\ x -> (x, y0)) (fromTo1 x0 x1)+       | otherwise = assert `failure` ((x0, y0), (x1, y1))+ in result++fromTo1 :: Int -> Int -> [Int]+fromTo1 x0 x1+  | x0 <= x1  = [x0..x1]+  | otherwise = [x0,x0-1..x1]++normalize :: ((X, Y), (X, Y)) -> ((X, Y), (X, Y))+normalize (a, b) | a <= b    = (a, b)+                 | otherwise = (b, a)++normalizeArea :: Area -> Area+normalizeArea (x0, y0, x1, y1) = (min x0 x1, min y0 y1, max x0 x1, max y0 y1)++grid :: (X, Y) -> Area -> [((X, Y), Area)]+grid (nx, ny) (x0, y0, x1, y1) =+  let yd = y1 - y0+      xd = x1 - x0+  in [ ((x, y), (x0 + (xd * x `div` nx),+                 y0 + (yd * y `div` ny),+                 x0 + (xd * (x + 1) `div` nx - 1),+                 y0 + (yd * (y + 1) `div` ny - 1)))+     | x <- [0..nx-1], y <- [0..ny-1] ]
+ src/AreaRnd.hs view
@@ -0,0 +1,103 @@+module AreaRnd where++import qualified Data.List as L+import qualified Data.Set as S+import qualified System.Random as R++import Geometry+import Area+import Random++xyInArea :: Area -> Rnd (X, Y)+xyInArea (x0, y0, x1, y1) = do+  rx <- randomR (x0, x1)+  ry <- randomR (y0, y1)+  return (rx, ry)++connectGrid' :: (X, Y) -> S.Set (X, Y) -> S.Set (X, Y) -> [((X, Y), (X, Y))] ->+                Rnd [((X, Y), (X, Y))]+connectGrid' (nx, ny) 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, nx-1, ny-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' (nx, ny) nu (S.delete c (candidates `S.union` nc)) (new acc)++connectGrid :: (X, Y) -> Rnd [((X, Y), (X, Y))]+connectGrid (nx, ny) = do+  let unconnected = S.fromList [ (x, y) | 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 [ (rx, ry) ]+  connectGrid' (nx, ny) unconnected candidates []++randomConnection :: (X, Y) -> Rnd ((X, Y), (X, Y))+randomConnection (nx, ny) = do+  rb  <- randomR (False, True)+  if rb+    then do+           rx  <- randomR (0, nx-2)+           ry  <- randomR (0, ny-1)+           return (normalize ((rx, ry), (rx+1, ry)))+    else do+           ry  <- randomR (0, ny-2)+           rx  <- randomR (0, nx-1)+           return (normalize ((rx, ry), (rx, ry+1)))++data HV = Horiz | Vert+  deriving (Eq, Show, Bounded)++fromHV :: HV -> Bool+fromHV Horiz = True+fromHV Vert  = False++toHV :: Bool -> HV+toHV True  = Horiz+toHV False = Vert++instance R.Random HV where+  randomR (a, b0) g = case R.randomR (fromHV a, fromHV b0) g of+                        (b, g') -> (toHV b, g')+  random = R.randomR (minBound, maxBound)++-- | Create a corridor, either horizontal or vertical, with+-- a possible intermediate part that is in the opposite direction.+mkCorridor :: HV -> ((X, Y), (X, Y)) -> Area -> Rnd [(X, Y)] {- straight sections of the corridor -}+mkCorridor hv ((x0, y0), (x1, y1)) b =+  do+    (rx, ry) <- xyInArea b+    -- (rx, ry) is intermediate point the path crosses+    -- hv decides whether we start in horizontal or vertical direction+    case hv of+      Horiz -> return [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]+      Vert  -> return [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]++-- | Try to connect two rooms with a corridor.+-- The condition passed to mkCorridor is tricky; there might not always+-- exist a suitable intermediate point if the rooms are allowed to be close+-- together ...+connectRooms :: Area -> Area -> Rnd [(X, Y)]+connectRooms sa@(_, _, sx1, sy1) ta@(tx0, ty0, _, _) =+  do+    (sx, sy) <- xyInArea sa+    (tx, ty) <- xyInArea ta+    let xok = sx1 < tx0 - 3+    let xarea = normalizeArea (sx1+2, sy, tx0-2, ty)+    let yok = sy1 < ty0 - 3+    let yarea = normalizeArea (sx, sy1+2, tx, ty0-2)+    let xyarea = normalizeArea (sx1+2, sy1+2, tx0-2, ty0-2)+    (hv, area) <- if xok && yok then fmap (\ hv -> (hv, xyarea)) (binaryChoice Horiz Vert)+                  else if xok   then return (Horiz, xarea)+                                else return (Vert, yarea)+    mkCorridor hv ((sx, sy), (tx, ty)) area
+ src/Bot.hs view
@@ -0,0 +1,22 @@+module Main where++import qualified System.Random as R+import System.Environment+import Control.Monad++move :: R.StdGen -> Int -> IO ()+move g k = do+  let (c, ng) = R.randomR ('0', 'z') g+  putChar c+  when (k > 0) $ move ng (k - 1)++main :: IO ()+main = do+  args <- getArgs+  case args of+    [seed, count] -> do+      -- Start by dumping config (hack: ' ', see Std.hs) with the game seed.+      putChar ' '+      -- Note that the seed is separate from the game seed.+      move (R.mkStdGen (read seed)) (read count)+    _ -> error "Two integer arguments required: random seed and iteration count."
+ src/Cave.hs view
@@ -0,0 +1,208 @@+module Cave+  ( Cave(..), SecretMapXY, ItemMapXY, TileMapXY, buildCave ) where++import Control.Monad+import qualified Data.Map as M+import qualified Data.List as L++import Geometry+import Area+import AreaRnd+import Item+import Random+import Content.TileKind+import Tile+import qualified Kind+import Content.CaveKind++type SecretMapXY = M.Map (X, Y) SecretStrength++type ItemMapXY = M.Map (X, Y) Item++type TileMapXY = M.Map (X, Y) (Kind.Id TileKind)++-- TODO: dmonsters :: [(X, Y), actorKind]  -- ^ fixed monsters on the level+data Cave = Cave+  { dkind     :: !(Kind.Id CaveKind)  -- ^ the kind of the cave+  , dsecret   :: SecretMapXY+  , ditem     :: ItemMapXY+  , dmap      :: TileMapXY+  , dmeta     :: String+  }+  deriving Show++buildCave :: Int -> Kind.Id CaveKind -> Rnd Cave+buildCave n ci =+  let CaveKind{clayout} = Kind.getKind ci+  in case clayout of+       CaveRogue -> caveRogue n ci+       CaveEmpty -> caveEmpty n ci+       CaveNoise -> caveNoise n ci++-- | Cave consisting of only one, empty room.+caveEmpty :: Int -> Kind.Id CaveKind -> Rnd Cave+caveEmpty _ ci =+  let CaveKind{cxsize, cysize} = Kind.getKind ci+      room = (1, 1, cxsize - 2, cysize - 2)+      dmap = digRoom True room M.empty+      cave = Cave+        { dkind = ci+        , dsecret = M.empty+        , ditem = M.empty+        , dmap+        , dmeta = "empty room"+        }+  in return cave++-- | Cave consisting of only one room with randomly distributed pillars.+caveNoise :: Int -> Kind.Id CaveKind -> Rnd Cave+caveNoise _ ci = do+  let CaveKind{cxsize, cysize} = Kind.getKind ci+      room = (1, 1, cxsize - 2, cysize - 2)+      em = digRoom True room M.empty+  nri <- rollDice (fromIntegral (cysize `div` 5), 3)+  lxy <- replicateM (cxsize * nri) $ xyInArea (1, 1, cxsize - 2, cysize - 2)+  let insertRock lm xy = M.insert xy Tile.wallId lm+      dmap = L.foldl' insertRock em lxy+      cave = Cave+        { dkind = ci+        , dsecret = M.empty+        , ditem = M.empty+        , dmap+        , dmeta = "noise room"+        }+  return cave++-- | If the room has size 1, it is at most a start of a corridor.+digRoom :: Bool -> Room -> TileMapXY -> TileMapXY+digRoom dl (x0, y0, x1, y1) lmap+  | x0 == x1 && y0 == y1 = lmap+  | otherwise =+  let floorDL = if dl then Tile.floorLightId else Tile.floorDarkId+      rm =+        [ ((x, y), floorDL) | x <- [x0..x1], y <- [y0..y1] ]+        ++ [ ((x, y), Tile.wallId)+           | x <- [x0-1, x1+1], y <- [y0..y1] ]+        ++ [ ((x, y), Tile.wallId)+           | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]+  in M.union (M.fromList rm) lmap++{-+Rogue cave is generated by an algorithm inspired by the original Rogue,+as follows:++  * The available area is divided into a 3 by 3 grid+    where each of the 9 grid cells has approximately the same size.++  * In each of the 9 grid cells one room is placed at a random location.+    The minimum size of a room is 2 by 2 floor tiles. A room is surrounded+    by walls, and the walls still have to fit into the assigned grid cells.++  * Rooms that are on horizontally or vertically adjacent grid cells+    may be connected by a corridor. Corridors consist of 3 segments of straight+    lines (either "horizontal, vertical, horizontal" or "vertical, horizontal,+    vertical"). They end in openings in the walls of the room they connect.+    It is possible that one or two of the 3 segments have length 0, such that+    the resulting corridor is L-shaped or even a single straight line.++  * Corridors are generated randomly in such a way that at least every room+    on the grid is connected, and a few more might be. It is not sufficient+    to always connect all adjacent rooms.+-}+-- | Cave generated by an algorithm inspired by the original Rogue,+caveRogue :: Int -> Kind.Id CaveKind -> Rnd Cave+caveRogue n ci = do+    let cfg@CaveKind{cxsize, cysize} = Kind.getKind ci+    lgrid@(gx, gy) <- levelGrid cfg+    lminroom <- minRoomSize cfg+    let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1)+    -- grid locations of "no-rooms"+    nrnr <- noRooms cfg lgrid+    nr   <- replicateM nrnr $ xyInArea (0, 0, gx - 1, gy - 1)+    rs0  <- mapM (\ (i, r) -> do+                              r' <- if i `elem` nr+                                      then mkRoom (border cfg) (1, 1) r+                                      else mkRoom (border cfg) lminroom r+                              return (i, r')) gs+    let rooms :: [Area]+        rooms = L.map snd rs0+    dlrooms <- mapM (\ r -> darkRoomChance cfg n+                            >>= \ c -> return (r, not c)) rooms+               :: Rnd [(Area, Bool)]+    let rs = M.fromList rs0+    connects <- connectGrid lgrid+    addedConnects <- replicateM+                       (extraConnects cfg lgrid)+                       (randomConnection lgrid)+    let allConnects = L.nub (addedConnects ++ connects)+    cs <- mapM+           (\ (p0, p1) -> do+                           let r0 = rs M.! p0+                               r1 = rs M.! p1+                           connectRooms r0 r1) allConnects+    let lrooms = L.foldr (\ (r, dl) m -> digRoom dl r m) M.empty dlrooms+        lcorridors = M.unions (L.map digCorridors cs)+        lrocks =+          M.fromList [ ((x, y), Tile.wallId) | x <- [0..cxsize - 1], y <- [0..cysize - 1] ]+        lm = M.union (M.unionWith mergeCorridor lcorridors lrooms) lrocks+    -- convert openings into doors+    (dmap, secretMap) <- do+      let f (l, le) o@((x, y), t) =+                  case t of+                    _ | Tile.isOpening t ->+                      do+                        -- openings have a certain chance to be doors;+                        -- doors have a certain chance to be open; and+                        -- closed doors have a certain chance to be+                        -- secret+                        rb <- doorChance cfg+                        ro <- doorOpenChance cfg+                        if not rb+                          then return (o : l, le)+                          else if ro+                               then return (((x, y), Tile.doorOpenId) : l, le)+                               else do+                                 rsc <- doorSecretChance cfg+                                 if not rsc+                                   then return (((x, y), Tile.doorClosedId) : l, le)+                                   else do+                                     rs1 <- rollDice (csecretStrength cfg)+                                     return (((x, y), Tile.doorSecretId) : l, M.insert (x, y) (SecretStrength rs1) le)+                    _ -> return (o : l, le)+      (l, le) <- foldM f ([], M.empty) (M.toList lm)+      return (M.fromList l, le)+    let cave = Cave+          { dkind = ci+          , dsecret = secretMap+          , ditem = M.empty+          , dmap+          , dmeta = show allConnects+          }+    return cave++type Corridor = [(X, Y)]+type Room = Area++-- | Create a random room according to given parameters.+mkRoom :: Int ->      -- ^ border columns+          (X, Y) ->    -- ^ minimum size+          Area ->     -- ^ this is an area, not the room itself+          Rnd Room    -- ^ this is the upper-left and lower-right corner of the room+mkRoom bd (xm, ym) (x0, y0, x1, y1) =+  do+    (rx0, ry0) <- xyInArea (x0 + bd, y0 + bd, x1 - bd - xm + 1, y1 - bd - ym + 1)+    (rx1, ry1) <- xyInArea (rx0 + xm - 1, ry0 + ym - 1, x1 - bd, y1 - bd)+    return (rx0, ry0, rx1, ry1)++digCorridors :: Corridor -> TileMapXY+digCorridors (p1:p2:ps) =+  M.union corPos (digCorridors (p2:ps))+  where+    corXY  = fromTo p1 p2+    corPos = M.fromList $ L.zip corXY (repeat Tile.floorDarkId)+digCorridors _ = M.empty++mergeCorridor :: Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind+mergeCorridor _ t | Tile.isWalkable t = t+mergeCorridor _ t | Tile.isUnknown t  = Tile.floorDarkId+mergeCorridor _ _                     = Tile.openingId
src/Color.hs view
@@ -1,8 +1,17 @@-module Color where+module Color+  (Color(..), Attr, defBG, defFG, defaultAttr, isBright, legalBG, colorToRGB)+  where -import Control.Monad import qualified Data.Binary as Binary +-- TODO: if the file grows much larger, split into Utils/Color.hs and Attr.hs++-- TODO: since this type may be essential to speed, consider implementing+-- it as an Int, with color numbered as they are on terminals, see+-- http://www.haskell.org/haskellwiki/Performance/Data_types#Enumerations+-- If we ever switch to 256 colours, the Int implementation or similar+-- will be more natural, anyway.+ data Color =     Black   | Red@@ -23,14 +32,15 @@   deriving (Show, Eq, Ord, Enum, Bounded)  instance Binary.Binary Color where-  put = Binary.putWord8 . fromIntegral . fromEnum-  get = liftM (toEnum . fromIntegral) Binary.getWord8+  put = Binary.putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) Binary.getWord8  defBG, defFG :: Color defBG = Black defFG = White  type Attr = (Color.Color, Color.Color)+ defaultAttr :: Attr defaultAttr = (Color.defFG, Color.defBG) @@ -50,8 +60,8 @@ colorToRGB Blue      = "#203AF0" colorToRGB Magenta   = "#AA00AA" colorToRGB Cyan      = "#00AAAA"-colorToRGB White     = "#BEBABA"-colorToRGB BrBlack   = "#6A6565"+colorToRGB White     = "#C5BCB8"+colorToRGB BrBlack   = "#6F5F5F" colorToRGB BrRed     = "#FF5555" colorToRGB BrGreen   = "#75FF45" colorToRGB BrYellow  = "#FFE855"@@ -62,58 +72,20 @@  -- 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"+_olorToRGB :: Color -> String+_olorToRGB Black     = "#000000"+_olorToRGB Red       = "#AA0000"+_olorToRGB Green     = "#00AA00"+_olorToRGB Yellow    = "#AA5500"  -- brown+_olorToRGB Blue      = "#0000AA"+_olorToRGB Magenta   = "#AA00AA"+_olorToRGB Cyan      = "#00AAAA"+_olorToRGB White     = "#AAAAAA"+_olorToRGB BrBlack   = "#555555"+_olorToRGB BrRed     = "#FF5555"+_olorToRGB BrGreen   = "#55FF55"+_olorToRGB BrYellow  = "#FFFF55"+_olorToRGB BrBlue    = "#5555FF"+_olorToRGB BrMagenta = "#FF55FF"+_olorToRGB BrCyan    = "#55FFFF"+_olorToRGB BrWhite   = "#FFFFFF"
src/Command.hs view
@@ -2,9 +2,8 @@  import Action import Actions+import Dir import ItemAction-import Geometry-import Level import Version  data Described a = Described { chelp :: String, caction :: a }@@ -13,29 +12,30 @@ type Command    = Described (Action ()) type DirCommand = Described (Dir -> Action ()) -closeCommand     = Described "close a door"      (checkCursor (openclose False))-openCommand      = Described "open a door (or bump into a door)"       (checkCursor (openclose True))+closeCommand, pickupCommand, dropCommand, inventoryCommand, ascendCommand, descendCommand, floorCommand, monsterCommand, quaffCommand, readCommand, throwCommand, aimCommand, saveCommand, quitCommand, cancelCommand, historyCommand, dumpCommand, heroCommand, versionCommand :: Described (Action ())+closeCommand     = Described "close a door"      (checkCursor closeDoor) 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 (or bump)" (checkCursor search)-ascendCommand    = Described "ascend a level"    (lvlChange Up)-descendCommand   = Described "descend a level"   (lvlChange Down)+ascendCommand    = Described "ascend a level"    (lvlGoUp True)+descendCommand   = Described "descend a level"   (lvlGoUp False) 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) +acceptCommand :: Action () -> Described (Action ())+acceptCommand h  = Described "accept choice"     (acceptCurrent h)++moveDirCommand, runDirCommand :: Described (Dir -> Action ()) moveDirCommand   = Described "move in direction" move runDirCommand    = Described "run in direction"  run
src/Config.hs view
@@ -1,14 +1,9 @@ module Config- (CP, defaultCP, config, getOption, getItems, get, getFile, dump) where+ (CP, defaultCP, config, getOption, getItems, get, getFile, set, dump) where  import System.Directory import System.FilePath-import System.IO-import Control.Monad.Error- import qualified Data.ConfigFile as CF-import Data.Either.Utils-import Data.Maybe import qualified Data.Binary as Binary  import qualified ConfigDefault@@ -16,7 +11,7 @@ newtype CP = CP CF.ConfigParser  instance Binary.Binary CP where-  put (CP config) = Binary.put $ CF.to_string config+  put (CP conf) = Binary.put $ CF.to_string conf   get = do     string <- Binary.get     -- use config in case savegame is from older version and lacks some options@@ -24,8 +19,12 @@     return $ toCP $ forceEither c  instance Show CP where-  show (CP config) = show $ CF.to_string config+  show (CP conf) = show $ CF.to_string conf +forceEither :: Show a => Either a b -> b+forceEither (Left a)  = error (show a)+forceEither (Right b) = b+ -- | Switches all names to case sensitive (unlike by default in ConfigFile). toSensitive :: CF.ConfigParser -> CF.ConfigParser toSensitive cp = cp {CF.optionxform = id}@@ -33,7 +32,7 @@ -- | The default configuration taken from the default configuration file -- included via CPP in ConfigDefault.hs. defCF :: CF.ConfigParser-defCF  =+defCF =   let c = CF.readstring CF.emptyCP ConfigDefault.configDefault   in  toSensitive $ forceEither c @@ -61,7 +60,7 @@     f <- file     b <- doesFileExist f     if not b-      then return $ toCP $ defCF+      then return $ toCP defCF       else do         c <- CF.readfile defCF f         return $ toCP $ forceEither c@@ -70,44 +69,50 @@ -- with simple error reporting (no error is caught and hidden). -- If there is no config file or no such option, gives Nothing. getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a-getOption (CP config) s o =-  if CF.has_option config s o-  then Just $ forceEither $ CF.get config s o+getOption (CP conf) s o =+  if CF.has_option conf s o+  then Just $ forceEither $ CF.get conf s o   else Nothing --- | A simplified access to an option in a given section.+-- | 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+get (CP conf) s o =+  if CF.has_option conf s o+  then forceEither $ CF.get conf s o+  else error $ "Unknown config option: " ++ s ++ "." ++ o +-- | Simplified setting of an option in a given section. Overwriting forbidden.+set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP+set (CP conf) s o v =+  if CF.has_option conf s o+  then error $ "Overwritten config option: " ++ s ++ "." ++ o+  else CP $ forceEither $ CF.set conf s o v+ -- | 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+getItems (CP conf) s =+  if CF.has_section conf s+  then forceEither $ CF.items conf s+  else error $ "Unknown config section: " ++ s  -- | Looks up a file path in the config file and makes it absolute. -- If the game's configuration directory exists, -- the 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 =+getFile conf s o =   do     current <- getCurrentDirectory     appData <- getAppUserDataDirectory "Allure"-    let path    = get config s o+    let path    = get conf 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+dump fn (CP conf) = do+  current <- getCurrentDirectory+  let path  = combine current fn+      sdump = CF.to_string conf+  writeFile path sdump
src/ConfigDefault.hs view
@@ -2,7 +2,7 @@  module ConfigDefault (configDefault) where -import Multiline+import Utils.Multiline  -- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?) -- as soon as the config file grows very big.@@ -12,8 +12,16 @@ -- 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|+configDefault = [multiline| +#ifdef STD++#include "config.bot"++#else+ #include "config.default"++#endif  |]
+ src/Content/ActorKind.hs view
@@ -0,0 +1,79 @@+module Content.ActorKind (ActorKind(..)) where++import Color+import qualified Content.Content+import qualified Geometry+import qualified Random++-- | Monster properties that are changing rarely and permanently.+data ActorKind = ActorKind+  { ahp     :: !Random.RollDice  -- ^ encodes initial and maximal hp+  , aspeed  :: !Geometry.Time    -- ^ natural speed+  , asymbol :: !Char             -- ^ map symbol+  , acolor  :: !Color            -- ^ map color+  , aname   :: !String           -- ^ name+  , asight  :: !Bool             -- ^ can it see?+  , asmell  :: !Bool             -- ^ can it smell?+  , aiq     :: !Int              -- ^ intelligence+  , aregen  :: !Int              -- ^ regeneration interval+  , afreq   :: !Int              -- ^ dungeon frequency+  }+  deriving (Show, Eq, Ord)++instance Content.Content.Content ActorKind where+  getFreq = afreq+  content =+    [hero, eye, fastEye, nose]++hero,      eye, fastEye, nose :: ActorKind++hero = ActorKind+  { ahp     = (50, 1)+  , aspeed  = 10+  , asymbol = '@'+  , aname   = "hero"+  , acolor  = BrWhite  -- Heroes white, monsters colorful.+  , asight  = True+  , asmell  = False+  , aiq     = 13  -- Can see secret doors, when he is under alien control.+  , aregen  = 1500+  , afreq   = 0  -- Does not appear randomly in the dungeon.++  }++eye = ActorKind+  { ahp     = (1, 12)  -- falls in 1--4 unarmed rounds+  , aspeed  = 10+  , asymbol = 'e'+  , acolor  = BrRed+  , aname   = "the reducible eye"+  , asight  = True+  , asmell  = False+  , aiq     = 8+  , aregen  = 1500+  , afreq   = 6+  }+fastEye = ActorKind+  { ahp     = (1, 6)  -- falls in 1--2 unarmed rounds+  , aspeed  = 4+  , asymbol = 'e'+  , acolor  = BrBlue+  , aname   = "the super-fast eye"+  , asight  = True+  , asmell  = False+  , aiq     = 12+  , aregen  = 1500+  , afreq   = 1+  }+nose = ActorKind+  { ahp     = (6, 2)  -- 2--5 and in 1 round of the strongest sword+  , aspeed  = 11+  , asymbol = 'n'+  , acolor  = Green+  , aname   = "the point-free nose"+  , asight  = False+  , asmell  = True+  , aiq     = 0+  , aregen  = 1500+  , afreq   = 2+  }
+ src/Content/CaveKind.hs view
@@ -0,0 +1,73 @@+module Content.CaveKind (CaveKind(..), CaveLayout(..)) where++import Data.Ratio++import qualified Content.Content+import Geometry+import Random++instance Content.Content.Content CaveKind where+  getFreq = cfreq+  content =+    [rogue, empty, noise, largeNoise]++rogue,      empty, noise, largeNoise:: CaveKind++data CaveKind = CaveKind+  { cxsize            :: X+  , cysize            :: Y+  , levelGrid         :: Rnd (X, Y)+  , minRoomSize       :: Rnd (X ,Y)+  , darkRoomChance    :: Int -> Rnd Bool  -- TODO: use RollQuad instead, etc.+  , border            :: Int         -- must be at least 2!+  , extraConnects     :: (X, Y) -> Int+      -- relative to grid (in fact a range, because of duplicate connects)+  , noRooms           :: (X, Y) -> Rnd Int+      -- range, relative to grid+  , minStairsDistance :: Int+  , doorChance        :: Rnd Bool+  , doorOpenChance    :: Rnd Bool+  , doorSecretChance  :: Rnd Bool+  , csecretStrength   :: RollDice+  , citemNum          :: RollDice+  , clayout           :: CaveLayout+  , cfreq             :: Int+  }++-- TODO: express those using many fine-graned parameters instead+data CaveLayout = CaveRogue | CaveEmpty | CaveNoise deriving Eq++rogue = CaveKind+  { cxsize            = fst normalLevelBound + 1+  , cysize            = snd normalLevelBound + 1+  , levelGrid         = do+                          x <- Random.randomR (3, 5)+                          y <- Random.randomR (2, 4)+                          return (x, y)+  , minRoomSize       = return (2, 2)+  , darkRoomChance    = \ d -> Random.chance $ 1%((22 - (2 * fromIntegral d)) `max` 2)+  , border            = 2+  , extraConnects     = \ (x, y) -> (x * y) `div` 3+  , noRooms           = \ (x, y) -> Random.randomR (0, (x * y) `div` 3)+  , minStairsDistance = 30+  , doorChance        = Random.chance $ 2%3+  , doorOpenChance    = Random.chance $ 1%10+  , doorSecretChance  = Random.chance $ 1%4+  , csecretStrength   = (7, 2)+  , citemNum          = (5, 2)+  , clayout           = CaveRogue+  , cfreq             = 80+  }+empty = rogue+  { clayout           = CaveEmpty+  , cfreq             = 20+  }+noise = rogue+  { clayout           = CaveNoise+  , cfreq             = 0  -- stairs may be blocked, so only for the last level+  }+largeNoise = noise+  { cxsize            = 231+  , cysize            = 77+  , cfreq             = 0  -- experimental+  }
+ src/Content/Content.hs view
@@ -0,0 +1,16 @@+module Content.Content (Content(..)) where++import qualified Data.List as L+import qualified Data.IntMap as IM+import qualified Data.Word as Word++class Content a where+  getFreq :: a -> Int++  content :: [a]++  kindAssocs :: [(Word.Word8, a)]+  kindAssocs = L.zip [0..] content++  kindMap :: IM.IntMap a+  kindMap = IM.fromDistinctAscList $ L.zip [0..] content
+ src/Content/ItemKind.hs view
@@ -0,0 +1,153 @@+module Content.ItemKind (ItemKind(..)) where++import Color+import qualified Content.Content+import Effect+import Flavour+import Random++-- 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+  { isymbol  :: !Char       -- ^ map symbol+  , iflavour :: ![Flavour]  -- ^ possible flavours+  , iname    :: !String     -- ^ group name+  , ieffect  :: !Effect     -- ^ the effect when activated+  , icount   :: !RollQuad   -- ^ created in that quantify+  , ifreq    :: !Int        -- ^ created that often+  , ipower   :: !RollQuad   -- ^ created with that power+  }+  deriving (Show, Eq, Ord)++instance Content.Content.Content ItemKind where+  getFreq = ifreq+  content =+    [amulet, dart, gem1, gem2, gem3, gem4, gold, potion1, potion2, potion3, ring, scroll1, scroll2, sword, fist, wand]++amulet,      dart, gem1, gem2, gem3, gem4, gold, potion1, potion2, potion3, ring, scroll1, scroll2, sword, fist, wand :: ItemKind++gem, potion, scroll :: ItemKind  -- generic templates++-- rollQuad (a, b, x, y) = a * roll b + (lvl * x * roll y) / 10++amulet = ItemKind+  { isymbol  = '"'+  , iflavour = [(BrGreen, True)]+  , iname    = "amulet"+  , ieffect  = Regneration+  , icount   = intToQuad 1+  , ifreq    = 10+  , ipower   = (2, 1, 2, 2)+  }+dart = ItemKind+  { isymbol  = ')'+  , iflavour = [(Yellow, False)]+  , iname    = "dart"+  , ieffect  = Wound (1, 1)+  , icount   = (3, 3, 0, 0)+  , ifreq    = 30+  , ipower   = intToQuad 0+  }+gem = ItemKind+  { isymbol  = '*'+  , iflavour = zipPlain brightCol  -- natural, so not fancy+  , iname    = "gem"+  , ieffect  = NoEffect+  , icount   = intToQuad 0+  , ifreq    = 20  -- x4, but rare on shallow levels+  , ipower   = intToQuad 0+  }+gem1 = gem+  { icount   = (1, 1, 0, 0)  -- appears on lvl 1+  }+gem2 = gem+  { icount   = (0, 0, 2, 1)  -- appears on lvl 5, doubled on lvl 10+  }+gem3 = gem+  { icount   = (0, 0, 1, 1)  -- appears on lvl 10+  }+gem4 = gem+  { icount   = (0, 0, 1, 1)  -- appears on lvl 10+  }+gold = ItemKind+  { isymbol  = '$'+  , iflavour = [(BrYellow, False)]+  , iname    = "gold piece"+  , ieffect  = NoEffect+  , icount   = (0, 0, 10, 10)+  , ifreq    = 80+  , ipower   = intToQuad 0+  }+potion = ItemKind+  { isymbol  = '!'+  , iflavour = zipFancy stdCol+  , iname    = "potion"+  , ieffect  = NoEffect+  , icount   = intToQuad 1+  , ifreq    = 10+  , ipower   = intToQuad 0+  }+potion1 = potion+  { ieffect  = ApplyPerfume+  }+potion2 = potion+  { ieffect  = Heal+  , ipower   = (10, 1, 0, 0)+  }+potion3 = potion+  { ieffect  = Wound (0, 0)+  , ipower   = (10, 1, 0, 0)+  }+ring = ItemKind+  { isymbol  = '='+  , iflavour = [(White, False)]+  , iname    = "ring"+  , ieffect  = Searching+  , icount   = intToQuad 1+  , ifreq    = 10+  , ipower   = (1, 1, 2, 2)+  }+scroll = ItemKind+  { isymbol  = '?'+  , iflavour = zipFancy darkCol  -- arcane and old+  , iname    = "scroll"+  , ieffect  = NoEffect+  , icount   = intToQuad 1+  , ifreq    = 10+  , ipower   = intToQuad 0+  }+scroll1 = scroll+  { ieffect  = SummonFriend+  , ifreq    = 20+  }+scroll2 = scroll+  { ieffect  = SummonEnemy+  }+sword = ItemKind+  { isymbol  = ')'+  , iflavour = [(BrCyan, False)]+  , iname    = "sword"+  , ieffect  = Wound (3, 1)+  , icount   = intToQuad 1+  , ifreq    = 60+  , ipower   = (1, 2, 4, 2)+  }+fist = sword+  { iname    = "fist"+  , ifreq    = 0  -- Does not appear randomly in the dungeon.+  }+wand = ItemKind+  { isymbol  = '/'+  , iflavour = [(BrRed, True)]+  , iname    = "wand"+  , ieffect  = Dominate+  , icount   = intToQuad 1+  , ifreq    = 10+  , ipower   = intToQuad 0+  }
+ src/Content/TileKind.hs view
@@ -0,0 +1,110 @@+module Content.TileKind (TileKind(..)) where++import Color+import qualified Content.Content+import qualified Effect+import Feature++data TileKind = TileKind+  { tsymbol  :: !Char       -- ^ map symbol+  , tname    :: !String     -- ^ name+  , tcolor   :: !Color      -- ^ map color+  , tcolor2  :: !Color      -- ^ map color when not in FOV+  , tfreq    :: !Int        -- ^ created that often (within a group?)+  , tfeature :: ![Feature]  -- ^ properties+  }+  deriving (Show, Eq, Ord)++instance Content.Content.Content TileKind where+  getFreq = tfreq+  content =+    [wall, doorOpen, doorClosed, doorSecret, opening, floorLight, floorDark, stairsUp, stairsDown, unknown]++wall,      doorOpen, doorClosed, doorSecret, opening, floorLight, floorDark, stairsUp, stairsDown, unknown :: TileKind++wall = TileKind+  { tsymbol  = '#'+  , tname    = "A wall."+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = []+  }++doorOpen = TileKind+  { tsymbol  = '\''+  , tname    = "An open door."+  , tcolor   = Yellow+  , tcolor2  = BrBlack+  , tfreq    = 100+  , tfeature = [Walkable, Clear, Exit{-TODO:, Lit-}, Change '+', Closable]+  }++doorClosed = TileKind+  { tsymbol  = '+'+  , tname    = "A closed door."+  , tcolor   = Yellow+  , tcolor2  = BrBlack+  , tfreq    = 100+  , tfeature = [Exit, Change '\'', Openable]+  }++doorSecret = wall+  { tfeature = [Hidden, Change '+', Secret (7, 2)]+  }++opening = TileKind+  { tsymbol  = '.'+  , tname    = "An opening."+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = [Walkable, Clear, Exit{-TODO: , Lit-}]+  }++floorLight = TileKind+  { tsymbol  = '.'+  , tname    = "Floor."+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = [Walkable, Clear, Lit]+  }++floorDark = TileKind+  { tsymbol  = '.'+  , tname    = "Floor."+  , tcolor   = BrYellow+  , tcolor2  = BrBlack+  , tfreq    = 100+  , tfeature = [Walkable, Clear]+  }++stairsUp = TileKind+  { tsymbol  = '<'+  , tname    = "A staircase up."+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = [Walkable, Clear, Exit, Lit,+                Climbable, Cause Effect.Teleport]+  }++stairsDown = TileKind+  { tsymbol  = '>'+  , tname    = "A staircase down."+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = [Walkable, Clear, Exit, Lit,+                Descendable, Cause Effect.Teleport]+  }++unknown = TileKind+  { tsymbol  = ' '+  , tname    = ""+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfreq    = 100+  , tfeature = []+  }
+ src/Dir.hs view
@@ -0,0 +1,77 @@+module Dir+  ( Dir, dirDistSq, diagonal, neg, moves, shift, towards ) where++import Data.Binary++import Geometry+import Loc+import Utils.Assert++-- Vectors of length 1 (in our metric), that is, geographical directions.+-- Implemented as an offset in the linear framebuffer indexed by Loc.+-- A newtype to prevent mixing up with Loc itself.+-- Level X size has to be > 1 for the @moves@ vectors to make sense.+newtype Dir = Dir Int deriving (Show, Eq)++instance Binary Dir where+  put (Dir dir) = put dir+  get = fmap Dir get++toDir :: X -> (X, Y) -> Dir+toDir lxsize (x, y) =+  assert (lxsize > 1 && lenXY (x, y) == 1 `blame` (lxsize, (x, y))) $+  Dir $ x + y * lxsize++fromDir :: X -> Dir -> (X, Y)+fromDir lxsize (Dir dir) =+  assert (lenXY res == 1 && fst res + snd res * lxsize == dir+          `blame` (lxsize, dir, res)) $+  res+ where+   (x, y) = (dir `mod` lxsize, dir `div` lxsize)+   -- Pick the vector's canonical form of length 1:+   res = if x > 1+         then (x - lxsize, y + 1)+         else (x, y)++-- | Squared euclidean distance between two directions.+dirDistSq :: X -> Dir -> Dir -> Int+dirDistSq lxsize dir0 dir1+  | (x0, y0) <- fromDir lxsize dir0, (x1, y1) <- fromDir lxsize dir1 =+  euclidLenSq ((y1 - y0), (x1 - x0))++diagonal :: X -> Dir -> Bool+diagonal lxsize dir | (x, y) <- fromDir lxsize dir =+  x * y /= 0++-- | Invert a direction (vector).+neg :: Dir -> Dir+neg (Dir dir) = Dir (-dir)++-- | Directions of all unit moves, clockwise, starting north-west.+moves :: X -> [Dir]+moves lxsize = map (toDir lxsize) movesXY++-- | Move one square in the given direction.+-- Particularly simple in the linear representation.+shift :: Loc -> Dir -> Loc+shift loc (Dir dir) = loc + dir++-- | Given two distinct locations, determine the direction in which one should+-- move from the first in order to get closer to the second. Does not+-- pay attention to obstacles at all.+towards :: X -> Loc -> Loc -> Dir+towards lxsize loc0 loc1+  | (x0, y0) <- fromLoc lxsize loc0, (x1, y1) <- fromLoc lxsize loc1 =+  assert (loc0 /= loc1 `blame` (loc0, loc1, x0, y0)) $+  let dx = x1 - x0+      dy = y1 - y0+      angle :: Double+      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)+      dxy | angle <= -0.75 = (0, -1)+          | angle <= -0.25 = (1, -1)+          | angle <= 0.25  = (1, 0)+          | angle <= 0.75  = (1, 1)+          | angle <= 1.25  = (0, 1)+          | otherwise = assert `failure` (lxsize, loc0, loc1, (x0, y0), (x1, y1))+  in if dx >= 0 then toDir lxsize dxy else neg (toDir lxsize dxy)
src/Display.hs view
@@ -6,44 +6,54 @@  #ifdef CURSES import qualified Display.Curses as D-#elif GTK-import qualified Display.Gtk as D-#else+#elif VTY import qualified Display.Vty as D+#elif STD+import qualified Display.Std as D+#else+import qualified Display.Gtk 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.Set as S+import qualified Data.List as L+import qualified 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 Control.Monad.IO.Class import Data.Maybe  import Message import qualified Color import State import Geometry+import Loc+import Area import Level-import LevelState-import Dungeon import Perception-import Movable-import MovableState-import MovableKind+import Actor+import ActorState+import Content.ActorKind+import Content.TileKind import Item import qualified Keys as K import WorldLoc+import Random+import qualified Kind  -- 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 -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO () display area = D.display area . fst+startup :: (InternalSession -> IO ()) -> IO () startup = D.startup+shutdown :: Session -> IO () shutdown = D.shutdown . fst+displayId :: String displayId = D.displayId  -- | Next event translated to a canonical form.@@ -51,18 +61,16 @@ nextCommand session =   do     e <- liftIO $ D.nextEvent (fst session)-    return $-      case M.lookup e (snd session) of-        Just key -> key-        Nothing  -> K.canonMoveKey e+    return $ fromMaybe (K.canonMoveKey e) (M.lookup e (snd session))  -- | 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, ' ')+      (lx, ly) = normalLevelBound  -- TODO: query terminal size instead   in do-       display ((0, 0), normalLevelSize) session doBlank x ""+       display (0, 0, lx, ly) session doBlank x ""        getConfirm session  -- | Waits for a space or return or '?' or '*'. The last two act this way,@@ -107,97 +115,107 @@ -- 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 :: Y -> String -> (Int, (X, Y) -> 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)+    (k, \ (x, y) -> M.lookup y m >>= \ n -> M.lookup x n) +data ColorMode = ColorFull | ColorBW+ displayLevel ::-  Bool -> Session -> Perceptions -> State -> Message -> Maybe String -> IO Bool-displayLevel-  blackAndWhite session per-  (state@(State { scursor = cursor,-                  stime   = time,-                  sassocs = assocs,-                  slevel  = Level ln _ (sy, sx) _ smap lmap _ }))-  msg moverlay =-  let Movable { mkind = MovableKind { nhpMax = xhp },-                mhp = php, mloc = ploc, mitems = pitems } = getPlayerBody state+  ColorMode -> Session -> Perceptions -> State -> Message -> Maybe String+  -> IO Bool+displayLevel dm session per+             state@State{scursor, stime, sflavour, slid} msg moverlay =+  let lvl@Level{lxsize = sx, lysize = sy, lsmell = smap} = slevel state+      Actor{bkind, bhp, bloc, bitems} = getPlayerBody state+      ActorKind{ahp} = Kind.getKind bkind       reachable = ptreachable per       visible   = ptvisible per       overlay   = fromMaybe "" moverlay-      (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed+      (ns, over) = stringByLocation sy overlay -- n overlay screens needed       sSml   = ssensory state == Smell       sVis   = case ssensory state of Vision _ -> True; _ -> False       sOmn   = sdisplay state == Omniscient       lAt    = if sOmn then at else rememberAt+      liAt   = if sOmn then iat else irememberAt       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+                else \ _vis _rea -> Color.defBG+      wealth  = L.sum $ L.map itemPrice bitems+      damage  = case strongestItem bitems "sword" of+                  Just sw -> 3 + jpower sw                   Nothing -> 3       hs      = levelHeroList state       ms      = levelMonsterList state-      dis n loc =-        let tile = lmap `lAt` loc-            sml  = ((smap ! loc) - time) `div` 100-            viewMovable loc (Movable { mkind = mk })-              | loc == ploc && ln == creturnLn cursor =-                  (nsymbol mk, Color.defBG)  -- highlight player-              | otherwise = (nsymbol mk, ncolor mk)+      dis n loc0 =+        let tile = lvl `lAt` loc0+            items = lvl `liAt` loc0+            sm = smelltime $ IM.findWithDefault (SmellTime 0) loc0 smap+            sml = (sm - stime) `div` 100+            viewActor loc Actor{bkind = bkind2, bsymbol}+              | loc == bloc && slid == creturnLn scursor =+                  (symbol, Color.defBG)  -- highlight player+              | otherwise = (symbol, acolor)+              where+                ActorKind{asymbol, acolor} = Kind.getKind bkind2+                symbol = fromMaybe asymbol bsymbol             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 == mloc m) (hs ++ ms) of-                Just m | sOmn || vis -> viewMovable 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+            viewSmell k+              | k > 9     = '*'+              | k < 0     = '-'+              | otherwise = Char.intToDigit k+            rainbow loc = toEnum $ loc `rem` 14 + 1+            (char, fg0) =+              case L.find (\ m -> loc0 == Actor.bloc m) (hs ++ ms) of+                Just m | sOmn || vis -> viewActor loc0 m+                _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc0)+                  | otherwise ->+                  case items of+                    [] ->+                      let u = Kind.getKind tile+                      in (tsymbol u, if vis then tcolor u else tcolor2 u)+                    i : _ ->+                      Item.viewItem (jkind i) sflavour+            vis = S.member loc0 visible+            rea = S.member loc0 reachable+            bg0 = if ctargeting scursor && loc0 == clocation scursor+                  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+              if (fg == Color.defBG) || (bg == Color.defFG && fg == Color.defFG)               then reverseVideo-              else if bg == Color.defFG && fg == Color.defFG-                   then reverseVideo-                   else (fg, bg)-            a = if blackAndWhite-                then Color.defaultAttr-                else optVisually (fg, bg)-        in case over (loc `shift` ((sy+1) * n, 0)) of+              else (fg, bg)+            a = case dm of+                  ColorBW   -> Color.defaultAttr+                  ColorFull -> optVisually (fg0, bg0)+        in case over (fromLoc sx loc0 `shiftXY` (0, sy * n)) of              Just c -> (Color.defaultAttr, c)              _      -> (a, char)       status =-        take 30 (levelName ln ++ repeat ' ') ++-        take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') +++        take 30 (levelName slid ++ repeat ' ') +++        take 10 ("T: " ++ show (stime `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+        take 20 ("HP: " ++ show bhp +++                 " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ')+      disp n mesg = display (0, 0, sx - 1, sy - 1) session (dis n) mesg 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 ->+      perf k (x:xs) = disp ns (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+        | k < ns - 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,35 +1,35 @@ module Display.Curses   (displayId, startup, shutdown, display, nextEvent, Session) where -import UI.HSCurses.Curses as C+import qualified 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.Char8 as BS+import qualified Data.List as L+import qualified Data.Map as M import Control.Monad -import Geometry+import Area+import Loc import qualified Keys as K (Key(..)) import qualified Color +displayId :: String displayId = "curses" -data Session =-  Session-    { win :: Window,-      styles :: Map (Color.Color, Color.Color) C.CursesStyle }+data Session = Session+  { win :: C.Window+  , styles :: M.Map (Color.Color, Color.Color) C.CursesStyle+  }  startup :: (Session -> IO ()) -> IO () startup k =   do     C.start-    cursSet CursorInvisible+    C.cursSet C.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+    nr <- C.colorPairs     when (nr < L.length s) $       C.end >>       error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")@@ -39,23 +39,24 @@     k (Session C.stdScr styleMap)  shutdown :: Session -> IO ()-shutdown w = C.end+shutdown _ = C.end  display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String            -> IO ()-display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =+display (x0, y0, x1, y1) (Session { win = w, styles = s }) f msg status =   do     -- let defaultStyle = C.defaultCursesStyle     -- Terminals with white background require this:-    let defaultStyle = s ! Color.defaultAttr+    let defaultStyle = s M.! 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+    C.mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg)  -- TODO: BS as in vty+    C.mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status)+    sequence_ [ C.setStyle (M.findWithDefault defaultStyle a s)+                >> C.mvWAddStr w (y + 1) x [c]+              | x <- [x0..x1], y <- [y0..y1],+                let (a, c) = f (toLoc (x1 + 1) (x, y)) ]+    C.refresh  toWidth :: Int -> String -> String toWidth n x = take n (x ++ repeat ' ')@@ -72,7 +73,9 @@     C.KeyUp          -> K.Up     C.KeyDown        -> K.Down     C.KeyLeft        -> K.Left+    C.KeySLeft       -> K.Left     C.KeyRight       -> K.Right+    C.KeySRight      -> K.Right     C.KeyHome        -> K.Home     C.KeyPPage       -> K.PgUp     C.KeyEnd         -> K.End@@ -80,17 +83,17 @@     C.KeyBeg         -> K.Begin     C.KeyB2          -> K.Begin     C.KeyClear       -> K.Begin-    -- No KP_ keys in hscurses and they do not seem actively maintained.-    -- For now, movement keys are more important than hero selection:+    -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10+    -- Movement keys are more important than hero selection, so preferring them:     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 =+nextEvent _session =   do-    e <- C.getKey refresh+    e <- C.getKey C.refresh     return (keyTranslate e) --    case keyTranslate e of --      Unknown _ -> nextEvent session
src/Display/Gtk.hs view
@@ -1,27 +1,29 @@ module Display.Gtk   (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-import Data.List as L+import qualified Data.List as L import Data.IORef-import Data.Map as M+import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS +import Area+import Loc import Geometry import qualified Keys as K (Key(..), keyTranslate) import qualified Color +displayId :: String displayId = "gtk" -data Session =-  Session {-    schan :: Chan String,-    stags :: Map Color.Attr TextTag,-    sview :: TextView }+data Session = Session+  { schan :: Chan String+  , stags :: M.Map Color.Attr TextTag+  , sview :: TextView+  }  startup :: (Session -> IO ()) -> IO () startup k =@@ -60,12 +62,12 @@                                Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } ->                                  do                                    fsd <- fontSelectionDialogNew "Choose font"-                                   cf <- readIORef currentfont-                                   fd <- fontDescriptionToString cf-                                   fontSelectionDialogSetFontName fsd fd+                                   cf  <- readIORef currentfont+                                   fds <- fontDescriptionToString cf+                                   fontSelectionDialogSetFontName fsd fds                                    fontSelectionDialogSetPreviewText fsd "+##@##-...|"-                                   response <- dialogRun fsd-                                   when (response == ResponseOk) $+                                   resp <- dialogRun fsd+                                   when (resp == ResponseOk) $                                      do                                        fn <- fontSelectionDialogGetFontName fsd                                        case fn of@@ -79,29 +81,33 @@                                _ -> return False)      let black = Color minBound minBound minBound  -- Color.defBG == Color.Black-        white = Color 0xAAAA 0xAAAA 0xAAAA        -- Color.defFG == Color.White+        white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White     widgetModifyBase tv StateNormal black     widgetModifyText tv StateNormal white      ec <- newChan     forkIO $ k (Session ec tts tv) -    onKeyPress tv (\ e -> postGUIAsync (writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)) >> return True)+    onKeyPress tv+      (\ e -> do+          writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)+          return True)      onDestroy w mainQuit -- set quit handler     widgetShowAll w     yield     mainGUI +shutdown :: Session -> IO () shutdown _ = mainQuit  display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String            -> IO ()-display ((y0,x0), (y1,x1)) session f msg status =-  postGUIAsync $-  do+display (x0, y0, x1, y1) session f msg status =+  postGUIAsync $ do     tb <- textViewGetBuffer (sview session)-    let fLine y = let (as, cs) = unzip [ f (y, x) | x <- [x0..x1] ]+    let fLine y = let (as, cs) = unzip [ f (toLoc (x1 + 1) (x, y))+                                       | x <- [x0..x1] ]                   in  ((y, as), BS.pack cs)         memo  = L.map fLine [y0..y1]         attrs = L.map fst memo@@ -110,26 +116,27 @@     textBufferSetByteString tb (BS.concat bs)     mapM_ (setTo tb (stags session) x0) attrs -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+setTo :: TextBuffer -> M.Map Color.Attr TextTag -> X -> (Y, [Color.Attr])+         -> IO ()+setTo _  _   _  (_,  [])         = return ()+setTo tb tts lx (ly, attr:attrs) = 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+          textBufferApplyTag tb (tts M.! 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+              textBufferApplyTag tb (tts M.! previous) ib ie             textIterForwardChars ib repetitions             setIter a 1 as-  setIter a 1 as+  setIter attr 1 attrs  -- | reads until a non-dead key encountered readUndeadChan :: Chan String -> IO String
src/Display/Vty.hs view
@@ -1,31 +1,32 @@ module Display.Vty   (displayId, startup, shutdown, display, nextEvent, Session) where -import Graphics.Vty as V-import Data.List as L-import Data.Char+import Graphics.Vty+import qualified Data.List as L import qualified Data.ByteString.Char8 as BS -import Geometry+import Area+import Loc import qualified Keys as K (Key(..)) import qualified Color +displayId :: String displayId = "vty" -type Session = V.Vty+type Session = Vty  startup :: (Session -> IO ()) -> IO ()-startup k = V.mkVty >>= k+startup k = mkVty >>= k  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 (setAttr a) c)))-            [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]-  in  V.update vty (pic_for_image+display (x0, y0, x1, y1) vty f msg status =+  let img = (foldr (<->) empty_image .+             L.map (foldr (<|>) empty_image .+                    L.map (\ (x, y) -> let (a, c) = f (toLoc (x1 + 1) (x, y))+                                       in  char (setAttr a) c)))+            [ [ (x, y) | x <- [x0..x1] ] | y <- [y0..y1] ]+  in  update vty (pic_for_image        (utf8_bytestring (setAttr Color.defaultAttr)         (BS.pack (toWidth (x1 - x0 + 1) msg)) <->         img <->@@ -35,24 +36,24 @@ toWidth :: Int -> String -> String toWidth n x = take n (x ++ repeat ' ') -keyTranslate :: V.Event -> K.Key+keyTranslate :: Event -> K.Key keyTranslate e =   case e of-    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+    EvKey KEsc []          -> K.Esc+    EvKey KEnter []        -> K.Return+    EvKey (KASCII '\t') [] -> K.Tab+    EvKey KUp []           -> K.Up+    EvKey KDown []         -> K.Down+    EvKey KLeft []         -> K.Left+    EvKey KRight []        -> K.Right+    EvKey KHome []         -> K.Home+    EvKey KPageUp []       -> K.PgUp+    EvKey KEnd []          -> K.End+    EvKey KPageDown []     -> K.PgDn+    EvKey KBegin []        -> K.Begin     -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8     -- For now, movement keys are more important than hero selection:-    V.EvKey (KASCII c) []+    EvKey (KASCII c) []       | c `elem` ['1'..'9']  -> K.KP c       | otherwise            -> K.Char c     _                        -> K.Unknown (show e)@@ -60,14 +61,16 @@ nextEvent :: Session -> IO K.Key nextEvent session =   do-    e <- V.next_event session+    e <- next_event session     return (keyTranslate e)  -- 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.--- HCurses does this by default, but vty refuses to get crazy.+-- HSCurses does this by default, but in Vty you have to request the hack.+hack :: Color.Color -> Attr -> Attr hack c a = if Color.isBright c then with_style a bold else a +setAttr :: (Color.Color, Color.Color) -> Attr setAttr (fg, bg) = -- This optimization breaks display for white background terminals: --  if (fg, bg) == Color.defaultAttr
src/Dungeon.hs view
@@ -1,379 +1,35 @@-module Dungeon where--import Prelude hiding (floor)-import Control.Monad-import qualified System.Random as R+module Dungeon (Dungeon, fromList, currentFirst, adjust, (!)) where  import Data.Binary-import Data.Map as M-import Data.List as L-import Data.Ratio-import Data.Maybe+import qualified Data.Map as M+import qualified Data.List as L -import Geometry-import GeometryRnd import Level-import Item-import Random-import qualified Terrain-import qualified ItemKind import WorldLoc-import Tile  -- TODO: qualified  -- | 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 LevelId Level)+newtype Dungeon = Dungeon{dungeonLevelMap :: M.Map LevelId Level}   deriving Show  instance Binary Dungeon where-  put (Dungeon dng) = put (M.elems dng)-  get = liftM dungeon get+  put dng = put (M.assocs (dungeonLevelMap dng))+  get = fmap fromList 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 :: LevelId -> 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---- | Create a random room according to given parameters.-mkRoom :: Int ->      -- ^ border columns-          (Y,X) ->    -- ^ minimum size-          Area ->     -- ^ this is an area, not the room itself-          Rnd Room    -- ^ this is the upper-left and lower-right corner of the room-mkRoom bd (ym,xm) ((y0,x0),(y1,x1)) =-  do-    (ry0,rx0) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd - ym + 1,x1 - bd - xm + 1))-    (ry1,rx1) <- locInArea ((ry0 + ym - 1,rx0 + xm - 1),(y1 - bd,x1 - bd))-    return ((ry0,rx0),(ry1,rx1))---- | Create a no-room, i.e., a single corridor field.-mkNoRoom :: Int ->      -- ^ border columns-            Area ->     -- ^ this is an area, not the room itself-            Rnd Room    -- ^ this is the upper-left and lower-right corner of the room-mkNoRoom bd ((y0,x0),(y1,x1)) =-  do-    (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 -}-mkCorridor hv ((y0,x0),(y1,x1)) b =-  do-    (ry,rx) <- findLocInArea b (const True)-    -- (ry,rx) is intermediate point the path crosses-    -- hv decides whether we start in horizontal or vertical direction-    case hv of-      Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)]-      Vert  -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)]---- | Try to connect two rooms with a corridor.--- The condition passed to mkCorridor is tricky; there might not always--- exist a suitable intermediate point if the rooms are allowed to be close--- together ...-connectRooms :: Area -> Area -> Rnd [Loc]-connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) =-  do-    (sy,sx) <- locInArea sa-    (ty,tx) <- locInArea ta-    let xok = sx1 < tx0 - 3-    let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2))-    let yok = sy1 < ty0 - 3-    let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx))-    let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-2))-    (hv,area) <- if xok && yok then fmap (\ hv -> (hv,xyarea)) (binaryChoice Horiz Vert)-                 else if xok   then return (Horiz,xarea)-                               else return (Vert,yarea)-    mkCorridor hv ((sy,sx),(ty,tx)) area--digCorridors :: Corridor -> LMap-digCorridors (p1:p2:ps) =-  M.union corPos (digCorridors (p2:ps))-  where-    corLoc = fromTo p1 p2-    corPos = M.fromList $ L.zip corLoc (repeat $ newTile Terrain.floorDark)-digCorridors _ = M.empty--mergeCorridor :: (Tile, Tile) -> (Tile, Tile) -> (Tile, Tile)-mergeCorridor _ (Tile t is, u) | Terrain.isRock t    = (Tile Terrain.opening is, u)-mergeCorridor _ (Tile t is, u) | Terrain.isOpening t = (Tile Terrain.opening is, u)-mergeCorridor _ (Tile t is, u) | Terrain.isFloor t   = (Tile t is, u)-mergeCorridor (x, u) _                 = (x, u)---- | Create a new tile.-newTile :: Terrain.Terrain -> (Tile, Tile)-newTile t = (Tile t [], Tile Terrain.unknown [])---- | Create a level consisting of only one room. Optionally, insert some walls.-emptyRoom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig ->-           LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc)-emptyRoom addRocksRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm =-  do-    let lmap = digRoom Terrain.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 emptyParty (sy,sx) emptyParty smap lmap ""-    -- locations of the stairs-    su <- findLoc lvl (const floor)-    sd <- findLoc lvl (\ l t -> floor t-                                && distance (su,l) > minStairsDistance cfg)-    is <- rollItems cfg lvl su-    addRocks <- addRocksRnd lvl-    let addItem lmap (l,it) =-          M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l lmap-        flmap lu ld =-          addRocks $-          maybe id (\ l -> M.insert su (newTile (Terrain.stairs Terrain.Light Up   l))) lu $-          maybe id (\ l -> M.insert sd (newTile (Terrain.stairs Terrain.Light Down l))) ld $-          (\lmap -> L.foldl' addItem lmap is) $-          lmap-        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 ->-           LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc)-bigRoom = emptyRoom (\ lvl -> return id)---- | For a noiseroom level: Create a level consisting of only one room--- with randomly distributed pillars.-noiseRoom :: LevelConfig ->-             LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc)-noiseRoom cfg =-  let addRocks lvl = do-        rs <- rollPillars cfg lvl-        let insertRock lmap l =-              case lmap `at` l of-                Tile t [] | Terrain.isFloor t -> M.insert l (newTile Terrain.rock) lmap-                _ -> lmap-        return $ \ lmap -> L.foldl' insertRock lmap rs-  in  emptyRoom addRocks cfg--data LevelConfig =-  LevelConfig {-    levelGrid         :: Rnd (Y,X),-    minRoomSize       :: Rnd (Y,X),-    darkRoomChance    :: Rnd Bool,-    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-    minStairsDistance :: Int,       -- must not be too large-    doorChance        :: Rnd Bool,-    doorOpenChance    :: Rnd Bool,-    doorSecretChance  :: Rnd Bool,-    doorSecretMax     :: Int,-    nrItems           :: Rnd Int,   -- range-    depth             :: Int        -- general indicator of difficulty-  }--normalLevelSize :: (Y,X)-normalLevelSize = (22,79)--defaultLevelConfig :: Int -> LevelConfig-defaultLevelConfig d =-  LevelConfig {-    levelGrid         = do-                          y <- randomR (2,4)-                          x <- randomR (3,5)-                          return (y,x),-    minRoomSize       = return (2,2),-    darkRoomChance    = chance $ 1%((22 - (2 * fromIntegral d)) `max` 2),-    border            = 2,-    levelSize         = normalLevelSize,-    extraConnects     = \ (y,x) -> (y*x) `div` 3,-    noRooms           = \ (y,x) -> randomR (0,(y*x) `div` 3),-    minStairsDistance = 676,-    doorChance        = chance $ 2%3,-    doorOpenChance    = chance $ 1%10,-    doorSecretChance  = chance $ 1%4,-    doorSecretMax     = 15,-    nrItems           = randomR (5,10),-    depth             = d-  }--largeLevelConfig :: Int -> LevelConfig-largeLevelConfig d =-  (defaultLevelConfig d) {-    levelGrid         = return (7,10),-    levelSize         = (77,231),-    extraConnects     = const 10-  }---- | Create a "normal" dungeon level. Takes a configuration in order--- to tweak all sorts of data.--{--Leve is generated by an algorithm inspired by the original Rogue,-as follows:--  * The available area is divided into a 3 by 3 grid-    where each of the 9 grid cells has approximately the same size.--  * In each of the 9 grid cells one room is placed at a random location.-    The minimum size of a room is 2 by 2 floor tiles. A room is surrounded-    by walls, and the walls still have to fit into the assigned grid cells.--  * Rooms that are on horizontally or vertically adjacent grid cells-    may be connected by a corridor. Corridors consist of 3 segments of straight-    lines (either "horizontal, vertical, horizontal" or "vertical, horizontal,-    vertical"). They end in openings in the walls of the room they connect.-    It is possible that one or two of the 3 segments have length 0, such that-    the resulting corridor is L-shaped or even a single straight line.--  * Corridors are generated randomly in such a way that at least every room-    on the grid is connected, and a few more might be. It is not sufficient-    to always connect all adjacent rooms.--  * Stairs up and down are placed. Stairs are always located in two different-    randomly chosen rooms.--}--rogueRoom :: LevelConfig ->-         LevelId ->-         Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) ->-              Level, Loc, Loc)-rogueRoom cfg nm =-  do-    lgrid    <- levelGrid cfg-    lminroom <- minRoomSize cfg-    let gs = grid lgrid ((0, 0), levelSize cfg)-    -- grid locations of "no-rooms"-    nrnr <- noRooms cfg lgrid-    nr   <- replicateM nrnr (do-                               let (y,x) = lgrid-                               yg <- randomR (0,y-1)-                               xg <- randomR (0,x-1)-                               return (yg,xg))-    rs0 <- mapM (\ (i,r) -> do-                              r' <- if i `elem` nr-                                      then mkNoRoom (border cfg) r-                                      else mkRoom (border cfg) lminroom r-                              return (i,r')) gs-    let rooms :: [(Loc, Loc)]-        rooms = L.map snd rs0-    dlrooms <- (mapM (\ r -> darkRoomChance cfg >>= \ c -> return (r, Terrain.toDL (not c))) rooms) :: Rnd [((Loc, Loc), Terrain.DL)]-    let rs = M.fromList rs0-    connects <- connectGrid lgrid-    addedConnects <- replicateM (extraConnects cfg lgrid) (randomConnection lgrid)-    let allConnects = L.nub (addedConnects ++ connects)-    cs <- mapM-           (\ (p0,p1) -> do-                           let r0 = rs ! p0-                               r1 = rs ! p1-                           connectRooms r0 r1) allConnects-    let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg,-                                           y <- [0..sy], x <- [0..sx] ]-    let lrooms = L.foldr (\ (r, dl) m -> digRoom dl r m) M.empty dlrooms-        lcorridors = M.unions (L.map digCorridors cs)-        lrocks = emptyLMap (levelSize cfg)-        lmap = M.union (M.unionWith mergeCorridor lcorridors lrooms) lrocks-    let lvl = Level nm emptyParty (levelSize cfg) emptyParty smap lmap ""-    -- convert openings into doors-    dlmap <- fmap M.fromList . mapM-                (\ o@((y,x),(t,r)) ->-                  case t of-                    Tile t _ | Terrain.isOpening t ->-                      do-                        -- openings have a certain chance to be doors;-                        -- doors have a certain chance to be open; and-                        -- closed doors have a certain chance to be-                        -- secret-                        rb <- doorChance cfg-                        ro <- doorOpenChance cfg-                        rs <- if ro then return Nothing-                                    else do rsc <- doorSecretChance cfg-                                            fmap Just-                                                 (if rsc then randomR (doorSecretMax cfg `div` 2, doorSecretMax cfg)-                                                         else return 0)-                        if rb-                          then return ((y,x),newTile (Terrain.door rs))-                          else return o-                    _ -> return o) .-                M.toList $ lmap-    -- locations of the stairs-    su <- findLoc lvl (const floor)-    sd <- findLocTry 1000 lvl-            (const floor)-            (\ l t -> distance (su,l) > minStairsDistance cfg)-    -- determine number of items, items and locations for the items-    is <- rollItems cfg lvl su-    -- generate map and level from the data-    let meta = show allConnects-    return (\ lu ld ->-      let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Up   l)) su) lu $-                  maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Down l)) sd) ld $-                  L.foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is-                  dlmap-      in  Level nm emptyParty (levelSize cfg) emptyParty smap flmap meta, su, sd)--rollItems :: LevelConfig -> Level -> Loc -> Rnd [(Loc, Item)]-rollItems cfg lvl ploc =-  do-    nri <- nrItems cfg-    replicateM nri $-      do-        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)-                   (\ l t -> distance (ploc, l) > 400)-               _ -> findLoc lvl (const floor)-        return (l,t)+fromList :: [(LevelId, Level)] -> Dungeon+fromList = Dungeon . M.fromList -rollPillars :: LevelConfig -> Level -> Rnd [Loc]-rollPillars cfg lvl =-  do-    nri <- 100 *~ nrItems cfg-    replicateM nri $-      do-        l <- findLoc lvl (const floor)-        return l+-- | Association list corresponding to the dungeon.+-- Starts at the supplied level id (usually the current level)+-- to try to speed up the searches and keep the dungeon lazy.+currentFirst :: LevelId -> Dungeon -> [(LevelId, Level)]+currentFirst slevel (Dungeon m) =+  (slevel, m M.! slevel)+  : L.filter ((/= slevel) . fst) (M.assocs m) -emptyLMap :: (Y, X) -> LMap-emptyLMap (my, mx) =-  M.fromList [ ((y, x), newTile Terrain.rock) | x <- [0..mx], y <- [0..my] ]+adjust :: (Level -> Level) -> LevelId -> Dungeon -> Dungeon+adjust f ln (Dungeon m) = Dungeon (M.adjust f ln m) --- | If the room has size 1, it is assumed to be a no-room, and a single--- corridor field will be dug instead of a room.-digRoom :: Terrain.DL -> Room -> LMap -> LMap-digRoom dl ((y0, x0), (y1, x1)) l-  | y0 == y1 && x0 == x1 =-  M.insert (y0, x0) (newTile Terrain.floorDark) l-  | otherwise =-  let floorDL = if dl == Terrain.Light then Terrain.floorLight else Terrain.floorDark-      rm =-        [ ((y, x), newTile floorDL) | x <- [x0..x1], y <- [y0..y1] ]-        ++ [ ((y, x), newTile Terrain.rock)-           | x <- [x0-1, x1+1], y <- [y0..y1] ]-        ++ [ ((y, x), newTile Terrain.rock)-           | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]-  in M.unionWith const (M.fromList rm) l+(!) :: Dungeon -> LevelId -> Level+(!) (Dungeon m) slid = m M.! slid
src/DungeonState.hs view
@@ -1,41 +1,145 @@ module DungeonState where -import Data.Map as M+import qualified System.Random as R+import qualified Data.List as L+import qualified Control.Monad.State as MState+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Control.Monad -import Geometry+import Utils.Assert+import Loc import Level-import Dungeon+import qualified Dungeon import Random import qualified Config import WorldLoc+import State+import qualified Feature as F+import qualified Tile+import Content.CaveKind+import Cave+import Content.ItemKind+import qualified Kind+import Item+import Geometry+import Frequency -connect ::-  Maybe (Maybe WorldLoc) ->-  [(Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> 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+listArrayCfg :: Int -> Int -> TileMapXY -> TileMap+listArrayCfg cxsize cysize lmap =+  Kind.listArray (zeroLoc, toLoc cxsize (cxsize - 1, cysize - 1))+    (M.elems $ M.mapKeys (\ (x, y) -> (y, x)) lmap) -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+unknownTileMap :: Int -> Int ->  TileMap+unknownTileMap cxsize cysize =+  Kind.listArray (zeroLoc, toLoc cxsize (cxsize - 1, cysize - 1))+    (repeat Tile.unknownId) -findGenerator config n =+mapToIMap :: X -> M.Map (X, Y) a -> IM.IntMap a+mapToIMap cxsize m =+  IM.fromList $ map (\ (xy, a) -> (toLoc cxsize xy, a)) (M.assocs m)++rollItems :: Int -> CaveKind -> TileMap -> Loc -> Rnd [(Loc, Item)]+rollItems n CaveKind{cxsize, citemNum} lmap ploc =+  do+    nri <- rollDice citemNum+    replicateM nri $+      do+        item <- newItem n+        l <- case iname (Kind.getKind (jkind item)) of+               "sword" ->+                 -- swords generated close to monsters; MUAHAHAHA+                 findLocTry 2000 lmap+                   (const Tile.isBoring)+                   (\ l _ -> distance cxsize ploc l > 30)+               _ -> findLoc lmap+                      (const Tile.isBoring)+        return (l, item)++-- | Create a level from a cave, from a cave kind.+buildLevel :: Cave -> Int -> Int -> Rnd Level+buildLevel Cave{dkind, dsecret, ditem, dmap, dmeta} n depth = do+  let cfg@CaveKind{cxsize, cysize, minStairsDistance} = Kind.getKind dkind+      cmap = listArrayCfg  cxsize cysize dmap+  -- Roll locations of the stairs.+  su <- findLoc cmap (const Tile.isBoring)+  sd <- findLocTry 2000 cmap+          (\ l t -> l /= su && Tile.isBoring t)+          (\ l _ -> distance cxsize su l >= minStairsDistance)+  let stairs =+        [(su, Tile.stairsUpId)]+        ++ if n == depth then [] else [(sd, Tile.stairsDownId)]+      lmap = cmap Kind.// stairs+  is <- rollItems n cfg lmap su+  let itemMap = mapToIMap cxsize ditem `IM.union` IM.fromList is+      litem = IM.map (\ i -> ([i], [])) itemMap+      level = Level+        { lheroes = emptyParty+        , lxsize = cxsize+        , lysize = cysize+        , lmonsters = emptyParty+        , lsmell = IM.empty+        , lsecret = mapToIMap cxsize dsecret+        , litem+        , lmap+        , lrmap = unknownTileMap cxsize cysize+        , lmeta = dmeta+        , lstairs = (su, sd)+        }+  return level++matchGenerator :: Maybe String -> Rnd (Kind.Id CaveKind)+matchGenerator Nothing = do+  (ci, _) <- frequency Kind.frequency+  return ci+matchGenerator (Just "caveRogue") = do+  let freq = filterFreq ((== CaveRogue) . clayout . snd) Kind.frequency+  (ci, _) <- frequency freq+  return ci+matchGenerator (Just "caveEmpty") = do+  let freq = filterFreq ((== CaveEmpty) . clayout . snd) Kind.frequency+  (ci, _) <- frequency freq+  return ci+matchGenerator (Just "caveNoise") =+  return $ Kind.getId (\ cc -> clayout cc == CaveNoise && cxsize cc < 100)+matchGenerator (Just s) =+  error $ "Unknown dungeon generator " ++ s++findGenerator :: Config.CP -> Int -> Int -> Rnd Level+findGenerator config n depth = do   let ln = "LambdaCave_" ++ show n       genName = Config.getOption config "dungeon" ln-  in  matchGenerator n genName (defaultLevelConfig n) (LambdaCave n)+  ci <- matchGenerator genName+  cave <- buildCave n ci+  buildLevel cave n depth  -- | Generate the dungeon for a new game.-generate :: Config.CP -> Rnd (Loc, Level, Dungeon)-generate config = do+generate :: Config.CP -> Rnd (Loc, LevelId, Dungeon.Dungeon)+generate config =   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))+      gen :: R.StdGen -> Int -> (R.StdGen, (LevelId, Level))+      gen g k =+        let (g1, g2) = R.split g+            res = MState.evalState (findGenerator config k depth) g1+        in (g2, (LambdaCave k, res))+      con :: R.StdGen -> ((Loc, LevelId, Dungeon.Dungeon), R.StdGen)+      con g =+        let (gd, levels) = L.mapAccumL gen g [1..depth]+            ploc = fst (lstairs (snd (head levels)))+        in ((ploc, LambdaCave 1, Dungeon.fromList levels), gd)+  in MState.state con++whereTo :: State -> Loc -> Maybe WorldLoc+whereTo state@State{slid, sdungeon} loc =+  let lvl = slevel state+      tile = lvl `at` loc+      k | Tile.hasFeature F.Climbable tile = -1+        | Tile.hasFeature F.Descendable tile = 1+        | otherwise = assert `failure` tile+      n = levelNumber slid+      nln = n + k+      ln = LambdaCave nln+      lvlTrg = sdungeon Dungeon.! ln+  in if (nln < 1)+     then Nothing+     else Just (ln, (if k == 1 then fst else snd) (lstairs lvlTrg))
src/Effect.hs view
@@ -1,19 +1,18 @@ module Effect where  import Random-import WorldLoc  data Effect =     NoEffect-  | Heal            -- healing strength in ipower-  | Wound RollDice  -- base damage, to-dam bonus in ipower+  | Heal             -- healing strength in ipower+  | Wound !RollDice  -- base damage, to-dam bonus in ipower   | Dominate   | SummonFriend   | SummonEnemy   | ApplyPerfume   | Regneration   | Searching-  | Teleport WorldLoc+  | Teleport   deriving (Show, Eq, Ord)  effectToName :: Effect -> String@@ -28,7 +27,7 @@ effectToName ApplyPerfume = "of rose water" effectToName Regneration = "of regeneration" effectToName Searching = "of searching"-effectToName (Teleport _) = "of teleport"+effectToName Teleport = "of teleportation"  -- | 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.@@ -42,4 +41,4 @@ effectToBenefit ApplyPerfume = 0 effectToBenefit Regneration = 0     -- much more benefit from carrying around effectToBenefit Searching = 0       -- AI does not need to search-effectToBenefit (Teleport _) = 0    -- AI does not know when to teleport+effectToBenefit Teleport = 0        -- AI does not know when to teleport
src/EffectAction.hs view
@@ -1,146 +1,141 @@ module EffectAction where  import Control.Monad-import Control.Monad.State hiding (State)+import Control.Monad.State hiding (State, state) import Data.Function-import Data.List as L-import Data.Map as M+import qualified Data.List as L import qualified Data.IntMap as IM-import Data.Maybe-import Data.Set as S+import qualified Data.Set as S import System.Time-import Control.Exception (assert) +import Utils.Assert import Action+import Actor+import ActorState+import Content.ActorKind+import ActorAdd import Display hiding (display)-import Dungeon-import Geometry import Grammar+import Loc import qualified HighScores as H import Item-import qualified ItemKind-import qualified Keys as K+import Content.ItemKind import Level-import LevelState import Message-import Movable-import MovableState-import MovableKind-import MovableAdd import Perception import Random import State import qualified Config-import qualified Save import qualified Effect-import WorldLoc+import qualified Kind  -- 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 -> Actor -> Actor -> Int ->+effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int ->                   Action (Bool, String)-effectToAction Effect.NoEffect source target power = nullEffect-effectToAction Effect.Heal _source target power = do+effectToAction Effect.NoEffect _ _ _ _ = nullEffect+effectToAction Effect.Heal _ _source target power = do+  let bhpMax m = maxDice (ahp $ Kind.getKind $ bkind m)   tm <- gets (getActor target)-  if mhp tm >= nhpMax (mkind tm) || power <= 0+  if bhp tm >= bhpMax tm || power <= 0     then nullEffect     else do       focusIfAHero target-      let upd m = m { mhp = min (nhpMax (mkind m)) (mhp m + power) }-      updateAnyActor target upd-      return (True, subjectMovableVerb (mkind tm) "feel" ++ " better.")-effectToAction (Effect.Wound nDm) source target power = do-  n <- liftIO $ rndToIO $ rollDice nDm-  if (n + power <= 0) then nullEffect else do+      updateAnyActor target (addHp power)  -- TODO: duplicates maxDice, etc.+      return (True, subjectActorVerb tm "feel" ++ " better.")+effectToAction (Effect.Wound nDm) verbosity source target power = do+  n <- rndToAction $ rollDice nDm+  if n + power <= 0 then nullEffect else do     focusIfAHero target     tm <- gets (getActor target)-    let newHP  = mhp tm - n - power+    let newHP  = bhp tm - n - power         killed = newHP <= 0-        msg = if source == target  -- a potion of wounding, etc.-              then subjectMovableVerb (mkind tm) "feel"-                   ++ if killed then " mortally" else ""-                   ++ " wounded."-              else if killed-                   then if isAHero target-                        then ""-                        else subjectMovableVerb (mkind tm) "die" ++ "."-                   else if isAHero target-                        then subjectMovableVerb (mkind tm) "lose"-                             ++ " " ++ show (n + power) ++ "HP."-                        else subjectMovableVerb (mkind tm) "hiss" ++ " in pain."-    updateAnyActor target $ \ m -> m { mhp = newHP }  -- Damage the target.+        msg+          | source == target =  -- a potion of wounding, etc.+            subjectActorVerb tm "feel" +++              if killed then " mortally" else "" ++ " wounded."+          | killed =+            if isAHero target then "" else+              subjectActorVerb tm "die" ++ "."+          | verbosity <= 0 = ""+          | isAHero target =+            subjectActorVerb tm "lose" +++              " " ++ show (n + power) ++ "HP."+          | otherwise = subjectActorVerb tm "hiss" ++ " in pain."+    updateAnyActor target $ \ m -> m { bhp = newHP }  -- Damage the target.     when killed $ do       -- Place the actor's possessions on the map.-      modify (updateLevel (dropItemsAt (mitems tm) (mloc tm)))+      modify (updateLevel (dropItemsAt (bitems tm) (bloc 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 =+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 { mtime = 0})-         stopRunning-         display-         return (True, "")+    selectPlayer target+      >>= assert `trueM` (source, target, "player dominates himself")+    -- Prevent AI from getting a few free moves until new player ready.+    updatePlayerBody (\ m -> m { btime = 0})+    display+    return (True, "")   else nullEffect-effectToAction Effect.SummonFriend source target power = do+effectToAction Effect.SummonFriend _ source target power = do   tm <- gets (getActor target)   if isAHero source-    then summonHeroes (1 + power) (mloc tm)-    else summonMonsters (1 + power) (mloc tm)+    then summonHeroes (1 + power) (bloc tm)+    else summonMonsters (1 + power) (bloc tm)   return (True, "")-effectToAction Effect.SummonEnemy source target power = do+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) (mloc tm)-    else summonMonsters (1 + power) (mloc tm)+    then summonHeroes (1 + power) (bloc tm)+    else summonMonsters (1 + power) (bloc tm)   return (True, "")-effectToAction Effect.ApplyPerfume source target _ =+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) }+    let upd lvl = lvl { lsmell = IM.empty }     modify (updateLevel upd)     return (True, "The fragrance quells all scents in the vicinity.")-effectToAction Effect.Regneration source target power =-  effectToAction Effect.Heal source target power-effectToAction Effect.Searching source target power =+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.")+effectToAction Effect.Teleport _ _ _ _ = nullEffect  -- TODO  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 :: Actor -> Actor -> Item -> Action Bool-itemEffectAction source target item = do-  state <- get-  pl    <- gets splayer-  tm    <- gets (getActor target)-  per   <- currentPerception-  let effect = ItemKind.jeffect $ ItemKind.getIK $ ikind item+itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool+itemEffectAction verbosity source target item = do+  tm  <- gets (getActor target)+  per <- currentPerception+  let effect = ieffect $ Kind.getKind $ jkind item   -- The message describes the target part of the action.-  (b, msg) <- effectToAction effect source target (ipower item)+  (b, msg) <- effectToAction effect verbosity source target (jpower item)   -- Determine how the player perceives the event.   -- TODO: factor it out as a function messageActor   -- and messageActorVerb (incorporating subjectActorVerb).-  if mloc tm `S.member` ptvisible per+  if bloc tm `S.member` ptvisible per      then messageAdd msg-     else if not b-          then return ()  -- Victim is not seen, nothing interestng happens.-          else messageAdd "You hear some noises."+     else unless b $+            -- victim is not seen and but somethig interestng happens+            messageAdd "You hear some noises."   -- If something happens, the item gets identified.   when (b && (isAHero source || isAHero target)) $ discover item   return b@@ -149,75 +144,77 @@ discover :: Item -> Action () discover i = do   state <- get-  let ik = ikind i+  let ik = jkind 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 ++ "."+      kind = Kind.getKind ik+      alreadyIdentified = L.length (iflavour kind) == 1 ||+                          ik `S.member` sdisco state+  unless alreadyIdentified $ do+    modify (updateDiscoveries (S.insert ik))+    state2 <- get+    messageAdd $ msg ++ objectItem state2 i ++ "." --- | Selects a movable for the player, based on the actor.--- Focuses on the hero if level changed. False, if nothing to do.-selectPlayer :: Actor -> Action Bool+-- | 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)+    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 }))-            -- Switch to the level.-            lvlSwitch nln-            -- Set smell display, depending on player capabilities.-            -- This also reset FOV mode.-            modify (\ s -> s { ssensory = if MovableKind.nsmell (mkind pbody)-                                          then Smell-                                          else Implicit })-            -- Announce.-            messageAdd $ subjectMovable (mkind pbody) ++ " selected."-            return True+        when (absentHero actor state) $ abortWith "No such member of the party."+        let (nln, pbody) = findActorAnyLevel actor state+        -- 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.+        modify (\ s -> s{slid = nln})+        -- Set smell display, depending on player capabilities.+        -- This also resets FOV mode.+        modify (\ s -> s { ssensory =+                             if asmell $ Kind.getKind $+                                bkind pbody+                             then Smell+                             else Implicit })+        -- Announce.+        messageAdd $ subjectActor pbody ++ " selected."+        return True -focusIfAHero :: Actor -> Action ()+focusIfAHero :: ActorId -> Action () focusIfAHero target =-  if isAHero target-  then do-    -- Focus on the hero being wounded.+  when (isAHero target) $ 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-  newHeroIndex <- gets (fst . scounter)+  newHeroId <- gets (fst . scounter)   modify (\ state -> iterate (addHero loc) state !! n)-  assertTrue $ selectPlayer (AHero newHeroIndex)+  selectPlayer (AHero newHeroId)+    >>= assert `trueM` (newHeroId, "player summons himself")   -- Display status line for the new hero.   display >> return ()  summonMonsters :: Int -> Loc -> Action () summonMonsters n loc = do-  let fmk = Frequency $ L.zip (L.map nfreq dungeonMonsters) dungeonMonsters-  mk <- liftIO $ rndToIO $ frequency fmk-  modify (\ state -> iterate (addMonster mk (nhpMax mk) loc) state !! n)+  (mk, k) <- rndToAction $ frequency Kind.frequency+  hp <- rndToAction $ rollDice $ ahp k+  modify (\ state ->+           iterate (addMonster mk hp 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.+-- | Remove dead heroes (or dominated monsters), check if game over.+-- For now we only check the selected hero and at current level,+-- but if poison, etc. is implemented, we'd need to check all heroes+-- on any level. checkPartyDeath :: Action () checkPartyDeath =   do@@ -225,9 +222,9 @@     pl     <- gets splayer     pbody  <- gets getPlayerBody     config <- gets sconfig-    when (mhp 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 True $-              subjectMovableVerb (mkind pbody) "die" ++ "."+    when (bhp pbody <= 0) $ do  -- TODO: change to guard? define mzero? Why are the writes to the files performed when I call abort later? That probably breaks the laws of MonadPlus.+      go <- messageMoreConfirm ColorBW $+              subjectActorVerb pbody "die" ++ "."       history  -- Prevent the messages from being repeated.       let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"       if firstDeathEnds@@ -237,10 +234,11 @@                (actor, _nln) : _ -> do                  messageAdd "The survivors carry on."                  -- Remove the dead player.-                 modify (deleteActor pl)+                 modify deletePlayer                  -- At this place the invariant that the player exists fails.                  -- Focus on the new hero (invariant not needed).-                 assertTrue $ selectPlayer actor+                 selectPlayer actor+                   >>= assert `trueM` (pl, actor, "player resurrects")                  -- At this place the invariant is restored again.  -- | End game, showing the ending screens, if requested.@@ -249,9 +247,9 @@   do     when showEndingScreens $ do       state <- get-      ln <- gets (lname . slevel)+      slid <- gets slid       let total = calculateTotal state-          status = H.Killed ln+          status = H.Killed slid       handleScores True status total       messageMore "Let's hope another party can save the day!"     end@@ -259,7 +257,7 @@ -- | Calculate loot's worth for heroes on the current level. calculateTotal :: State -> Int calculateTotal s =-  L.sum $ L.map itemPrice $ L.concatMap mitems (levelHeroList s)+  L.sum $ L.map itemPrice $ L.concatMap bitems (levelHeroList s)  -- | Handle current score and display it with the high scores. Scores -- should not be shown during the game,@@ -268,7 +266,7 @@ -- 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)+  if total == 0   then return False   else do     config  <- gets sconfig@@ -281,48 +279,31 @@     (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 :: LevelId -> 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)+            L.map (\ i -> letterLabel (jletter i) ++ objectItem state i ++ " ")+              ((if sorted then L.sortBy (cmpLetter' `on` jletter) else id) is)   let ovl = inv ++ more-  messageWipeAndSet msg+  messageReset msg   overlay ovl  stopRunning :: Action ()-stopRunning = updatePlayerBody (\ p -> p { mdir = Nothing })+stopRunning = updatePlayerBody (\ p -> p { bdir = Nothing })  -- | Store current message in the history and reset current message. history :: Action () history =   do-    (_, sx) <- gets (lsize . slevel)-    msg     <- resetMessage-    config  <- gets sconfig+    sx     <- gets (lxsize . 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 ++ " ")+        splitS = splitMsg (sx + 1) (msg ++ " ")     unless (L.null msg) $-      modify (updateHistory (take historyMax . (L.reverse split ++)))+      modify (updateHistory (take historyMax . (L.reverse splitS ++)))
src/FOV.hs view
@@ -1,49 +1,58 @@-module FOV where+module FOV (FovMode(..), fullscan) where -import Data.Map as M-import Data.Set as S-import Data.List as L-import Data.Ratio-import Data.Maybe+import qualified Data.Set as S+import qualified Data.List as L  import FOV.Common-import FOV.Digital-import FOV.Permissive-import FOV.Shadow-import Geometry+import qualified FOV.Digital+import qualified FOV.Permissive+import qualified FOV.Shadow+import Loc import Level --- import Debug.Trace-+-- 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.---- The main FOV function.- -- | Perform a full scan for a given location. Returns the locations--- that are currently in the field of view.-fullscan :: FovMode -> Loc -> LMap -> Set Loc-fullscan fovMode loc lmap =+-- that are currently in the field of view. The Field of View+-- algorithm to use is set in the config file.+-- Press a command key in the game to cycle among the algorithms+-- and see a special visualization of their effects..+fullscan :: FovMode -> Loc -> Level -> S.Set Loc+fullscan fovMode loc lvl@Level{lxsize} =   case fovMode of-    Shadow ->         -- shadow casting with infinite range+    Shadow ->  -- shadow casting with infinite range       S.unions $-      L.map (\ tr ->-              scan (tr loc) lmap 1 (0,1)) -- was: scan (tr loc) lmap 0 (0,1); TODO: figure out what difference this makes-      [tr0,tr1,tr2,tr3,tr4,tr5,tr6,tr7]+      L.map (\ tr -> FOV.Shadow.scan tr lvl 1 (0,1))+        [tr0, tr1, tr2, tr3, tr4, tr5, tr6, tr7]     Permissive r  ->  -- permissive with range r       S.unions $-      L.map (\ tr ->-              pscan r (tr loc) lmap 1-                (((B(1, 0), B(0, r+1)), [B(0, 1)]),-                 ((B(0, 1), B(r+1, 0)), [B(1, 0)])))-      [qtr0,qtr1,qtr2,qtr3]-    Digital r    ->  -- digital with range r+      L.map (\ tr -> FOV.Permissive.scan r tr lvl) [qtr0, qtr1, qtr2, qtr3]+    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]-    Blind        ->  -- only feeling out adjacent tiles by touch-      S.empty+      L.map (\ tr -> FOV.Digital.scan r tr lvl) [qtr0, qtr1, qtr2, qtr3]+    Blind ->  -- only feeling out adjacent tiles by touch+      let radius = 1+      in S.unions $+         L.map (\ tr -> FOV.Digital.scan radius tr lvl) [qtr0, qtr1, qtr2, qtr3]+ where+  trL = trLoc lxsize++  -- | The translation, rotation and symmetry functions for octants.+  tr0, tr1, tr2, tr3, tr4, tr5, tr6, tr7 :: (Distance, Progress) -> Loc+  tr0 (p, d) = trL loc (  p,   d)+  tr1 (p, d) = trL loc (- p,   d)+  tr2 (p, d) = trL loc (  p, - d)+  tr3 (p, d) = trL loc (- p, - d)+  tr4 (p, d) = trL loc (  d,   p)+  tr5 (p, d) = trL loc (- d,   p)+  tr6 (p, d) = trL loc (  d, - p)+  tr7 (p, d) = trL loc (- d, - p)++  -- | The translation and rotation functions for quadrants.+  qtr0, qtr1, qtr2, qtr3 :: Bump -> Loc+  qtr0 (B(x, y)) = trL loc (  x, - y)  -- quadrant I+  qtr1 (B(x, y)) = trL loc (  y,   x)  -- II (we rotate counter-clockwise)+  qtr2 (B(x, y)) = trL loc (- x,   y)  -- III+  qtr3 (B(x, y)) = trL loc (- y, - x)  -- IV
src/FOV/Common.hs view
@@ -1,58 +1,60 @@-module FOV.Common where+module FOV.Common+  ( Distance, Progress+  , Bump(..)+  , Line, ConvexHull, Edge, EdgeInterval+  , isClear, divUp, maximal, steeper, addHull+  ) where -import Data.List as L+import qualified Data.List as L  import Geometry+import Loc+import qualified Tile+import Level -type Interval = (Rational, Rational) type Distance = Int type Progress = Int-newtype Bump      = B Loc  deriving (Show)++-- | Rotated and translated coordinates of 2D points, so that the points fit+-- in a single quadrant area (quadrant I for Permissive FOV, hence both+-- coordinates positive, and adjacent diagonal halves of quadrant I and II+-- for Digital FOV, hence y positive).+-- The coordinates are written using the standard mathematical coordinate setup,+-- where quadrant I, with x and y positive, is on the upper right.+newtype Bump = B (X, Y)+  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)+isClear :: Level -> (Bump -> Loc) -> Bump -> Bool+isClear l tr = Tile.isClear . (l `at`) . tr  -- | Integer division, rounding up.-divUp n k = - (-n) `div` k+divUp :: Int -> Int -> Int+divUp n k = (n + k - 1) `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)+maximal gte = L.foldl1' (\ acc e -> if gte e acc then e 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)) =+steeper (B(xf, yf)) (B(x1, y1)) (B(x2, y2)) =   (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 =+addHull gte d l =   case l of-    x:y:zs ->-      if gte x y-      then addHull gte b (y:zs)-      else b : l-    _ -> b : l-+    a:b:cs ->+      if gte a b+      then addHull gte d (b:cs)+      else d : l+    _ -> d : l
src/FOV/Digital.hs view
@@ -1,11 +1,11 @@-module FOV.Digital where+module FOV.Digital (scan) where -import Data.Set as S+import qualified Data.Set as S +import Utils.Assert import FOV.Common-import Geometry+import Loc import Level-import qualified Tile  -- Digital FOV with a given range. @@ -13,75 +13,85 @@ -- 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+-- See https://github.com/Mikolaj/Allure/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+scan :: Distance -> (Bump -> Loc) -> Level -> S.Set Loc+scan r tr l =+  -- the scanned area is a square, which is a sphere in this metric; good+  dscan 1 (((B(1, 0), B(-r, r)),  [B(0, 0)]), ((B(0, 0), B(r+1, r)), [B(1, 0)]))+ where+  dscan :: Distance -> EdgeInterval -> S.Set Loc+  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+    let ps0 = let (n, k) = intersect sl d  -- minimal progress to consider+              in n `div` k+        pe = let (n, k) = intersect el d   -- maximal progress to consider                -- 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))-        | Tile.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+             in -1 + n `divUp` k -      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-        | Tile.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+        inside = S.fromList [tr (B(p, d)) | p <- [ps0..pe]]+        outside+          | d >= r = S.empty+          | isClear l tr (B(ps0, d)) =+              mscan (Just s0) (ps0+1) pe      -- start in light+          | otherwise =+              mscan Nothing (ps0+1) pe        -- start in shadow+    in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $+       S.union inside outside+   where+    mscan :: Maybe Edge -> Progress -> Progress -> S.Set Loc+    mscan (Just s@(_, sBumps)) ps pe+      | ps > pe = dscan (d+1) (s, e)          -- reached end, scan next+      | not $ isClear l tr steepBump =        -- entering shadow+          S.union (dscan (d+1) (s, (dline nep steepBump, neBumps)))+                  (mscan Nothing (ps+1) pe)+      | otherwise = mscan (Just s) (ps+1) pe  -- continue in light+     where+      steepBump = B(ps, d)+      gte = dsteeper steepBump+      nep = maximal gte sBumps+      neBumps = addHull gte steepBump eBumps -      dscan' Nothing ps-        | ps > pe = S.empty                   -- reached end while in shadow-        | Tile.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+    mscan Nothing ps pe+      | ps > pe = S.empty                     -- reached end while in shadow+      | isClear l tr shallowBump =            -- moving out of shadow+          mscan (Just (dline nsp shallowBump, nsBumps)) (ps+1) pe+      | otherwise = mscan Nothing (ps+1) pe   -- continue in shadow+     where+      shallowBump = B(ps, d)+      gte = flip $ dsteeper shallowBump+      nsp = maximal gte eBumps+      nsBumps = addHull gte shallowBump sBumps0 -      dline p1 p2 =-        ddebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)+-- | Create a line from two points. Debug: check if well-defined.+dline :: Bump -> Bump -> Line+dline p1 p2 =+  assert (uncurry blame $ debugLine (p1, p2)) $+  (p1, p2) -      dsteeper f p1 p2 =-        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2+-- | Compare steepness of (p1, f) and (p2, f).+-- Debug: Verify that the results of 2 independent checks are equal.+dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper f p1 p2 =+  assert (res == debugSteeper f p1 p2) $+  res+   where res = 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 =+intersect :: Line -> Distance -> (Int, Int)+intersect (B(x, y), B(xf, yf)) d =+  assert (allB (>= 0) [y, yf]) $   ((d - y)*(xf - x) + x*(yf - y), yf - y) {- Derivation of the formula:-The intersection point (yt, xt) satisfies the following equalities:+The intersection point (xt, yt) satisfies the following equalities: yt = d (yt - y) (xf - x) = (xt - x) (yf - y) hence@@ -91,48 +101,49 @@ xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)  General remarks:-A diamond is denoted by its left corner. Hero at (0,0).+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,+as for the restrictive shadow casting algorithm and reversed wrt PFOV.+The line in the curent state of mscan 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,+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.+looks at the first (rotated 45 degrees) quadrant. The (Progress, Distance)+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)+debugSteeper :: Bump -> Bump -> Bump -> Bool+debugSteeper f@(B(_xf, yf)) p1@(B(_x1, y1)) p2@(B(_x2, y2)) =+  assert (allB (>= 0) [yf, y1, y2]) $+  let (n1, k1) = intersect (p1, f) 0+      (n2, k2) = intersect (p2, f) 0+  in n1 * k2 >= k1 * n2  -- | Debug: check is a view border line for DFOV is legal.-ddebugLine :: Line -> Line-ddebugLine line@(B(y1, x1), B(y2, x2))+debugLine :: Line -> (Bool, String)+debugLine line@(B(x1, y1), B(x2, y2))+  | not (allB (>= 0) [y1, y2]) =+      (False, "negative coordinates: " ++ show line)   | y1 == y2 && x1 == x2 =-      error $ "ddebugLine: wrongly defined line " ++ show line-  | y2 - y1 == 0 =-      error $ "ddebugLine: horizontal line " ++ show line+      (False, "ill-defined line: " ++ show line)+  | y1 == y2 =+      (False, "horizontal line: " ++ show line)   | crossL0 =-      error $ "ddebugLine: crosses the X axis below 0 " ++ show line+      (False, "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)+      (False, "crosses the X axis above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = intersect 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
@@ -1,11 +1,11 @@-module FOV.Permissive where+module FOV.Permissive (scan) where -import Data.Set as S+import qualified Data.Set as S +import Utils.Assert import FOV.Common-import Geometry+import Loc import Level-import qualified Tile  -- Permissive FOV with a given range. @@ -14,7 +14,7 @@ -- 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+-- See https://github.com/Mikolaj/Allure/wiki/Fov-and-los -- for some more context.  -- TODO: Scanning squares on horizontal lines in octants, not squares@@ -25,75 +25,82 @@ -- | 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-        | Tile.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+scan :: Distance -> (Bump -> Loc) -> Level -> S.Set Loc+scan r tr l =+  -- the area is diagonal, which is incorrect, but looks good enough+  dscan 1 (((B(0, 1), B(r+1, 0)), [B(1, 0)]), ((B(1, 0), B(0, r+1)), [B(0, 1)]))+ where+  dscan :: Distance -> EdgeInterval -> S.Set Loc+  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+    assert (r >= d && d >= 0 && pe + 1 >= ps0 && ps0 >= 0+            `blame` (r,d,s0,e,ps0,pe)) $+    if illegal then S.empty else S.union inside outside+   where+    (ns, ks) = intersect sl d+    (ne, ke) = intersect el d+    -- Corners are translucent, so they are invisible, so if intersection+    -- is at a corner, choose pe that creates the smaller view.+    (ps0, 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) = intersect sl 0+               in ns*ke == ne*ks && (n `elem` [0, k])+    pd2bump     (p, di) = B(di - p    , p)+    bottomRight (p, di) = B(di - p + 1, p) -      dp2bump     (d, p) = B(p, d - p)-      bottomRight (d, p) = B(p, d - p + 1)-      tr = ptr . dp2bump+    inside = S.fromList [tr (pd2bump (p, d)) | p <- [ps0..pe]]+    outside+      | d >= r = S.empty+      | isClear l tr (pd2bump (ps0, d)) = mscan (Just s0) ps0  -- start in light+      | ps0 == ns `divUp` ks = mscan (Just s0) ps0          -- start in a corner+      | otherwise = mscan Nothing (ps0+1)                   -- start in mid-wall -      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)-        | Tile.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+    mscan :: Maybe Edge -> Progress -> S.Set Loc+    mscan (Just s@(_, sBumps)) ps+      | ps > pe = dscan (d+1) (s, e)            -- reached end, scan next+      | not $ isClear l tr (pd2bump (ps, d)) =  -- enter shadow, steep bump+          let steepBump = bottomRight (ps, d)+              gte = flip $ dsteeper steepBump+              -- sBumps may contain steepBump, but maximal will ignore it+              nep = maximal gte sBumps+              neBumps = addHull gte steepBump eBumps+          in S.union (dscan (d+1) (s, (dline nep steepBump, neBumps)))+                     (mscan Nothing (ps+1))+      | otherwise = mscan (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+    mscan 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 (ps, d)+              gte = dsteeper shallowBump+              nsp = maximal gte eBumps+              nsBumps = addHull gte shallowBump sBumps0+          in mscan (Just (dline nsp shallowBump, nsBumps)) ps -      pline p1 p2 =-        pdebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)+-- | Create a line from two points. Debug: check if well-defined.+dline :: Bump -> Bump -> Line+dline p1 p2 =+  assert (uncurry blame $ debugLine (p1, p2)) $+  (p1, p2) -      psteeper f p1 p2 =-        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2+-- | Compare steepness of (p1, f) and (p2, f).+-- Debug: Verify that the results of 2 independent checks are equal.+dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper f p1 p2 =+  assert (res == debugSteeper f p1 p2) $+  res+   where res = 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 =+intersect :: Line -> Distance -> (Int, Int)+intersect (B(x, y), B(xf, yf)) d =+  assert (allB (>= 0) [x, y, xf, yf]) $   ((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:+The intersection point (xt, yt) satisfies the following equalities: xt = 1 + d - yt (yt - y) (xf - x) = (xt - x) (yf - y) hence@@ -104,48 +111,49 @@ 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).+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,+wrt the restrictive shadow casting algorithm. The line in the curent state+of mscan 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,+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+looks at the first quadrant. The (Progress, Distance) 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)+debugSteeper :: Bump -> Bump -> Bump -> Bool+debugSteeper f@(B(xf, yf)) p1@(B(x1, y1)) p2@(B(x2, y2)) =+  assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $+  let (n1, k1) = intersect (p1, f) 0+      (n2, k2) = intersect (p2, f) 0+  in n1 * k2 <= k1 * n2  -- | Debug: checks postconditions of borderLine.-pdebugLine :: Line -> Line-pdebugLine line@(B(y1, x1), B(y2, x2))+debugLine :: Line -> (Bool, String)+debugLine line@(B(x1, y1), B(x2, y2))+  | not (allB (>= 0) [x1, y1, x2, y2]) =+      (False, "negative coordinates: " ++ show line)   | y1 == y2 && x1 == x2 =-      error $ "pdebugLine: wrongly defined line " ++ show line+      (False, "ill-defined line: " ++ show line)   | x2 - x1 == - (y2 - y1) =-      error $ "pdebugLine: diagonal line " ++ show line+      (False, "diagonal line: " ++ show line)   | crossL0 =-      error $ "pdebugLine: crosses diagonal below 0 " ++ show line+      (False, "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)+      (False, "crosses diagonal above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = intersect 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
@@ -1,10 +1,11 @@-module FOV.Shadow where+module FOV.Shadow (scan) where  import Data.Ratio-import Data.Set as S+import qualified Data.Set as S +import Utils.Assert import FOV.Common-import Geometry+import Loc import Level import qualified Tile @@ -67,38 +68,41 @@ for the square is added to the shadow set. -} +type Interval = (Rational, Rational)+ -- | 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+scan :: ((Progress, Distance) -> Loc) -> Level -> Distance -> Interval+        -> S.Set Loc+scan tr l d (s0, e) =+    let ps = downBias (s0 * fromIntegral d)  -- minimal progress to check         pe = upBias (e * fromIntegral d)     -- maximal progress to check-        st = if Tile.open (l `at` tr (d,ps)) then Just s   -- start in light-                                             else Nothing  -- start in shadow+        st = if Tile.isClear (l `at` tr (ps, d))+             then Just s0  -- 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)+        assert (d >= 0 && e >= 0 && s0 >= 0 && pe >= ps && ps >= 0+                `blame` (d,s0,e,ps,pe)) $+        S.union (S.fromList [tr (p, d) | p <- [ps..pe]]) (mscan 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-      | Tile.closed (l `at` tr (d,ps)) =+    mscan :: Maybe Rational -> Progress -> Progress -> S.Set Loc+    mscan (Just s) ps pe+      | s  >= e  = S.empty                -- empty interval+      | ps > pe  = scan tr l (d+1) (s, e) -- reached end, scan next+      | not $ Tile.isClear (l `at` tr (ps, d)) =                    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+                   in  scan tr l (d+1) (s, ne) `S.union` mscan Nothing (ps+1) pe                                       -- entering shadow-      | otherwise = scan' (Just s) (ps+1) pe+      | otherwise = mscan (Just s) (ps+1) pe                                       -- continue in light-    scan' Nothing ps pe+    mscan Nothing ps pe       | ps > pe  = S.empty            -- reached end while in shadow-      | Tile.open (l `at` tr (d,ps)) =+      | Tile.isClear (l `at` tr (ps, d)) =                    let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-                   in  scan' (Just ns) (ps+1) pe+                   in  mscan (Just ns) (ps+1) pe                                       -- moving out of shadow-      | otherwise = scan' Nothing (ps+1) pe+      | otherwise = mscan Nothing (ps+1) pe                                       -- continue in shadow  downBias, upBias :: (Integral a, Integral b) => Ratio a -> b
+ src/Feature.hs view
@@ -0,0 +1,20 @@+module Feature (Feature(..)) where++import Effect+import Random++data Feature =+    Walkable           -- ^ actors can walk through+  | Clear              -- ^ actors can see through+  | Exit               -- ^ is an exit from a room+  | Lit                -- ^ is lit; TODO: (partially) replace ucolor by this feature?+  | Secret !RollDice   -- ^ tile is generated with this high secrecy value+  | Aura !Effect       -- ^ sustains the effect continuously+  | Cause !Effect      -- ^ causes the effect when triggered+  | Change !Char       -- ^ transitions when triggered+  | Climbable          -- ^ triggered by climbing+  | Descendable        -- ^ triggered by descending into+  | Openable           -- ^ triggered by opening+  | Closable           -- ^ triggered by closable+  | Hidden             -- ^ triggered when the tile's secrecy becomes (Just 0)+  deriving (Show, Eq, Ord)
− src/File.hs 
@@ -1,22 +0,0 @@-module File where--import System.IO-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import Codec.Compression.Zlib as Z--strictReadCompressedFile :: FilePath -> IO LBS.ByteString-strictReadCompressedFile f =-    do-      h <- openBinaryFile f ReadMode-      c <- LBS.hGetContents h-      let d = Z.decompress c-      LBS.length d `seq` return d--strictDecodeCompressedFile :: Binary a => FilePath -> IO a-strictDecodeCompressedFile = fmap decode . strictReadCompressedFile--encodeCompressedFile :: Binary a => FilePath -> a -> IO ()-encodeCompressedFile f = LBS.writeFile f . Z.compress . encode-  -- note that LBS.writeFile opens the file in binary mode-
+ src/Flavour.hs view
@@ -0,0 +1,68 @@+module Flavour+  ( Flavour+  , zipPlain, zipFancy, darkCol, brightCol, stdCol, stdFlav+  , flavourToColor, flavourToName)+  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, zipFancy :: [Color] -> [(Color, Bool)]+zipPlain cs = L.zip cs (repeat False)+zipFancy cs = L.zip cs (repeat True)++darkCol, brightCol, stdCol :: [Color]+darkCol    = [Red .. Cyan]+brightCol  = [BrRed .. BrCyan]  -- BrBlack is not really that bright+stdCol     = darkCol ++ brightCol++stdFlav :: [(Color, Bool)]+stdFlav    = zipPlain stdCol ++ zipFancy stdCol++flavourToName :: Flavour -> String+flavourToName (c, False) = colorToName c+flavourToName (c, True) = colorToName' c++flavourToColor :: Flavour -> Color+flavourToColor (c, _) = c++-- 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/Frequency.hs view
@@ -2,15 +2,17 @@  import Control.Monad +-- TODO: perhaps move to Utils/ (generally useful enough? more ops needed?)+ newtype Frequency a = Frequency { runFrequency :: [(Int, a)] }   deriving Show  instance Monad Frequency where-  return x  =  Frequency [(1, x)]-  m >>= f   =  Frequency-               [(p * q, y) | (p, x) <- runFrequency m, +  return x = Frequency [(1, x)]+  m >>= f  = Frequency+               [(p * q, y) | (p, x) <- runFrequency m,                              (q, y) <- runFrequency (f x) ]-  fail ""   =  Frequency []+  fail _   = Frequency []  instance MonadPlus Frequency where   mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys)@@ -22,10 +24,13 @@ -- only try the second possibility if the first fails melse :: Frequency a -> Frequency a -> Frequency a melse (Frequency []) y = y-melse x              y = x+melse x             _y = x  scale :: Int -> Frequency a -> Frequency a scale n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs)  uniform :: [a] -> Frequency a uniform = Frequency . map (\ x -> (1, x))++filterFreq :: (a -> Bool) -> Frequency a -> Frequency a+filterFreq p (Frequency l) = Frequency $ filter (p . snd) l
src/Geometry.hs view
@@ -1,116 +1,29 @@-module Geometry where--import Data.List as L+module Geometry+  ( Time, X, Y, shiftXY, movesXY, lenXY, euclidLenSq, normalLevelBound ) where --- | Game time in turns. (Placement in module Geometry is not ideal.)+-- | Game time in turns. The time dimension. type Time = Int --- | Vertical directions.-data VDir = Up | Down-  deriving (Eq, Ord, Show, Enum, Bounded)-+-- | Spacial dimensions, points and vectors. type X = Int type Y = Int -type Loc  = (Y,X)-type Dir  = (Y,X)-type Area = ((Y,X),(Y,X))---- | Given two locations, determine the direction in which one should--- move from the first in order to get closer to the second. Does not--- pay attention to obstacles at all.-towards :: (Loc,Loc) -> Dir-towards ((y0,x0),(y1,x1)) =-  let dy = y1 - y0-      dx = x1 - x0-      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)-      dir | angle <= -0.75 = (-1,0)-          | angle <= -0.25 = (-1,1)-          | angle <= 0.25  = (0,1)-          | angle <= 0.75  = (1,1)-          | angle <= 1.25  = (1,0)-          | otherwise      = (0,0)-  in  if dx >= 0 then dir else neg dir---- | Get the squared distance between two locations.-distance :: (Loc,Loc) -> Int-distance ((y0,x0),(y1,x1)) = (y1 - y0)^2 + (x1 - x0)^2---- | Return whether two locations are adjacent on the map--- (horizontally, vertically or diagonally). Currrently, a--- position is also considered adjacent to itself.-adjacent :: Loc -> Loc -> Bool-adjacent s t = distance (s,t) <= 2---- | Return the 8 surrounding locations of a given location.-surroundings :: Loc -> [Loc]-surroundings l = map (l `shift`) moves--diagonal :: Dir -> Bool-diagonal (y,x) = y*x /= 0---- | Move one square in the given direction.-shift :: Loc -> Dir -> Loc-shift (y0,x0) (y1,x1) = (y0+y1,x0+x1)---- | Invert a direction (vector).-neg :: Dir -> Dir-neg (y,x) = (-y,-x)---- | Get the vectors of all the moves, clockwise, starting north-west.-moves :: [Dir]-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-upleft    = up   `shift` left-upright   = up   `shift` right-downleft  = down `shift` left-downright = down `shift` right-up        = (-1,0)-down      = (1,0)-left      = (0,-1)-right     = (0,1)--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)+-- | Shift a point by a vector.+shiftXY :: (X, Y) -> (X, Y) -> (X, Y)+shiftXY (x0, y0) (x1, y1) = (x0 + x1, y0 + y1) -fromTo1 :: X -> X -> [X]-fromTo1 x0 x1-  | x0 <= x1  = [x0..x1]-  | otherwise = [x0,x0-1..x1]+-- | Vectors of all unit moves, clockwise, starting north-west.+movesXY :: [(X, Y)]+movesXY = [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] -normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))-normalize (a,b) | a <= b    = (a,b)-                | otherwise = (b,a)+-- | The lenght of a vector in our metric where diagonal moves cost 1 move.+lenXY :: (X, Y) -> Int+lenXY (x, y) = max (abs x) (abs y) -normalizeArea :: Area -> Area-normalizeArea a@((y0,x0),(y1,x1)) =-  ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))+-- | Squared euclidean length of a vector.+euclidLenSq :: (X, Y) -> Int+euclidLenSq (x, y) = let square a = a * a+                     in square x + square y -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] ]+normalLevelBound :: (X, Y)+normalLevelBound = (79, 22)  -- TODO: query terminal size instead
− src/GeometryRnd.hs 
@@ -1,58 +0,0 @@-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,17 +1,18 @@ module Grammar where  import Data.Char-import Data.Set as S-import Data.List as L-import qualified Data.IntMap as IM+import qualified Data.Set as S+import qualified Data.List as L+import Data.Maybe  import Item-import Movable-import MovableKind+import Actor+import Content.ActorKind import State-import ItemKind+import Content.ItemKind import Effect-+import Flavour+import qualified Kind  suffixS :: String -> String suffixS word = case last word of@@ -24,61 +25,63 @@ capitalize [] = [] capitalize (c : cs) = toUpper c : cs --- | How to refer to a movable in object position of a sentence.-objectMovable :: MovableKind -> String-objectMovable mk = nname mk+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) --- | How to refer to a movable in subject position of a sentence.-subjectMovable :: MovableKind -> String-subjectMovable x = capitalize $ objectMovable x+-- TODO: when there's more of the above, split and move to Utils/ -verbMovable :: MovableKind -> String -> String-verbMovable mk v = if nname mk == "you" then v else suffixS v+-- | How to refer to an actor in object position of a sentence.+objectActor :: Actor -> String+objectActor a = fromMaybe (aname $ Kind.getKind $ bkind a) (bname a) +-- | How to refer to an actor in subject position of a sentence.+subjectActor :: Actor -> String+subjectActor x = capitalize $ objectActor x++verbActor :: Actor -> String -> String+verbActor a v = if objectActor a == "you" then v else suffixS v+ -- | Sentences such like "The dog barks".-subjectMovableVerb :: MovableKind -> String -> String-subjectMovableVerb x v = subjectMovable x ++ " " ++ verbMovable x v+subjectActorVerb :: Actor -> String -> String+subjectActorVerb x v = subjectActor x ++ " " ++ verbActor x v -compoundVerbMovable :: MovableKind -> String -> String -> String-compoundVerbMovable m v p = verbMovable m v ++ " " ++ p+compoundVerbActor :: Actor -> String -> String -> String+compoundVerbActor m v p = verbActor m v ++ " " ++ p -subjectVerbIObject :: State -> Movable -> String -> Item -> String -> String+subjectVerbIObject :: State -> Actor -> String -> Item -> String -> String subjectVerbIObject state m v o add =-  subjectMovable (mkind m) ++ " " ++-  verbMovable (mkind m) v ++ " " +++  subjectActor m ++ " " +++  verbActor m v ++ " " ++   objectItem state o ++ add ++ "." -subjectVerbMObject :: Movable -> String -> Movable -> String -> String+subjectVerbMObject :: Actor -> String -> Actor -> String -> String subjectVerbMObject m v o add =-  subjectMovable (mkind m) ++ " " ++-  verbMovable (mkind m) v ++ " " ++-  objectMovable (mkind o) ++ add ++ "."+  subjectActor m ++ " " +++  verbActor m v ++ " " +++  objectActor o ++ add ++ "." -subjCompoundVerbIObj :: State -> Movable -> String -> String ->+subjCompoundVerbIObj :: State -> Actor -> String -> String ->                         Item -> String -> String subjCompoundVerbIObj state m v p o add =-  subjectMovable (mkind m) ++ " " ++-  compoundVerbMovable (mkind m) v p ++ " " +++  subjectActor m ++ " " +++  compoundVerbActor 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+  let ik = jkind o+      kind = Kind.getKind ik+      identified = L.length (iflavour kind) == 1 ||+                   ik `S.member` sdisco state       addSpace s = if s == "" then "" else " " ++ s-      eff = effectToName (jeffect kind)-      pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")"+      eff = effectToName (ieffect kind)+      pwr = if jpower o == 0 then "" else "(+" ++ show (jpower o) ++ ")"       adj name = if identified                  then name ++ addSpace eff ++ addSpace pwr-                 else let flavour = getFlavour (sassocs state) ik+                 else let flavour = getFlavour (sflavour state) ik                       in  flavourToName flavour ++ " " ++ name-  in  makeObject (icount o) adj (jname kind)+  in  makeObject (jcount o) adj (iname kind)
src/HighScores.hs view
@@ -1,19 +1,17 @@ module HighScores where  import System.Directory-import Control.Exception as E hiding (handle) import Control.Monad import Text.Printf import System.Time  import Data.Binary-import Data.List as L-import Data.Maybe+import qualified Data.List as L -import File-import Dungeon+import Utils.File import qualified Config import WorldLoc+import Geometry  -- | A single score. -- TODO: add heroes' names, exp and level, cause of death, user number/name.@@ -22,26 +20,16 @@ -- and I couldn't use Datetime because it needs old base (and is under GPL). -- TODO: When we finally move to Date.Time, let's take timezone into account. data ScoreRecord = ScoreRecord-                     { points  :: Int,-                       negTurn :: Int,-                       date    :: ClockTime,-                       status  :: Status}+  { points  :: !Int+  , negTurn :: !Int+  , date    :: !ClockTime+  , status  :: !Status+  }   deriving (Eq, Ord) -data Status = Killed LevelId | Camping LevelId | Victor+data Status = Killed !LevelId | Camping !LevelId | Victor   deriving (Eq, Ord) -instance Binary ClockTime where-  put (TOD s p) =-    do-      put s-      put p-  get =-    do-      s <- get-      p <- get-      return (TOD s p)- instance Binary Status where   put (Killed ln)  = putWord8 0 >> put ln   put (Camping ln) = putWord8 1 >> put ln@@ -52,21 +40,24 @@             0 -> liftM Killed  get             1 -> liftM Camping get             2 -> return Victor+            _ -> fail "no parse (Status)"  instance Binary ScoreRecord where-  put (ScoreRecord points negTurn date status) =+  put (ScoreRecord p n (TOD cs cp) s) =     do-      put points-      put negTurn-      put date-      put status+      put p+      put n+      put cs+      put cp+      put s   get =     do-      points <- get-      negTurn <- get-      date <- get-      status <- get-      return (ScoreRecord points negTurn date status)+      p <- get+      n <- get+      cs <- get+      cp <- get+      s <- get+      return (ScoreRecord p n (TOD cs cp) s)  -- | Show a single high score. showScore :: (Int, ScoreRecord) -> String@@ -79,7 +70,6 @@       time  = calendarTimeToString . toUTCTime . date $ score       big   = "                                                 "       lil   = "              "-      -- TODO: later: https://github.com/kosmikus/LambdaHack/issues#issue/9       steps = negTurn score `div` (-10)   in    printf@@ -100,26 +90,25 @@ -- | We save a simple serialized version of the high scores table. -- The 'False' is used only as an EOF marker. save :: Config.CP -> ScoreTable -> IO ()-save config scores =-  do-    f <- file config-    E.catch (removeFile f) (\ e -> case e :: IOException of _ -> return ())-    encodeCompressedFile f (scores, False)+save config scores = do+  f <- file config+  encodeEOF f scores  -- | Read the high scores table. Return the empty table if no file. restore :: Config.CP -> IO ScoreTable-restore config =-  E.catch (do-             f <- file config-             (x, z) <- strictDecodeCompressedFile f-             (z :: Bool) `seq` return x)-          (\ e -> case e :: IOException of-                    _ -> return [])+restore config = do+  f <- file config+  b <- doesFileExist f+  if not b+    then return []+    else do+      scores <- strictDecodeEOF f+      return scores  -- | Insert a new score into the table, Return new table and the position. insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) insertPos s h =-  let (prefix, suffix) = L.span (\ x -> x > s) h in+  let (prefix, suffix) = L.span (> s) h in   (prefix ++ [s] ++ suffix, L.length prefix + 1)  -- | Show a screenful of the high scores table.@@ -145,8 +134,8 @@   do     h <- restore config     let (h', pos) = insertPos s h-        (lines, _) = normalLevelSize-        height = lines `div` 3+        (_, nlines) = normalLevelBound  -- TODO: query terminal size instead+        height = nlines `div` 3         (msgCurrent, msgUnless) =           case status s of             Killed _  -> (" short-lived", " (score halved)")@@ -157,5 +146,5 @@                           else "")         msg = printf "Your%s exploits award you place >> %d <<%s."                 msgCurrent pos msgUnless-    if write then save config h' else return ()+    when write $ save config h'     return (msg, slideshow pos h' height)
src/Item.hs view
@@ -1,80 +1,85 @@ module Item where  import Data.Binary-import Data.Set as S-import Data.List as L-import qualified Data.IntMap as IM+import qualified Data.Set as S+import qualified Data.List as L+import qualified Data.Map as M import Data.Maybe import Data.Char import Data.Function+import Data.Ord import Control.Monad +import Utils.Assert import Random-import ItemKind+import Content.ItemKind import qualified Color+import Flavour+import qualified Kind  data Item = Item-  { ikind    :: !Int,-    ipower   :: !Int,  -- https://github.com/Mikolaj/Allure/issues#issue/11-    iletter  :: Maybe Char,  -- ^ inventory identifier-    icount   :: !Int }+  { jkind   :: !(Kind.Id ItemKind)+  , jpower  :: !Int         -- TODO: see the TODO about jpower+  , jletter :: Maybe Char  -- ^ inventory identifier+  , jcount  :: !Int+  }   deriving Show  instance Binary Item where-  put (Item ikind ipower iletter icount ) =-    put ikind >> put ipower >> put iletter >> put icount+  put (Item ik ip il ic ) =+    put ik >> put ip >> put il >> put ic   get = liftM4 Item get get get get -type Assocs = IM.IntMap Flavour+type FlavourMap = M.Map (Kind.Id ItemKind) Flavour  -- TODO: rewrite and move elsewhere -type Discoveries = S.Set Int+type Discoveries = S.Set (Kind.Id ItemKind) --- | Assinges flavours to item kinds. Assures no flavor is repeated,+-- | Assigns flavours to item kinds. Assures no flavor is repeated, -- except for items with only one permitted flavour.-rollAssocs :: Int -> ItemKind ->-              Rnd (IM.IntMap Flavour, S.Set Flavour) ->-              Rnd (IM.IntMap Flavour, S.Set Flavour)-rollAssocs key kind rnd =-  if L.length (jflavour kind) == 1-  then rnd-  else do-    (assocs, available) <- rnd-    let proper = S.fromList (jflavour kind) `S.intersection` available-    flavour <- oneOf (S.toList proper)-    return (IM.insert key flavour assocs, S.delete flavour available)+rollFlavourMap :: Kind.Id ItemKind -> ItemKind ->+              Rnd (FlavourMap, S.Set Flavour) ->+              Rnd (FlavourMap, S.Set Flavour)+rollFlavourMap key ik rnd =+  let flavours = iflavour ik+  in 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)  -- | Randomly chooses flavour for all item kinds for this game.-dungeonAssocs :: Rnd Assocs-dungeonAssocs =-  liftM fst $-  IM.foldWithKey rollAssocs (return (IM.empty, S.fromList stdFlav)) dungeonLoot+dungeonFlavourMap :: Rnd FlavourMap+dungeonFlavourMap =+  liftM fst $ Kind.foldrWithKey rollFlavourMap (return (M.empty, S.fromList stdFlav)) -getFlavour :: Assocs -> Int -> Flavour+getFlavour :: FlavourMap -> Kind.Id ItemKind -> Flavour getFlavour assocs ik =-  let kind = ItemKind.getIK ik-  in  case jflavour kind of-        []  -> error "getFlavour"+  let kind = Kind.getKind ik+  in  case iflavour kind of+        []  -> assert `failure` (assocs, ik, kind)         [f] -> f-        _:_ -> assocs IM.! ik+        _:_ -> assocs M.! ik -viewItem :: Int -> Assocs -> (Char, Color.Color)-viewItem ik assocs = (jsymbol (getIK ik), flavourToColor $ getFlavour assocs ik)+fistKindId :: Kind.Id ItemKind+fistKindId = Kind.getId ((== "fist") . iname) +viewItem :: Kind.Id ItemKind -> FlavourMap -> (Char, Color.Color)+viewItem ik assocs = (isymbol (Kind.getKind ik), flavourToColor $ getFlavour assocs ik)+ itemLetter :: ItemKind -> Maybe Char-itemLetter ik = if jsymbol ik == '$' then Just '$' else Nothing+itemLetter ik = if isymbol ik == '$' then Just '$' else Nothing  -- | Generate an item. newItem :: Int -> Rnd Item newItem lvl = do-  let dLoot = IM.assocs dungeonLoot-      fik = Frequency $ L.zip (L.map (jfreq . snd) dLoot) (L.map fst dLoot)-  ikChosen <- frequency fik-  let kind = getIK ikChosen-  count <- rollQuad lvl (jcount kind)+  (ikChosen, kind) <- frequency Kind.frequency+  count <- rollQuad lvl (icount kind)   if count == 0     then newItem lvl  -- Rare item; beware of inifite loops.     else do-      power <- rollQuad lvl (jpower kind)+      power <- rollQuad lvl (ipower kind)       return $ Item ikChosen power (itemLetter kind) count  -- | Assigns a letter to an item, for inclusion@@ -86,7 +91,7 @@       Just l | l `L.elem` allowed -> Just l       _ -> listToMaybe free   where-    current    = S.fromList (concatMap (maybeToList . iletter) is)+    current    = S.fromList (mapMaybe jletter is)     allLetters = ['a'..'z'] ++ ['A'..'Z']     candidates = take (length allLetters) $                    drop (fromJust (L.findIndex (==c) allLetters)) $@@ -108,13 +113,14 @@                   LT  ->  y                   _   ->  x +maxLetter :: Char -> Char -> Char maxLetter = maxBy cmpLetter  mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char mergeLetter = mplus  letterRange :: [Char] -> String-letterRange xs = sectionBy (sortBy cmpLetter xs) Nothing+letterRange ls = sectionBy (L.sortBy cmpLetter ls) Nothing   where     succLetter c d = ord d - ord c == 1 @@ -141,8 +147,8 @@ 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) }+    Just (j,js) -> let n = i { jcount = jcount i + jcount j,+                               jletter = mergeLetter (jletter j) (jletter i) }                    in (n, n : js)  -- | Removes an item from a list of items.@@ -150,42 +156,44 @@ removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item] removeItemBy eq i = concatMap $ \ x ->                     if eq i x-                      then let remaining = icount x - icount i-                           in  if remaining > 0-                                 then [x { icount = remaining }]-                                 else []+                      then let remaining = jcount x - jcount i+                           in if remaining > 0+                              then [x { jcount = remaining }]+                              else []                       else [x]  equalItemIdentity :: Item -> Item -> Bool-equalItemIdentity i1 i2 = ipower i1 == ipower i2 && ikind i1 == ikind i2+equalItemIdentity i1 i2 = jpower i1 == jpower i2 && jkind i1 == jkind i2 +removeItemByIdentity :: Item -> [Item] -> [Item] removeItemByIdentity = removeItemBy equalItemIdentity  equalItemLetter :: Item -> Item -> Bool-equalItemLetter = (==) `on` iletter+equalItemLetter = (==) `on` jletter +removeItemByLetter :: Item -> [Item] -> [Item] removeItemByLetter = removeItemBy equalItemLetter  -- | Finds an item in a list of items. findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])-findItem p is = findItem' [] is+findItem p = findItem' []   where-    findItem' acc []     = Nothing+    findItem' _   []     = Nothing     findItem' acc (i:is)       | p i              = Just (i, reverse acc ++ is)       | otherwise        = findItem' (i:acc) is  strongestItem :: [Item] -> String -> Maybe Item strongestItem is groupName =-  let cmp = compare `on` ipower-      igs = L.filter (\ i -> jname (getIK (ikind i)) == groupName) is+  let cmp = comparing jpower+      igs = L.filter (\ i -> iname (Kind.getKind (jkind i)) == groupName) is   in  case igs of         [] -> Nothing         _  -> Just $ L.maximumBy cmp igs  itemPrice :: Item -> Int itemPrice i =-  case jname (getIK (ikind i)) of-    "gold piece" -> icount i-    "gem" -> 100+  case iname (Kind.getKind (jkind i)) of+    "gold piece" -> jcount i+    "gem" -> jcount i * 100     _ -> 0
src/ItemAction.hs view
@@ -1,39 +1,28 @@ 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 Control.Monad.State hiding (State, state)+import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe-import Data.Set as S-import System.Time+import qualified Data.Set as S +import Utils.Assert import Action import Display hiding (display)-import Dungeon-import Geometry+import Loc import Grammar-import qualified HighScores as H import Item-import qualified ItemKind+import Content.ItemKind import qualified Keys as K import Level-import LevelState-import Message-import Movable-import MovableState-import MovableKind-import MovableAdd+import Actor+import ActorState+import ActorAdd import Perception-import Random import State-import qualified Config-import qualified Save-import qualified Effect import EffectAction-import qualified Tile+import qualified Kind  -- Item UI code with the Action type and everything it depends on -- that is not already in Action.hs and EffectAction.hs.@@ -42,7 +31,7 @@ -- | Display inventory inventory :: Action a inventory = do-  items <- gets (mitems . getPlayerBody)+  items <- gets (bitems . getPlayerBody)   if L.null items     then abortWith "Not carrying anything."     else do@@ -53,42 +42,45 @@ -- | 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))+  let choice i = groupName == iname (Kind.getKind (jkind i))       header = capitalize $ suffixS groupName   in  getItem prompt choice header is packName -applyGroupItem :: Actor ->   -- actor applying the item; on current level-                  String ->  -- how the "applying" is called-                  Item ->    -- the item to be applied+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 }+  let consumed = item { jcount = 1 }       msg = subjectVerbIObject state body verb consumed ""-      loc = mloc body+      loc = bloc body   removeFromInventory actor consumed loc   when (loc `S.member` ptvisible per) $ messageAdd msg-  itemEffectAction actor actor consumed+  itemEffectAction 5 actor actor consumed   advanceTime actor  playerApplyGroupItem :: String -> Action () playerApplyGroupItem groupName = do-  is   <- gets (mitems . getPlayerBody)+  is   <- gets (bitems . 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)))+      let verb = applyToVerb (iname (Kind.getKind (jkind i)))       in  applyGroupItem pl verb i     Nothing -> neverMind True @@ -103,35 +95,39 @@ readScroll :: Action () readScroll = playerApplyGroupItem "scroll" -zapGroupItem :: Actor ->   -- 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+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 }-      msg = subjectVerbIObject state sm verb consumed ""-      sloc = mloc sm+  let consumed = item { jcount = 1 }+      sloc = bloc sm+      subject =+        if sloc `S.member` ptvisible per+        then sm+        else template Actor.heroKindId (Just "somebody") Nothing 99 sloc+      msg = subjectVerbIObject state subject verb consumed ""   removeFromInventory source consumed sloc-  -- The message describes the source part of the action.-  when (sloc `S.member` ptvisible per) $ messageAdd msg   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 source ta consumed-      when (not b) $-        modify (updateLevel (dropItemsAt [consumed] loc))-    Nothing ->+      b <- itemEffectAction 10 source ta consumed+      unless 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 (mitems . getPlayerBody)+  is    <- gets (bitems . getPlayerBody)   iOpt  <- getGroupItem is groupName              ("What to " ++ zapToVerb groupName ++ "?") "in inventory"   pl    <- gets splayer@@ -143,7 +139,7 @@         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)))+          then let verb = zapToVerb (iname (Kind.getKind (jkind i)))                in  zapGroupItem pl loc verb i           else abortWith "target not reachable"     Nothing -> neverMind True@@ -166,13 +162,13 @@   pl    <- gets splayer   state <- get   pbody <- gets getPlayerBody-  ploc  <- gets (mloc . getPlayerBody)-  items <- gets (mitems . getPlayerBody)+  ploc  <- gets (bloc . getPlayerBody)+  items <- gets (bitems . getPlayerBody)   iOpt  <- getAnyItem "What to drop?" items "inventory"   case iOpt of     Just stack -> do-      let i = stack { icount = 1 }-      removeOnlyFromInventory pl i (mloc pbody)+      let i = stack { jcount = 1 }+      removeOnlyFromInventory pl i (bloc pbody)       messageAdd (subjectVerbIObject state pbody "drop" i "")       modify (updateLevel (dropItemsAt [i] ploc))     Nothing -> neverMind True@@ -180,9 +176,9 @@  -- TODO: this is a hack for dropItem, because removeFromInventory -- makes it impossible to drop items if the floor not empty.-removeOnlyFromInventory :: Actor -> Item -> Loc -> Action ()-removeOnlyFromInventory actor i loc = do-  updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems m) })+removeOnlyFromInventory :: ActorId -> Item -> Loc -> Action ()+removeOnlyFromInventory actor i _loc =+  updateAnyActor actor (\ m -> m { bitems = removeItemByLetter i (bitems 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@@ -191,52 +187,56 @@ -- 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 :: Actor -> Item -> Loc -> Action ()+removeFromInventory :: ActorId -> Item -> Loc -> Action () removeFromInventory actor i loc = do   b <- removeFromLoc i loc-  when (not b) $-    updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems m) })+  unless b $+    updateAnyActor actor (\ m -> m { bitems = removeItemByLetter i (bitems 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) (Tile.titems (lmap `at` loc))+  lvl <- gets slevel+  if not $ L.any (equalItemIdentity i) (lvl `iat` loc)     then return False     else-      modify (updateLevel (updateLMap adj)) >>+      modify (updateLevel (updateIMap adj)) >>       return True         where-          adj = M.adjust (\ (t, rt) -> (remove t, rt)) loc-          remove t = t { Tile.titems = removeItemByIdentity i (Tile.titems t) }+          rib Nothing = assert `failure` (i, loc)+          rib (Just (is, irs)) =+            case (removeItemByIdentity i is, irs) of+              ([], []) -> Nothing+              iss -> Just iss+          adj = IM.alter rib loc -actorPickupItem :: Actor -> Action ()+actorPickupItem :: ActorId -> Action () actorPickupItem actor = do   state <- get   pl    <- gets splayer   per   <- currentPerception-  lmap  <- gets (lmap . slevel)+  lvl   <- gets slevel   body  <- gets (getActor actor)-  let loc       = mloc body-      t         = lmap `at` loc -- the map tile in question+  let loc       = bloc body       perceived = loc `S.member` ptvisible per       isPlayer  = actor == pl   -- check if something is here to pick up-  case Tile.titems t of+  case lvl `iat` loc of     []   -> abortIfWith isPlayer "nothing here"-    i:rs -> -- pick up first item; TODO: let player select item;not for monsters-      case assignLetter (iletter i) (mletter body) (mitems body) of+    i:is -> -- pick up first item; TODO: let player select item; not for monsters+      case assignLetter (jletter i) (bletter body) (bitems body) of         Just l -> do-          let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems body)+          let (ni, nitems) = joinItem (i { jletter = Just l }) (bitems body)           -- message depends on who picks up and if a hero can perceive it           if isPlayer-            then messageAdd (letterLabel (iletter ni) ++ objectItem state ni)+            then messageAdd (letterLabel (jletter ni) ++ objectItem state ni)             else when perceived $                    messageAdd $ subjCompoundVerbIObj state body "pick" "up" i ""-          assertTrue $ removeFromLoc i loc+          removeFromLoc i loc+            >>= assert `trueM` (i, is, loc, "item is stuck")           -- add item to actor's inventory:           updateAnyActor actor $ \ m ->-            m { mitems = nitems, mletter = maxLetter l (mletter body) }+            m { bitems = nitems, bletter = maxLetter l (bletter body) }         Nothing -> abortIfWith isPlayer "cannot carry any more"   advanceTime actor @@ -266,7 +266,7 @@               [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+getAnyItem prompt = getItem prompt (const True) "Objects"  -- | Let the player choose a single item from a list of items. getItem :: String ->              -- prompt message@@ -276,44 +276,43 @@            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       = mloc body-      t         = lmap `at` loc -- the map tile in question-      tis       = Tile.titems t+  lvl  <- gets slevel+  body <- gets getPlayerBody+  let loc       = bloc body+      tis       = lvl `iat` loc       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)+               else let r = letterRange $ mapMaybe jletter is                     in  "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]"-      interact = do+      ask = do         when (L.null is0 && L.null tis) $           abortWith "Not carrying anything."-        messageWipeAndSet (prompt ++ " " ++ choice)+        messageReset (prompt ++ " " ++ choice)         display         session nextCommand >>= perform       perform command = do-        resetMessage+        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+            if b then session (getOptionalConfirm (const ask) perform)+                 else ask           K.Char '*' -> do             -- show all objects             b <- displayItems ("Objects " ++ isn) True is0-            if b then session (getOptionalConfirm (const interact) perform)-                 else interact+            if b then session (getOptionalConfirm (const ask) perform)+                 else ask           K.Char '-' ->             case tis of               []   -> return Nothing-              i:rs -> -- use first item; TODO: let player select item+              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 (L.find (maybe False (== l) . jletter) is0)+          K.Return   ->  -- TODO: it should be the first displayed (except $)             return (case is of [] -> Nothing ; i : _ -> Just i)           _          -> return Nothing-  interact+  ask
− src/ItemKind.hs 
@@ -1,169 +0,0 @@-module ItemKind where--import qualified Data.List as L-import qualified Data.IntMap as IM--import Color-import Effect-import Random--data ItemKind = ItemKind-  { jsymbol  :: !Char      -- ^ map symbol-  , jflavour :: [Flavour]  -- ^ possible flavours-  , jname    :: String     -- ^ 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)--type Flavour = (Color, Bool)  -- the flag says 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 excluded (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--dungeonLoot :: IM.IntMap ItemKind-dungeonLoot = IM.fromDistinctAscList (L.zip [0..] loot)--getIK ik = dungeonLoot IM.! ik--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/Keybindings.hs view
@@ -1,41 +1,81 @@ module Keybindings where -import Control.Monad-import Control.Monad.State hiding (State)-import Data.Map as M-import Data.List as L+import qualified Data.Map as M+import qualified Data.List as L +import Utils.Assert import Action import Command+import Geometry import qualified Keys as K  -- | Keybindings. data Keybindings = Keybindings-  { kdir   :: DirCommand,-    kudir  :: DirCommand,-    kother :: M.Map K.Key Command+  { kdir   :: DirCommand+  , kudir  :: DirCommand+  , kother :: M.Map K.Key Command   } -handleKey :: Keybindings -> K.Key -> Action ()-handleKey kb k =-  do-    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 ++ ")"+handleKey :: X -> Keybindings -> K.Key -> Action ()+handleKey lxsize kb k =+  K.handleDirection lxsize k (caction $ kdir kb) $+    K.handleUDirection lxsize k (caction $ kudir kb) $+      case M.lookup k (kother kb) of+        Just c  -> caction c+        Nothing -> abortWith $ "unknown command (" ++ K.showKey k ++ ")"  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 ((35 - length h) `max` 1) ' '-    fmts s  = replicate 15 ' ' ++ s ++ replicate ((48 - length s) `max` 1) ' '+    fmts s  = replicate 2  ' ' ++ s ++ replicate ((71 - length s) `max` 1) ' '     blank   = fmt "" ""-    title   = fmt "keys" "command"-    footer  = fmts "(See file PLAYING.markdown.)"+    movKs   =+      [ ""+      , "You move throughout the level using the numerical keypad or"+      , "the vi text editor keys (also known as \"Rogue-like keys\")."+      , ""+      , "               7 8 9     y k u"+      , "                \\|/       \\|/"+      , "               4-5-6     h-.-l"+      , "                /|\\       /|\\"+      , "               1 2 3     b j n"+      , ""+      , "Shift and a movement key make the hero run in the indicated direction,"+      , "until anything of interest is spotted. '5' and '.' skip a turn."+      , ""+      , "To search, open or attack, bump into walls, doors or monsters."+      , ""+      , "For more playing instructions see file PLAYING.md."+      , ""+      , "Press space to see the next page."+      , ""+      , ""+      ]+    mov     = map fmts movKs+    keyC    = fmt "keys" "command"+--    footer  =+--      fmts "(To search, open or attack, bump into walls, doors or monsters.)"     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])+    unlines ([blank] ++ mov ++ [blank, keyC] ++ rest)+--             [blank, footer, blank])++-- | 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 K.Key K.Key+macroKey section =+  let trans k = case K.keyTranslate k of+                  K.Unknown s -> assert `failure` ("unknown macro key " ++ s)+                  kt -> kt+      trMacro (from, to) = let fromTr = trans from+                               !toTr  = K.canonMoveKey $ trans to+                           in  if fromTr == toTr+                               then assert `failure` ("degenerate alias", toTr)+                               else (fromTr, toTr)+  in  M.fromList $ L.map trMacro section
src/Keys.hs view
@@ -1,13 +1,17 @@ module Keys where  import Prelude hiding (Left, Right)--import Geometry hiding (Up, Down)+import qualified Data.Map as M+import qualified Data.List as L+import Data.Char import Data.Maybe-import Data.List as L-import Data.Map as M --- | Library-independent datatype to represent keys.+import Geometry+import Dir++-- TODO: if the file grows much larger, split it and move a part to Utils/++-- | Frontend-independent datatype to represent keys. data Key =     Esc   | Return@@ -21,9 +25,9 @@   | End   | Begin   | Home-  | 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+  | 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@@ -47,62 +51,38 @@ instance Show Key where   show = showKey +dirChars :: [Char]+dirChars = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']++dirKeys :: [Key]+dirKeys = map Char dirChars++dirUKeys :: [Key]+dirUKeys = map (Char . toUpper) dirChars+ -- | 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+canonMoveKey =+  let assocs = (Begin, Char '.') : (KP '5', Char '.') :+        zip [Home, Up, PgUp, Right, PgDn, Down, End, Left] dirKeys +++        zip (map KP ['7', '8', '9', '6', '3', '2', '1', '4']) dirUKeys+      m = M.fromList assocs+  in \ e -> fromMaybe e (M.lookup e m)  -- | 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+--   such as close door.+handleDirection :: X -> Key -> (Dir -> a) -> a -> a+handleDirection lxsize e h k =+  let assocs = zip dirKeys (moves lxsize)+  in maybe k h (L.lookup e assocs) --- | 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+-- | Configurable event handler for the upper direction keys.+handleUDirection :: X -> Key -> (Dir -> a) -> a -> a+handleUDirection lxsize e h k =+  let assocs = zip dirUKeys (moves lxsize)+  in maybe k h (L.lookup e assocs)  -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the macros in the config file.@@ -138,19 +118,3 @@ 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/Kind.hs view
@@ -0,0 +1,64 @@+module Kind+  ( Id, Kind.getKind, getId, frequency, foldrWithKey, boundsId+  , Array, (!), (//), listArray, bounds+  ) where++import Data.Binary+import qualified Data.List as L+import qualified Data.IntMap as IM+import qualified Data.Word as Word+import qualified Data.Array.Unboxed as A+import qualified Data.Ix as Ix++import Utils.Assert+import Content.Content+import Frequency++newtype Id a = Id{kindId :: Word8} deriving (Show, Eq, Ord, Ix.Ix)++instance Binary (Id a) where+  put (Id i) = put i+  get = fmap Id get++getKind :: Content a => Id a -> a+getKind (Id i) = kindMap IM.! (fromEnum i)++getId :: Content a => (a -> Bool) -> Id a+getId f = case [Id i | (i, k) <- kindAssocs, f k] of+            [i] -> i+            l -> assert `failure` l++frequency :: Content a => Frequency (Id a, a)+frequency = Frequency [(getFreq k, (Id i, k)) | (i, k) <- kindAssocs]++foldrWithKey :: Content a => (Id a -> a -> b -> b) -> b -> b+foldrWithKey f z = L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs++limitsId :: Content a => ((Id a, a), (Id a, a))+limitsId = let (i1, a1) = IM.findMin kindMap+               (i2, a2) = IM.findMax kindMap+           in ((Id (toEnum i1), a1), (Id (toEnum i2), a2))++boundsId :: Content a => (Id a, Id a)+boundsId = (Id 0, (fst . snd) limitsId)++newtype Array i c = Array{_kindArray :: A.UArray i Word.Word8} deriving Show++-- TODO: save/restore is still too slow, but we are already past+-- the point of diminishing returns. A dramatic change would be+-- low-level conversion to ByteString and serializing that.+instance (Ix.Ix i, Binary i) => Binary (Array i c) where+  put (Array a) = put a+  get = fmap Array get++(!) :: Ix.Ix i => Array i c -> i -> Id c+(!) (Array a) i = Id $ a A.! i++(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c+(//) (Array a) l = Array $ a A.// [(i, kindId e) | (i, e) <- l]++listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c+listArray bds l = Array $ A.listArray bds [(kindId e) | e <- l]++bounds :: Ix.Ix i => Array i c -> (i, i)+bounds (Array a) = A.bounds a
src/Level.hs view
@@ -1,40 +1,67 @@-module Level where--import Control.Monad+module Level+  ( SmellTime(..), SmellMap, SecretMap+  , ItemMap, TileMap, Level(..)+  , updateHeroes, updateMonsters, updateLMap, updateLRMap, updateIMap+  , updateSmell , emptyParty, at, rememberAt, iat, irememberAt+  , accessible, openable, findLoc, findLocTry, dropItemsAt+  ) where  import Data.Binary-import Data.Map as M-import Data.List as L+import qualified Data.List as L import qualified Data.IntMap as IM +import Utils.Assert import Geometry-import GeometryRnd-import Movable+import Loc+import Actor import Item+import Content.TileKind import Random-import qualified Terrain-import WorldLoc-import Data.Maybe import qualified Tile+import qualified Feature as F+import qualified Kind -type Party = IM.IntMap Movable+newtype SmellTime = SmellTime{smelltime :: Time} deriving Show+instance Binary SmellTime where+  put = put . smelltime+  get = fmap SmellTime get+type SmellMap = IM.IntMap SmellTime +type SecretMap = IM.IntMap Tile.SecretStrength++type ItemMap = IM.IntMap ([Item], [Item])++type TileMap = Kind.Array Loc TileKind+ data Level = Level-  { lname     :: LevelId,    -- TODO: remove-    lheroes   :: Party,      -- ^ all heroes on the level-    lsize     :: (Y,X),-    lmonsters :: Party,      -- ^ all monsters on the level-    lsmell    :: SMap,-    lmap      :: LMap,-    lmeta     :: String }+  { lheroes   :: Party      -- ^ all heroes on the level+  , lxsize    :: X+  , lysize    :: Y+  , lmonsters :: Party      -- ^ all monsters on the level+  , lsmell    :: SmellMap+  , lsecret   :: SecretMap+  , litem     :: ItemMap+  , lmap      :: TileMap+  , lrmap     :: TileMap+  , lmeta     :: String+  , lstairs   :: (Loc, Loc) -- ^ here the stairs (down, up) from other levels end+  }   deriving Show -updateLMap :: (LMap -> LMap) -> Level -> Level+updateLMap :: (TileMap -> TileMap) -> Level -> Level updateLMap f lvl = lvl { lmap = f (lmap lvl) } -updateSMap :: (SMap -> SMap) -> Level -> Level-updateSMap f lvl = lvl { lsmell = f (lsmell lvl) }+updateLRMap :: (TileMap -> TileMap) -> Level -> Level+updateLRMap f lvl = lvl { lrmap = f (lrmap lvl) } +updateIMap :: (IM.IntMap ([Item], [Item]) ->+               IM.IntMap ([Item], [Item])) -> Level+              -> Level+updateIMap f lvl = lvl { litem = f (litem lvl) }++updateSmell :: (SmellMap -> SmellMap) -> Level -> Level+updateSmell f lvl = lvl { lsmell = f (lsmell lvl) }+ updateMonsters :: (Party -> Party) -> Level -> Level updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) } @@ -45,84 +72,96 @@ emptyParty = IM.empty  instance Binary Level where-  put (Level nm hs sz@(sy,sx) ms lsmell lmap lmeta) =+  put (Level hs sx sy ms ls le li lm lrm lme lstairs) =         do-          put nm           put hs-          put sz+          put sx+          put sy           put ms-          put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]-          put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ]-          put lmeta+          put ls+          put le+          put (assert+                 (IM.null (IM.filter (\ (is1, is2) ->+                                       L.null is1 && L.null is2) li)+                 `blame` li) li)+          put lm+          put lrm+          put lme+          put lstairs   get = do-          nm <- get           hs <- get-          sz@(sy,sx) <- get+          sx <- get+          sy <- get           ms <- get-          xs <- get-          let lsmell = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)-          xs <- get-          let lmap   = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)-          lmeta <- get-          return (Level nm hs sz ms lsmell lmap lmeta)--type LMap = Map (Y,X) (Tile.Tile, Tile.Tile)-type SMap = Map (Y,X) Time+          ls <- get+          le <- get+          li <- get+          lm <- get+          lrm <- get+          lme <- get+          lstairs <- get+          return (Level hs sx sy ms ls le li lm lrm lme lstairs) -at         l p = fst (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l)-rememberAt l p = snd (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l)+at, rememberAt :: Level -> Loc -> (Kind.Id TileKind)+at         l p = lmap l Kind.! p+rememberAt l p = lrmap l Kind.! p --- Checks for the presence of movables. Does *not* check if the tile is open.-unoccupied :: [Movable] -> Loc -> Bool-unoccupied movables loc =-  all (\ m -> mloc m /= loc) movables+-- Note: representations with 2 maps leads to longer code and slower 'remember'.+iat, irememberAt :: Level -> Loc -> [Item]+iat         l p = fst $ IM.findWithDefault ([], []) p (litem l)+irememberAt l p = snd $ IM.findWithDefault ([], []) p (litem l)  -- Check whether one location is accessible from the other. -- Precondition: the two locations are next to each other. -- Currently only implements that the target location has to be open. -- TODO: in the future check flying for chasms, swimming for water, etc.-accessible :: LMap -> Loc -> Loc -> Bool-accessible lmap source target =-  let tgt = lmap `at` target-  in  Tile.open tgt+accessible :: Level -> Loc -> Loc -> Bool+accessible lvl _source target =+  let tgt = lvl `at` target+  in  Tile.isWalkable tgt  -- 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 Terrain.deDoor $ Tile.tterrain tgt of-        Just (Just n)  -> n < k-        _ -> False+openable :: Level -> Tile.SecretStrength -> Loc -> Bool+openable lvl k target =+  let le = lsecret lvl+      tgt = lvl `at` target+  in Tile.hasFeature F.Openable tgt ||+     (Tile.hasFeature F.Hidden tgt &&+      le IM.! target < k) -findLoc :: Level -> (Loc -> Tile.Tile -> Bool) -> Rnd Loc-findLoc l@(Level { lsize = sz, lmap = lm }) p =-  do-    loc <- locInArea ((0,0),sz)-    let tile = lm `at` loc-    if p loc tile-      then return loc-      else findLoc l p+-- Do not scatter items around, it's too much work for the player.+dropItemsAt :: [Item] -> Loc -> Level -> Level+dropItemsAt [] _loc = id+dropItemsAt items loc =+  let joinItems = L.foldl' (\ acc i -> snd (joinItem i acc))+      adj Nothing = Just (items, [])+      adj (Just (i, ri)) = Just (joinItems items i, ri)+  in  updateIMap (IM.alter adj loc) -findLocTry :: Int ->  -- try k times-              Level ->-              (Loc -> Tile.Tile -> Bool) ->  -- loop until satisfied-              (Loc -> Tile.Tile -> Bool) ->  -- only try to satisfy k times-              Rnd Loc-findLocTry k l@(Level { lsize = sz, lmap = lm }) p pTry =-  do-    loc <- locInArea ((0,0),sz)-    let tile = lm `at` loc-    if p loc tile && pTry loc tile-      then return loc-      else if k > 1-             then findLocTry (k - 1) l p pTry-             else findLoc l p+findLoc :: TileMap -> (Loc -> (Kind.Id TileKind) -> Bool) -> Rnd Loc+findLoc lmap p =+  let search = do+        loc <- randomR $ Kind.bounds lmap+        let tile = lmap Kind.! loc+        if p loc tile+          then return loc+          else search+  in search --- 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 { Tile.titems = joinItems items (Tile.titems t) }-      ntRemember = lmap `rememberAt` loc-  in  updateLMap (M.insert loc (nt, ntRemember)) lvl+findLocTry ::+  Int ->  -- try to pTry only so many times+  TileMap ->+  (Loc -> Kind.Id TileKind -> Bool) ->  -- loop until satisfied+  (Loc -> Kind.Id TileKind -> Bool) ->  -- only try to satisfy k times+  Rnd Loc+findLocTry numTries lmap p pTry =+  let search k = do+        loc <- randomR $ Kind.bounds lmap+        let tile = lmap Kind.! loc+        if p loc tile && pTry loc tile+          then return loc+          else if k > 1+            then search (k - 1)+            else findLoc lmap p+  in assert (numTries > 0) $+     search numTries
src/LevelState.hs view
@@ -1,28 +1,24 @@ module LevelState where -import qualified Color-import Geometry import Level import State-import Item import Grammar-import qualified Terrain-import qualified Tile--viewTile :: Bool -> Tile.Tile -> Assocs -> (Char, Color.Color)-viewTile b (Tile.Tile t [])    a = Terrain.viewTerrain b t-viewTile b (Tile.Tile t (i:_)) a = Item.viewItem (ikind i) a+import Loc+import Content.TileKind+import qualified Kind  -- | 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+lookAt :: Bool -> Bool -> State -> Level -> Loc -> String -> String+lookAt detailed canSee s lvl loc msg   | detailed  =-    Terrain.lookTerrain (Tile.tterrain (lmap `rememberAt` loc)) ++ " " ++ msg ++ isd+    let tile = lvl `rememberAt` loc+        name = tname . Kind.getKind $ tile+    in name ++ " " ++ msg ++ isd   | otherwise = msg ++ isd   where-    is  = Tile.titems (lmap `rememberAt` loc)+    is  = lvl `irememberAt` loc     prefixSee = if canSee then "You see " else "You remember "     prefixThere = if canSee                   then "There are several objects here"
+ src/Loc.hs view
@@ -0,0 +1,58 @@+module Loc+  ( Loc, toLoc, fromLoc, trLoc, zeroLoc, distance, adjacent, surroundings )+  where++import Geometry+import Utils.Assert++-- Loc is a positivie integer for speed and to enforce the use of wrappers+-- (we don't want newtype to avoid the trouble with using EnumMap+-- in place of IntMap, etc.). We represent the screen as a linear framebuffer,+-- when Loc is an Int offset counted from the first cell.+-- We do bounds check for the X size ASAP and each subsequent+-- array access performs another check, effectively for Y size.+-- After dungeon is generated (using (X, Y) points, not Loc), Locs are used+-- mainly as keys and not constructed often, so the performance will improve+-- due to smaller save files, IntMaps and cheaper array indexing,+-- including cheaper bounds checks.+type Loc = Int++toLoc :: X -> (X, Y) -> Loc+toLoc lxsize (x, y) =+  assert (lxsize > x && x >= 0 && y >= 0 `blame` (lxsize, x, y)) $+  x + y * lxsize++fromLoc :: X -> Loc -> (X, Y)+fromLoc lxsize loc =+  assert (loc >= 0 `blame` (lxsize, loc)) $+  (loc `rem` lxsize, loc `quot` lxsize)++-- | Translation by a vector, where dx and dy can be negative.+trLoc :: X -> Loc -> (X, Y) -> Loc+trLoc lxsize loc (dx, dy) =+  assert (loc >= 0 && res >= 0 `blame` (lxsize, loc, (dx, dy))) $+  res+   where res = loc + dx + dy * lxsize++zeroLoc :: Loc+zeroLoc = 0++-- | The distance between two points in the metric with diagonal moves.+distance :: X -> Loc -> Loc -> Int+distance lxsize loc0 loc1+  | (x0, y0) <- fromLoc lxsize loc0, (x1, y1) <- fromLoc lxsize loc1 =+  lenXY (x1 - x0, y1 - y0)++-- | Return whether two locations are adjacent on the map+-- (horizontally, vertically or diagonally).+-- A position is also considered adjacent to itself.+adjacent :: X -> Loc -> Loc -> Bool+adjacent lxsize s t = distance lxsize s t <= 1++-- | Return the 8, or less, surrounding locations of a given location.+surroundings :: X -> Y -> Loc -> [Loc]+surroundings lxsize lysize loc | (x, y) <- fromLoc lxsize loc =+  [ toLoc lxsize (x + dx, y + dy)+  | (dx, dy) <- movesXY,+    x + dx >= 0 && x + dx < lxsize &&+    y + dy >= 0 && y + dy < lysize ]
src/Main.hs view
@@ -1,19 +1,19 @@ module Main where  import System.Directory-import Data.Map as M+import qualified System.Random as R+import qualified Control.Monad.State as MState  import Action import State import DungeonState import qualified Display-import Random import qualified Save import Turn import qualified Config-import MovableAdd+import ActorAdd import Item-import qualified Keys as K+import qualified Keybindings as KB  main :: IO () main = Display.startup start@@ -23,23 +23,46 @@ start internalSession = do   config <- Config.config   let section = Config.getItems config "macros"-      !macros = K.macroKey section-      session = (internalSession, macros)+      !macros = KB.macroKey section+      sess = (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"+                     Display.displayBlankConfirm sess "Restoring save game"                      Save.restoreGame config               else return $ Right "Welcome to Allure of the Stars!"  -- 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 }+      -- TODO: move somewhere sane+      (dg, configD) <-+        case Config.getOption config "engine" "dungeonRandomGenerator" of+          Just sg ->+            return (read sg, config)+          Nothing -> do+            -- Pick the randomly chosen dungeon generator from the IO monad+            -- and record it in the config for debugging (can be 'D'umped).+            g <- R.getStdGen+            let gs = show g+                c = Config.set config "engine" "dungeonRandomGenerator" gs+            return (g, c)+      let ((ploc, lid, dng), ag) = MState.runState (generate configD) dg+          sflavour = MState.evalState dungeonFlavourMap ag+      (sg, sconfig) <-+        case Config.getOption configD "engine" "startingRandomGenerator" of+          Just sg ->+            return (read sg, configD)+          Nothing -> do+            -- Pick the randomly chosen starting generator from the IO monad+            -- and record it in the config for debugging (can be 'D'umped).+            g <- R.getStdGen+            let gs = show g+                c = Config.set configD "engine" "startingRandomGenerator" gs+            return (g, c)+      let defState = defaultState dng lid ploc sg+          state = defState{sconfig, sflavour}           hstate = initialHeroes ploc state-      handlerToIO session hstate msg handle+      handlerToIO sess hstate msg handle     Left state ->-      handlerToIO session state "Welcome back to Allure of the Stars." handle+      handlerToIO sess state "Welcome back to Allure of the Stars." handle
src/Message.hs view
@@ -1,6 +1,6 @@ module Message where -import Data.List as L+import qualified Data.List as L import Data.Char  type Message = String
− src/Movable.hs 
@@ -1,83 +0,0 @@-module Movable where--import Data.Binary-import Control.Monad--import Geometry-import Item-import MovableKind---- | Monster properties that are changing a lot. If they are dublets--- of properties form MovableKind, the intention is they may be modified--- temporarily, but will return to the original value over time. E.g., HP.-data Movable = Movable-  { mkind   :: !MovableKind,  -- ^ kind of the movable; TODO: make this Int-    mhp     :: !Int,       -- ^ current hit pints-    mdir    :: Maybe Dir,  -- ^ the direction of running-    mtarget :: Target,     -- ^ the target for distance attacks and AI-    mloc    :: !Loc,       -- ^ current location-    mitems  :: [Item],     -- ^ inventory-    mletter :: !Char,      -- ^ next inventory letter-    mtime   :: !Time }     -- ^ time of next action-  deriving Show--instance Binary Movable where-  put (Movable mk mhp md tgt ml minv mletter mtime) =-    do-      put mk-      put mhp-      put md-      put tgt-      put ml-      put minv-      put mletter-      put mtime-  get = do-          mk      <- get-          mhp     <- get-          md      <- get-          tgt     <- get-          ml      <- get-          minv    <- get-          mletter <- get-          mtime   <- get-          return (Movable mk mhp md tgt ml minv mletter mtime)--data Actor = AHero Int     -- ^ hero index (on the lheroes intmap)-           | AMonster Int  -- ^ monster index (on the lmonsters intmap)-  deriving (Show, Eq, Ord)--isAHero :: Actor -> Bool-isAHero (AHero _) = True-isAHero (AMonster _) = False--isAMonster :: Actor -> Bool-isAMonster = not . isAHero--instance Binary Actor 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 (Actor)"--data Target =-    TEnemy Actor 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/MovableAdd.hs 
@@ -1,109 +0,0 @@-module MovableAdd 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 Movable-import MovableState-import MovableKind-import Random-import qualified Config-import WorldLoc-import qualified Tile---- 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 :: MovableKind -> Int -> Loc -> Movable-template mk hp loc = Movable 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 = Tile.open (map `at` loc) && not (loc `L.elem` L.map mloc (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 {nhpMin = bHP, nhpMax = bHP, nsymbol = symbol, nname = 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 :: LevelId -> Int -> Rnd Bool-monsterGenChance (LambdaCave depth) numMonsters =-  chance $ 1%(fromIntegral (250 + 200 * (numMonsters - depth)) `max` 50)---- | Create a new monster in the level, at a random position.-addMonster :: MovableKind -> 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 -> Tile.open t-                       && not (l `L.elem` L.map mloc (hs ++ ms)))-             (\ l t -> Tile.floor t-                       && L.all (\ pl -> distance (mloc pl, l) > 400) hs)-      let fmk = Frequency $ L.zip (L.map nfreq dungeonMonsters) dungeonMonsters-      mk <- frequency fmk-      hp <- randomR (nhpMin mk, nhpMax mk)-      return $ addMonster mk hp loc state
− src/MovableKind.hs 
@@ -1,111 +0,0 @@-module MovableKind where--import Data.Binary-import Control.Monad--import Geometry-import Random-import qualified Color---- | Monster properties that are changing rarely and permanently.-data MovableKind = MovableKind-  { nhpMin  :: !Int          -- ^ minimal initial hp-  , nhpMax  :: !Int          -- ^ maximal possible and initial hp-  , nspeed  :: !Time         -- ^ natural speed-  , nsymbol :: !Char         -- ^ map symbol-  , ncolor  :: !Color.Color  -- ^ map color-  , nname   :: String        -- ^ name-  , nsight  :: !Bool         -- ^ can it see?-  , nsmell  :: !Bool         -- ^ can it smell?-  , niq     :: !Int          -- ^ intelligence-  , nregen  :: !Int          -- ^ regeneration interval-  , nfreq   :: !Int          -- ^ created that often-  }-  deriving (Show, Eq)--instance Binary MovableKind where-  put (MovableKind 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 (MovableKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq)---- | The list of kinds of monsters that appear randomly throughout the dungeon.-dungeonMonsters :: [MovableKind]-dungeonMonsters = [eye, fastEye, nose]--hero, eye, fastEye, nose :: MovableKind-hero = MovableKind-  { nhpMin  = 50,-    nhpMax  = 50,-    nspeed  = 10,-    nsymbol = '@',-    nname   = "you",-    ncolor  = Color.BrWhite,  -- Heroes white, monsters colorful.-    nsight  = True,-    nsmell  = False,-    niq     = 13,  -- Can see secret doors under alien control.-    nregen  = 1500,-    nfreq   = 0-  }--eye = MovableKind-  { nhpMin  = 1,  -- falls in 1--4 unarmed rounds-    nhpMax  = 12,-    nspeed  = 10,-    nsymbol = 'e',-    ncolor  = Color.BrRed,-    nname   = "the reducible eye",-    nsight  = True,-    nsmell  = False,-    niq     = 8,-    nregen  = 1500,-    nfreq   = 6-  }-fastEye = MovableKind-  { nhpMin  = 1,  -- falls in 1--2 unarmed rounds-    nhpMax  = 6,-    nspeed  = 4,-    nsymbol = 'e',-    ncolor  = Color.BrBlue,-    nname   = "the super-fast eye",-    nsight  = True,-    nsmell  = False,-    niq     = 12,-    nregen  = 1500,-    nfreq   = 1-  }-nose = MovableKind-  { nhpMin  = 6,  -- 2--5 and in 1 round of the strongest sword-    nhpMax  = 13,-    nspeed  = 11,-    nsymbol = 'n',-    ncolor  = Color.Green,-    nname   = "the point-free nose",-    nsight  = False,-    nsmell  = True,-    niq     = 0,-    nregen  = 1500,-    nfreq   = 2-  }
− src/MovableState.hs 
@@ -1,123 +0,0 @@-module MovableState 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 Movable-import Level-import Dungeon-import State-import WorldLoc---- 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 :: Actor -> State -> Maybe (LevelId, Movable)-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 -> Movable-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 -> [(Actor, LevelId)]-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 :: Actor -> (Movable -> Movable) -> 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) -> LevelId -> 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 mtarget (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 = mloc (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 :: Actor -> 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 :: Actor -> State -> Movable-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 :: Actor -> 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 :: Actor -> Movable -> 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 -> [Movable]-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 Actor-locToActor loc state =-  let l = locToActors loc state-  in assert (L.length l <= 1) $-       listToMaybe l--locToActors :: Loc -> State -> [Actor]-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) -> mloc m == loc) l-        in  fmap (injection . fst) im
− src/Multiline.hs 
@@ -1,8 +0,0 @@-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,44 +1,48 @@ module Perception where  import qualified Data.Set as S-import Data.List as L+import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe import Control.Monad -import Geometry+import Loc import State import Level-import Movable-import MovableState-import qualified MovableKind+import Actor+import ActorState+import Content.ActorKind import FOV import qualified Config import qualified Tile+import qualified Kind -data Perception =-  Perception { preachable :: S.Set Loc, pvisible :: S.Set Loc }+data Perception = Perception+  { preachable :: S.Set Loc+  , pvisible :: S.Set Loc+  }  -- The pplayer field is void if player not on the current level, -- or if the player controls a blind monster. 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 }+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) ->-              Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+              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)+                    return $ loc `S.member` projection hper       tryPl   = do  -- the case for a monster under player control                   guard $ Just actor == pl                   pper <- pplayer per@@ -46,14 +50,15 @@       tryAny  = tryHero `mplus` tryPl   in  fromMaybe False tryAny  -- assume not visible, if no perception found -actorSeesLoc    :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+actorSeesLoc    :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool actorSeesLoc    = actorPrLoc pvisible -actorReachesLoc :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+actorReachesLoc :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool actorReachesLoc = actorPrLoc preachable  -- Not quite correct if FOV not symmetric (Shadow).-actorReachesActor :: Actor -> Actor -> Loc -> Loc -> Perceptions -> Maybe Actor+actorReachesActor :: ActorId -> ActorId -> Loc -> Loc+                     -> Perceptions -> Maybe ActorId                      -> Bool actorReachesActor actor1 actor2 loc1 loc2 per pl =   actorReachesLoc actor1 loc2 per pl ||@@ -61,12 +66,17 @@  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 $ MovableKind.nsight (mkind m) then Blind else+  let lvl@Level{lheroes = hs} = slevel state+      mode   = Config.get config "engine" "fovMode"+      radius = let r = Config.get config "engine" "fovRadius"+               in if r < 1+                  then error $ "FOV radius is " ++ show r ++ ", should be >= 1"+                  else r+      fovMode m = if not $ asight $ Kind.getKind $ bkind m+                  then Blind+                  else         -- terrible, temporary hack         case sensory of           Vision 3 -> Digital radius@@ -78,14 +88,14 @@               "permissive" -> Permissive radius               "digital"    -> Digital radius               "shadow"     -> Shadow-              _            -> error $ "perception_: unknown mode: " ++ show mode+              _            -> error $ "Unknown FOV 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) (mloc m) lmap+                  in Just $ perception (fovMode m) (bloc m) lvl              else Nothing-      pers = IM.map (\ h -> perception (fovMode h) (mloc h) lmap) hs+      pers = IM.map (\ h -> perception (fovMode h) (bloc h) lvl) hs       lpers = maybeToList pper ++ IM.elems pers       reachable = S.unions (L.map preachable lpers)       visible = S.unions (L.map pvisible lpers)@@ -95,19 +105,20 @@  -- | Once we compute the reachable fields using FOV, it is possible -- to compute what the hero can actually see.-perception :: FovMode -> Loc -> LMap -> Perception-perception fovMode ploc lmap =+perception :: FovMode -> Loc -> Level -> Perception+perception fovMode ploc lvl@Level{lxsize, lysize} =   let     -- Reachable are all fields on an unblocked path from the hero position.-    reachable  = fullscan fovMode ploc lmap-    -- Everybody can see locations that have light and are reachable.-    uniVisible = S.filter (\ loc -> Tile.light (lmap `at` loc)) reachable+    -- The player position is visible, but not reachable (e.g. for targeting).+    reachable  = fullscan fovMode ploc lvl+    -- Everybody can see locations that are lit and are reachable.+    uniVisible = S.filter (\ loc -> Tile.isLit (lvl `at` loc)) reachable     -- The hero is assumed to carry a light source, too.     litVisible = S.insert ploc uniVisible     -- Reachable fields adjacent to lit fields are visible, too.     adjVisible =       S.filter-        (\ loc -> L.any (\ l -> S.member l litVisible) (surroundings loc))+        (L.any (`S.member` litVisible) . surroundings lxsize lysize)         reachable     -- Visible fields are either lit or adjacent to lit.     visible = S.union litVisible adjVisible
src/Random.hs view
@@ -1,17 +1,24 @@-module Random (module Frequency, module Random) where+module Random+  (Rnd, randomR, binaryChoice, chance,+   roll, oneOf, frequency, (*~), (~+~),+   RollDice, rollDice, maxDice, minDice, meanDice,+   RollQuad, rollQuad, intToQuad)+  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 +import Utils.Assert import Frequency +-- TODO: if the file grows much larger, split it and move a part to Utils/+ type Rnd a = State R.StdGen a --- Written in a "portable" way because the implementation of--- State changes between mtl versions 1 and 2.+-- TODO: rewrite; was written in a "portable" way because the implementation of+-- State changes between mtl versions 1 and 2. Now we are using only mtl 2. randomR :: (R.Random a) => (a, a) -> Rnd a randomR rng =   do@@ -31,12 +38,12 @@   do     let n = numerator r         d = denominator r-    k <- randomR (1,d)+    k <- randomR (1, d)     return (k <= n) --- | d for die/dice-d :: Int -> Rnd Int-d x = if x <= 0 then return 0 else randomR (1,x)+-- | roll a single die+roll :: Int -> Rnd Int+roll x = if x <= 0 then return 0 else randomR (1,x)  oneOf :: [a] -> Rnd a oneOf xs =@@ -45,25 +52,17 @@     return (xs !! r)  frequency :: Frequency a -> Rnd a-frequency (Frequency xs) =+frequency (Frequency fs) =   do-    r <- randomR (1, sum (map fst xs))-    return (frequency' r xs)+    r <- randomR (1, sum (map fst fs))+    return (frequency' r fs)  where   frequency' :: Int -> [(Int, a)] -> a-  frequency' _ [(_, x)] = x+  frequency' m []       = assert `failure` (map fst fs, m)   frequency' m ((n, x) : xs)     | m <= n            = x     | otherwise         = frequency' (m - n) xs -rndToIO :: Rnd a -> IO a-rndToIO r =-  do-    g <- R.getStdGen-    let (x,g') = runState r g-    R.setStdGen g'-    return x- -- ** Arithmetic operations on Rnd.  infixl 7 *~@@ -75,15 +74,30 @@ (*~) :: Num a => Int -> Rnd a -> Rnd a x *~ r = liftM sum (replicateM x r) --- RollDice: 1d7, 3d3, etc. (a, b) represent (a *~ d b).+-- RollDice: 1d7, 3d3, 2d0, etc. (a, b) represent (a *~ roll 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+  in a *~ roll b --- rollQuad (a, b, x, y) = a *~ d b + (lvl * (x *~ d y)) / 10+maxDice :: RollDice -> Int+maxDice (a', b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in a * b++minDice :: RollDice -> Int+minDice (a', b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in if b == 0 then 0 else a++meanDice :: RollDice -> Rational+meanDice (a', b') =+  let (a, b) = (fromIntegral a', fromIntegral b')+  in if b' == 0 then 0 else a * (b + 1) % 2++-- rollQuad (a, b, x, y) = a *~ roll b + (lvl * (x *~ roll y)) / 10 type RollQuad = (Binary.Word8, Binary.Word8, Binary.Word8, Binary.Word8)  rollQuad :: Int -> RollQuad -> Rnd Int@@ -94,7 +108,7 @@  intToQuad :: Int -> RollQuad intToQuad 0 = (0, 0, 0, 0)-intToQuad n = let n' = fromIntegral n+intToQuad n = let n' = toEnum n               in  if n' > maxBound || n' < minBound-                  then error "intToQuad"+                  then assert `failure` n                   else (n', 1, 0, 0)
src/Save.hs view
@@ -1,10 +1,9 @@ module Save where  import System.Directory-import Control.Exception as E hiding (handle)+import qualified Control.Exception as E hiding (handle) -import File-import Level+import Utils.File import State import qualified Config @@ -12,25 +11,22 @@ 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.+-- | We save a simple serialized version of the current state. saveGame :: State -> IO ()-saveGame state =-  do-    f <- file (sconfig state)-    encodeCompressedFile f (state, False)+saveGame state = do+  f <- file (sconfig state)+  encodeEOF f state --- | Restore a saved game. Returns either the current level and--- game state, or a string containing an error message if restoring--- the game fails.+-- | Restore a saved game. Returns either the current game state,+-- or a string containing an error message if restoring the game fails. restoreGame :: Config.CP -> IO (Either State String) restoreGame config =   E.catch (do              mvBkp config              f <- file config-             (x, z) <- strictDecodeCompressedFile (f ++ ".bkp")-             (z :: Bool) `seq` return $ Left x)-          (\ e -> case e :: IOException of+             state <- strictDecodeEOF (f ++ ".bkp")+             return (Left state))+          (\ e -> case e :: E.IOException of                     _ -> return (Right $                                    "Restore failed: "                                    ++ (unwords . lines) (show e)))@@ -43,10 +39,13 @@     renameFile f (f ++ ".bkp")  -- | Remove the backup of the savegame. Should be called before any--- non-error exit from the game.+-- non-error exit from the game. Sometimes it does not exist and it's OK.+-- We don't bother reporting any other exceptions, either, because the file+-- is relatively unimportant and because most probably the exception+-- would be reported for the main savefile, where it should not be overlooked. rmBkp :: Config.CP -> IO () rmBkp config =   do     f <- file config     E.catch (removeFile (f ++ ".bkp"))-      (\ e -> case e :: IOException of _ -> return ())+      (\ e -> case e :: E.IOException of _ -> return ())
src/State.hs view
@@ -2,63 +2,68 @@  import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.IntMap as IM-import Control.Monad+import qualified Data.IntSet as IS import Data.Binary import qualified Config+import qualified System.Random as R -import Movable+import Actor import Geometry+import Loc import Level-import Dungeon+import qualified Dungeon import Item import Message-import qualified ItemKind import WorldLoc  -- | 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 LevelId, removing the lname field--- and not removing the current level from the dungeon. data State = State-  { splayer      :: Actor,        -- ^ represents the player-controlled movable-    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+  { splayer      :: ActorId      -- ^ represents the player-controlled actor+  , scursor      :: Cursor       -- ^ cursor location and level to return to+  , shistory     :: [Message]+  , ssensory     :: SensoryMode+  , sdisplay     :: DisplayMode+  , stime        :: Time+  , sflavour     :: FlavourMap   -- ^ association of flavour to items+  , sdisco       :: Discoveries  -- ^ items (kinds) that have been discovered+  , sdungeon     :: Dungeon.Dungeon  -- ^ all but the current dungeon level+  , slid         :: LevelId+  , scounter     :: (Int, Int)   -- ^ stores next hero index and monster index+  , sparty       :: IS.IntSet    -- ^ heroes in the party+  , srandom      :: R.StdGen     -- ^ current random generator+  , sconfig      :: Config.CP   }   deriving Show  data Cursor = Cursor-  { ctargeting :: Bool,       -- ^ are we in targeting mode?-    clocLn     :: LevelId,  -- ^ cursor level-    clocation  :: Loc,        -- ^ cursor coordinates-    creturnLn  :: LevelId   -- ^ the level current player resides on+  { ctargeting :: Bool       -- ^ are we in targeting mode?+  , clocLn     :: LevelId    -- ^ cursor level+  , clocation  :: Loc        -- ^ cursor coordinates+  , creturnLn  :: LevelId    -- ^ the level current player resides on   }   deriving Show -defaultState :: Dungeon -> Level -> State-defaultState dng lvl =+slevel :: State -> Level+slevel State{slid, sdungeon} = sdungeon Dungeon.! slid++defaultState :: Dungeon.Dungeon -> LevelId -> Loc -> R.StdGen -> State+defaultState dng lid ploc g =   State-    (AHero 0)-    (Cursor False (LambdaCave (-1)) (-1, -1) (lname lvl))+    (AHero 0)  -- hack: the hero is not yet alive+    (Cursor False lid ploc lid)     []     Implicit Normal     0-    IM.empty+    M.empty     S.empty     dng-    lvl+    lid     (0, 0)-    (Config.defaultCP)+    IS.empty+    g+    Config.defaultCP  updateCursor :: (Cursor -> Cursor) -> State -> State updateCursor f s = s { scursor = f (scursor s) }@@ -70,12 +75,12 @@ updateTime f s = s { stime = f (stime s) }  updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State-updateDiscoveries f s = s { sdiscoveries = f (sdiscoveries s) }+updateDiscoveries f s = s { sdisco = f (sdisco s) }  updateLevel :: (Level -> Level) -> State -> State-updateLevel f s = s { slevel = f (slevel s) }+updateLevel f s = updateDungeon (Dungeon.adjust f (slid s)) s -updateDungeon :: (Dungeon -> Dungeon) -> State -> State+updateDungeon :: (Dungeon.Dungeon -> Dungeon.Dungeon) -> State -> State updateDungeon f s = s {sdungeon = f (sdungeon s)}  toggleVision :: State -> State@@ -95,7 +100,8 @@                                                     _         -> Terrain 4 }  instance Binary State where-  put (State player cursor hst sense disp time assocs discs dng lvl ct config) =+  put (State player cursor hst sense disp time flav disco dng lid ct+       party g config) =     do       put player       put cursor@@ -103,11 +109,13 @@       put sense       put disp       put time-      put assocs-      put discs+      put flav+      put disco       put dng-      put lvl+      put lid       put ct+      put party+      put (show g)       put config   get =     do@@ -117,14 +125,17 @@       sense  <- get       disp   <- get       time   <- get-      assocs <- get-      discs  <- get+      flav   <- get+      disco  <- get       dng    <- get-      lvl    <- get+      lid    <- get       ct     <- get+      party  <- get+      g      <- get       config <- get       return-        (State player cursor hst sense disp time assocs discs dng lvl ct config)+        (State player cursor hst sense disp time flav disco dng lid ct+         party (read g) config)  instance Binary Cursor where   put (Cursor act cln loc rln) =@@ -155,7 +166,7 @@           tag <- getWord8           case tag of             0 -> return Implicit-            1 -> liftM Vision get+            1 -> fmap Vision get             2 -> return Smell             _ -> fail "no parse (SensoryMode)" @@ -174,5 +185,5 @@           case tag of             0 -> return Normal             1 -> return Omniscient-            2 -> liftM Terrain get+            2 -> fmap Terrain get             _ -> fail "no parse (DisplayMode)"
src/StrategyState.hs view
@@ -1,32 +1,29 @@ module StrategyState where -import Data.List as L-import Data.Map as M-import Data.Set as S+import qualified Data.List as L import qualified Data.IntMap as IM import Data.Maybe import Control.Monad-import Control.Monad.State hiding (State)-import Control.Exception (assert)+import Control.Arrow -import Geometry+import Loc+import Dir import Level-import Movable-import MovableState-import MovableKind-import Random+import Actor+import ActorState+import Content.ActorKind+import Frequency import Perception import Strategy import State import Action import Actions import ItemAction-import qualified ItemKind+import Content.ItemKind import Item import qualified Effect import qualified Tile---- import Debug.Trace+import qualified Kind  {- Monster movement@@ -56,58 +53,51 @@ and moves into the approximate direction of the hero. -} -strategy :: Actor -> State -> Perceptions -> Strategy (Action ())-strategy actor-         oldState@(State { scursor = cursor,-                           splayer = pl,-                           stime   = time,-                           slevel  = Level { lname = ln,-                                             lsmell = nsmap,-                                             lmap = lmap } })-         per =---  trace (show time ++ ": " ++ show actor) $-    strategy+strategy :: ActorId -> State -> Perceptions -> Strategy (Action ())+strategy actor oldState@State{splayer = pl, stime = time} per =+    strat   where-    Movable { mkind = mk, mloc = me, mdir = mdir,-              mtarget = tgt, mitems = items } =+    lvl@Level{lsmell = nsmap, lxsize} = slevel oldState+    Actor { bkind = ak, bloc = me, bdir = ad,+            btarget = tgt, bitems = items } =       getActor actor oldState+    mk = Kind.getKind ak     delState = deleteActor actor oldState     enemyVisible a l =       -- We assume monster sight is infravision, so light has no significance.-      nsight mk && actorReachesActor a actor l me per Nothing ||+      asight 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+      memActor a delState && adjacent lxsize me l     -- If no heroes on the level, monsters go at each other. TODO: let them     -- earn XP by killing each other to make this dangerous to the player.-    hs = L.map (\ (i, m) -> (AHero i, mloc m)) $+    hs = L.map (AHero *** bloc) $          IM.assocs $ lheroes $ slevel delState-    ms = L.map (\ (i, m) -> (AMonster i, mloc m)) $+    ms = L.map (AMonster *** bloc) $          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 = mloc m-              in  if enemyVisible a l+          if memActor a delState+          then let l = bloc $ getActor a delState+               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+          else closest  -- enemy not on the level, temporarily chase others         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, mloc $ getPlayerBody delState) : hs+                         then (pl, bloc $ 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+          foeVisible = L.filter (uncurry enemyVisible) foes+          foeDist = L.map (\ (a, l) -> (distance lxsize me l, l, a)) foeVisible       in  case foeDist of             [] -> (TCursor, Nothing)             _  -> let (_, l, a) = L.minimum foeDist@@ -116,102 +106,98 @@     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 $ Tile.titems $ lmap `at` x)+                         let foeDir = towards lxsize me loc+                         in  only (\ x -> dirDistSq lxsize foeDir x <= 1)+    lootHere x     = not $ L.null $ lvl `iat` x     onlyLoot       = onlyMoves lootHere me-    exitHere       = (\ x -> let t = lmap `at` x in Tile.open t && Tile.isExit t)+    exitHere x     = let t = lvl `at` x in Tile.isExit t     onlyExit       = onlyMoves exitHere me-    onlyKeepsDir k = only (\ x -> maybe True (\ d -> distance (d, x) <= k) mdir)-    onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) mdir)-    onlyUnoccupied = onlyMoves (unoccupied (levelMonsterList delState)) me+    onlyKeepsDir k = only (\ x -> maybe True (\ d -> dirDistSq lxsize d x <= k) ad)+    onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) ad)+    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  -> niq mk + ipower i-                       Nothing -> niq mk-    openableHere   = openable openPower lmap+    openPower      = Tile.SecretStrength $+                     case strongestItem items "ring" of+                       Just i  -> aiq mk + jpower i+                       Nothing -> aiq mk+    openableHere   = openable lvl openPower     onlyOpenable   = onlyMoves openableHere me-    accessibleHere = accessible lmap me+    accessibleHere = accessible lvl me     onlySensible   = onlyMoves (\ l -> accessibleHere l || openableHere l) me-    focusedMonster = niq mk > 10+    focusedMonster = aiq 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+      L.map (\ x -> let sm = smelltime $ IM.findWithDefault+                                           (SmellTime 0) (me `shift` x) nsmap+                    in  (x, (sm - time) `max` 0)) (moves lxsize)     fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d -    strategy =+    strat =       fromDir True (onlyFoe moveFreely)       .| isJust floc .=> liftFrequency (msum freqs)       .| lootHere me .=> actionPickup       .| fromDir True moveAround     actionPickup = return $ actorPickupItem actor-    tis = Tile.titems $ lmap `at` me+    tis = lvl `iat` 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)+      [ (benefit * multi, actionApply (iname ik) i)       | i <- is,-        let ik = ItemKind.getIK (ikind i),+        let ik = Kind.getKind (jkind i),         let benefit =-              (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+              (1 + jpower i) * Effect.effectToBenefit (ieffect ik),         benefit > 0,-        nsight mk || not (ItemKind.jname ik == "scroll")]-    actionApply groupName item =-      applyGroupItem actor (applyToVerb groupName) item-    throwFreq is multi = if not $ nsight mk then mzero else Frequency-      [ (benefit * multi, actionThrow (ItemKind.jname ik) i)+        asight mk || iname ik /= "scroll"]+    actionApply groupName = applyGroupItem actor (applyToVerb groupName)+    throwFreq is multi = if not $ asight mk then mzero else Frequency+      [ (benefit * multi, actionThrow (iname ik) i)       | i <- is,-        let ik = ItemKind.getIK (ikind i),+        let ik = Kind.getKind (jkind i),         let benefit =-              - (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+              - (1 + jpower i) * Effect.effectToBenefit (ieffect 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+        iname ik /= "sword"]+    actionThrow groupName =+      zapGroupItem actor (fromJust floc) (zapToVerb groupName)     towardsFreq =-      let freqs = runStrategy $ fromDir False moveTowards-      in  if nsight mk && not (L.null freqs)-          then scale 30 $ head freqs+      let freqs2 = runStrategy $ fromDir False moveTowards+      in  if asight mk && not (L.null freqs2)+          then scale 30 $ head freqs2           else mzero-    moveTowards =-      onlySensible $-        onlyUnoccupied (towardsFoe moveFreely)-        .| towardsFoe moveFreely+    moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely)     moveAround =       onlySensible $-        (if nsight mk then onlyUnoccupied else id) $-          nsmell mk .=> L.foldr (.|) reject (L.map return smells)+        (if asight mk then onlyNoMs else id) $+          asmell mk .=> L.foldr ((.|) . return) reject smells           .| onlyOpenable moveFreely           .| moveFreely     moveFreely = onlyLoot moveRandomly                  .| onlyExit (onlyKeepsDir 2 moveRandomly)-                 .| niq mk > 15 .=> onlyKeepsDir 0 moveRandomly-                 .| niq mk > 10 .=> onlyKeepsDir 1 moveRandomly-                 .| niq mk > 5  .=> onlyKeepsDir 2 moveRandomly+                 .| aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly+                 .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly+                 .| aiq mk > 5  .=> onlyKeepsDir 2 moveRandomly                  .| onlyKeepsDir_9 moveRandomly                  .| moveRandomly+    onlyMoves :: (Loc -> Bool) -> Loc -> Strategy Dir -> Strategy Dir+    onlyMoves p l = only (\ x -> p (l `shift` x))+    moveRandomly :: Strategy Dir+    moveRandomly = liftFrequency $ uniform (moves lxsize) -dirToAction :: Actor -> Target -> Bool -> Dir -> Action ()-dirToAction actor tgt allowAttacks dir =-  assert (dir /= (0,0)) $ do+dirToAction :: ActorId -> Target -> Bool -> Dir -> Action ()+dirToAction actor tgt allowAttacks dir = do   -- set new direction-  updateAnyActor actor $ \ m -> m { mdir = Just dir, mtarget = tgt }+  updateAnyActor actor $ \ m -> m { bdir = Just dir, btarget = 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))--moveRandomly :: Strategy Dir-moveRandomly = liftFrequency $ uniform moves--wait :: Actor -> Strategy (Action ())+wait :: ActorId -> Strategy (Action ()) wait actor = return $ advanceTime actor
− src/Terrain.hs 
@@ -1,227 +0,0 @@-module Terrain-  (Terrain(Door), DL(Light, Dark), rock, opening, floorDark, floorLight, unknown, stairs, door, deDoor, isFloor, isFloorDark, isRock, isOpening, isUnknown, isOpen, isExit, deStairs, fromDL, toDL, isAlight, lookTerrain, viewTerrain) where--import Control.Monad--import Data.Binary-import Data.Maybe--import qualified Color-import Geometry-import WorldLoc--import Color-import Effect-import Random--data TileKind = TileKind-  { usymbol  :: !Char         -- ^ map symbol-  , uname    :: String        -- ^ name-  , ucolor   :: !Color.Color  -- ^ map color-  , ucolor2  :: !Color.Color  -- ^ map color when not in FOV-  , ufreq    :: !Int          -- ^ created that often (within a group?)-  , ufeature :: [Feature]     -- ^ properties-  }-  deriving (Show, Eq, Ord)--data Feature =-    Walkable         -- ^ actors can walk through-  | Clear            -- ^ actors can see through-  | Exit             -- ^ is an exit from a room-  | Lit Int          -- ^ emits light; radius 0 means just the tile is lit-  | Aura Effect      -- ^ sustains the effect continuously-  | Cause Effect     -- ^ causes the effect when triggered-  | Change TileKind  -- ^ transitions when triggered-  | Climbable VDir   -- ^ triggered by climbing-  | Openable         -- ^ triggered by opening-  | Closable         -- ^ triggered by closable-  | Secret RollDice  -- ^ triggered by searching a number of times-  deriving (Show, Eq, Ord)--wall, doorOpen, doorClosed, doorSecret :: TileKind  -- TODO: , opening, floorDark, floorLight, unknown--wall = TileKind-  { usymbol  = '#'-  , uname    = "A wall."-  , ucolor   = Color.BrWhite-  , ucolor2  = Color.defFG-  , ufreq    = 100-  , ufeature = []-  }--doorOpen = TileKind-  { usymbol  = '\''-  , uname    = "An open door."-  , ucolor   = Color.Yellow-  , ucolor2  = Color.BrBlack-  , ufreq    = 100-  , ufeature = [Walkable, Clear, Exit, Lit 0, Change doorClosed, Openable]-  }--doorClosed = TileKind-  { usymbol  = '+'-  , uname    = "A closed door."-  , ucolor   = Color.Yellow-  , ucolor2  = Color.BrBlack-  , ufreq    = 100-  , ufeature = [Exit, Change doorClosed, Closable]-  }--doorSecret = wall-  { ufeature = [Change doorClosed, Secret (7, 2)]-  }--data Terrain =-    Rock-  | Opening-  | Floor DL-  | Unknown-  | Stairs DL VDir (Maybe WorldLoc)-  | Door (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 Terrain where-  put Rock            = putWord8 0-  put Opening         = putWord8 1-  put (Floor dl)      = putWord8 2 >> put dl-  put Unknown         = putWord8 3-  put (Stairs dl d n) = putWord8 5 >> put dl >> put d >> put n-  put (Door o)        = putWord8 6 >> put o-  get = do-          tag <- getWord8-          case tag of-            0 -> return Rock-            1 -> return Opening-            2 -> liftM Floor get-            3 -> return Unknown-            5 -> liftM3 Stairs get get get-            6 -> liftM Door get-            _ -> fail "no parse (Terrain)"--instance Eq Terrain where-  Rock == Rock = True-  Opening == Opening = True-  Floor l == Floor l' = l == l'-  Unknown == Unknown = True-  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'-  Door o == Door o' = 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--rock, opening, floorDark, floorLight, unknown :: Terrain-rock = Rock-opening = Opening-floorDark = Floor Dark-floorLight = Floor Light-unknown = Unknown--stairs :: DL -> VDir -> Maybe WorldLoc -> Terrain-stairs = Stairs--deStairs :: Terrain -> Maybe (VDir, Maybe WorldLoc)-deStairs (Stairs _ vdir next) = Just (vdir, next)-deStairs _                    = Nothing--deDoor :: Terrain -> Maybe (Maybe Int)-deDoor (Door n) = Just n-deDoor _        = Nothing--door :: Maybe Int -> Terrain-door = Door--isFloor :: Terrain -> Bool-isFloor (Floor _) = True-isFloor _         = False--isFloorDark :: Terrain -> Bool-isFloorDark (Floor Dark) = True-isFloorDark _            = False--isRock :: Terrain -> Bool-isRock Rock = True-isRock _    = False--isOpening :: Terrain -> Bool-isOpening Opening = True-isOpening _       = False--isUnknown :: Terrain -> Bool-isUnknown Unknown = True-isUnknown _       = False---- | allows moves and vision-isOpen :: Terrain -> Bool-isOpen (Floor {})   = True-isOpen Opening      = True-isOpen (Door o)     = isNothing o-isOpen (Stairs {})  = True-isOpen _            = False---- | marks an exit from a room-isExit :: Terrain -> Bool-isExit (Stairs  {}) = True-isExit (Opening {}) = True-isExit (Door    {}) = True-isExit _            = 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 -> Bool-isAlight (Floor l)      = fromDL l-isAlight (Stairs l _ _) = fromDL l-isAlight _              = False---- | Produces a textual description for terrain, used if no objects--- are present.-lookTerrain :: Terrain -> String-lookTerrain (Floor _)         = "Floor."-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 Rock              = "Rock."-lookTerrain Unknown           = ""---- | 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 :: Bool -> Terrain -> (Char, Color.Color)-viewTerrain 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         -> ('.', def)-       (Floor d)       -> ('.', if d == Light then def else defDark)-       Unknown         -> (' ', def)-       (Stairs d p _)  -> (if p == Up then '<' else '>',-                           if d == Light then def else defDark)-       (Door (Just 0)) -> ('+', defDoor)-       (Door (Just _)) -> viewTerrain b Rock  -- secret door-       (Door Nothing)  -> ('\'', defDoor)
src/Tile.hs view
@@ -1,59 +1,93 @@ module Tile where -import Control.Monad-+import qualified Data.List as L+import qualified Data.Array.Unboxed as A import Data.Binary-import Data.List as L -import Item-import qualified Terrain+import Content.TileKind+import qualified Feature as F+import qualified Kind+import Geometry -data Tile = Tile-              { tterrain :: Terrain.Terrain,-                titems   :: [Item] }-  deriving Show+newtype SecretStrength = SecretStrength{secretStrength :: Time}+  deriving (Show, Eq, Ord)+instance Binary SecretStrength where+  put = put . secretStrength+  get = fmap SecretStrength get -instance Binary Tile where-  put (Tile t is) = put t >> put is-  get = liftM2 Tile get get+-- TODO: remove this file -unknownTile :: Tile-unknownTile = Tile Terrain.unknown []+wallId, openingId, floorLightId, floorDarkId, unknownId, doorOpenId, doorClosedId, doorSecretId, stairsUpId, stairsDownId :: Kind.Id TileKind+wallId = Kind.getId (\ t -> tsymbol t == '#' && (L.null $ tfeature t))+openingId = Kind.getId (\ t -> tsymbol t == '.' && kindHasFeature F.Exit t)+floorLightId =+  Kind.getId (\ t -> tsymbol t == '.' && kindHas [F.Lit] [F.Exit] t)+floorDarkId =+  Kind.getId (\ t -> tsymbol t == '.' && kindHas [] [F.Exit, F.Lit] t)+unknownId = Kind.getId ((== ' ') . tsymbol)+doorOpenId = Kind.getId (kindHasFeature F.Closable)+doorClosedId = Kind.getId (kindHasFeature F.Openable)+doorSecretId = Kind.getId (kindHasFeature F.Hidden)+stairsUpId = Kind.getId (kindHas [F.Lit, F.Climbable] [])+stairsDownId = Kind.getId (kindHas [F.Lit, F.Descendable] []) --- | blocks moves and vision-closed :: Tile -> Bool-closed = not . open+-- | The player can't tell if the tile is a secret door or not.+canBeSecretDoor :: Kind.Id TileKind -> Bool+canBeSecretDoor t =+  let u = Kind.getKind t+      s = Kind.getKind doorSecretId+  in tsymbol u == tsymbol s &&+     tname u == tname s &&+     tcolor u == tcolor s &&+     tcolor2 u == tcolor2 s -floor :: Tile -> Bool-floor = Terrain.isFloor . tterrain+isUnknown :: Kind.Id TileKind -> Bool+isUnknown t = t == unknownId -canBeDoor :: Tile -> Bool-canBeDoor t =-  case Terrain.deDoor $ tterrain t of-    Just o | secret o -> True-    _ ->-      Terrain.isRock (tterrain t) ||-      Terrain.isUnknown (tterrain t)+isOpening :: Kind.Id TileKind -> Bool+isOpening t = t == openingId -secret :: Maybe Int -> Bool-secret (Just n) | n /= 0 = True-secret _ = False+kindHasFeature :: F.Feature -> TileKind -> Bool+kindHasFeature f t = f `elem` tfeature t -isUnknown :: Tile -> Bool-isUnknown = Terrain.isUnknown . tterrain+kindHas :: [F.Feature] -> [F.Feature] -> TileKind -> Bool+kindHas yes no t = L.all (flip kindHasFeature t) yes &&+                   not (L.any (flip kindHasFeature t) no) -toOpen :: Bool -> Maybe Int-toOpen True = Nothing-toOpen False = Just 0+hasFeature :: F.Feature -> Kind.Id TileKind -> Bool+hasFeature f t = kindHasFeature f (Kind.getKind t) --- | allows moves and vision-open :: Tile -> Bool-open = Terrain.isOpen . tterrain+-- | Does not block vision. Essential for efficiency of FOV, hence tabulated.+clearTab :: A.UArray (Kind.Id TileKind) Bool+clearTab = let f _ k acc = kindHasFeature F.Clear k : acc+               clearAssocs = Kind.foldrWithKey f []+           in A.listArray Kind.boundsId clearAssocs --- | is lighted on its own-light :: Tile -> Bool-light = Terrain.isAlight . tterrain+isClear :: Kind.Id TileKind -> Bool+isClear i = clearTab A.! i --- | marks an exit from a room-isExit :: Tile -> Bool-isExit = Terrain.isExit . tterrain+-- | Is lit on its own. Essential for efficiency of Perception, hence tabulated.+litTab :: A.UArray (Kind.Id TileKind) Bool+litTab = let f _ k acc = kindHasFeature F.Lit k : acc+             litAssocs = Kind.foldrWithKey f []+         in A.listArray Kind.boundsId litAssocs++isLit :: Kind.Id TileKind -> Bool+isLit i = litTab A.! i++-- | Does not block land movement.+isWalkable :: Kind.Id TileKind -> Bool+isWalkable = hasFeature F.Walkable+++-- | Provides an exit from a room.+isExit :: Kind.Id TileKind -> Bool+isExit = hasFeature F.Exit++-- | Is a good candidate to deposit items, replace by other tiles, etc.+isBoring :: Kind.Id TileKind -> Bool+isBoring t =+  let fs = tfeature (Kind.getKind t)+      optional = [F.Exit, F.Lit]+      mandatory = [F.Walkable, F.Clear]+  in fs L.\\ optional `L.elem` L.permutations mandatory
src/Turn.hs view
@@ -1,10 +1,10 @@ module Turn where  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 Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.Ord as Ord import qualified Data.IntMap as IM import qualified Data.Char as Char@@ -18,8 +18,8 @@ import Keybindings import qualified Keys as K import Level-import Movable-import MovableState+import Actor+import ActorState import Random import State import Strategy@@ -64,25 +64,24 @@   do     debug "handle"     state <- get-    pl <- gets splayer-    let ptime = mtime (getPlayerBody state)  -- time of player's next move+    let ptime = btime (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-             -- the hero can't make a move yet; monsters first-             -- we redraw the map even between player moves so that the movements of fast-             -- 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) displayWithoutMessage-             handleMonsters-      else do-             handlePlayer -- it's the hero's turn!+      then handleMonsters  -- the hero can't make a move yet; monsters first+      else handlePlayer    -- it's the hero's turn! +    -- TODO: readd this, but only for the turns when anything moved+    -- and only after a rendering delay is added, so that the move is visible+    -- on modern computers. Use the same delay for running (not disabled now).+    -- We redraw the map even between player moves so that the movements of fast+    -- monsters can be traced on the map.+    -- displayGeneric ColorFull (const "")+ -- | 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@@ -92,15 +91,15 @@     pl   <- gets splayer     if IM.null ms       then nextMove-      else let order  = Ord.comparing (mtime . snd)+      else let order  = Ord.comparing (btime . snd)                (i, m) = L.minimumBy order (IM.assocs ms)                actor = AMonster i-           in  if mtime m > time || actor == pl+           in  if btime m > time || actor == pl                then nextMove  -- no monster is ready for another move                else handleMonster actor  -- | Handle the move of a single monster.-handleMonster :: Actor -> Action ()+handleMonster :: ActorId -> Action () handleMonster actor =   do     debug "handleMonster"@@ -108,7 +107,7 @@     per <- currentPerception     -- Run the AI: choses an action from those given by the AI strategy.     action <--      liftIO $ rndToIO $+      rndToAction $         frequency (head (runStrategy (strategy actor state per .| wait actor)))     action     handleMonsters@@ -136,21 +135,22 @@     remember  -- the hero perceives his (potentially new) surroundings     -- determine perception before running player command, in case monsters     -- have opened doors ...-    oldPlayerTime <- gets (mtime . getPlayerBody)+    oldPlayerTime <- gets (btime . getPlayerBody)     withPerception playerCommand -- get and process a player command     -- at this point, the command was successful and possibly took some time-    newPlayerTime <- gets (mtime . getPlayerBody)+    newPlayerTime <- gets (btime . getPlayerBody)     if newPlayerTime == oldPlayerTime       then withPerception handlePlayer  -- no time taken, repeat       else do         state <- get         pl    <- gets splayer         let time = stime state-            ploc = mloc (getPlayerBody state)+            ploc = bloc (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))))+          modify (updateLevel (updateSmell (IM.insert ploc+                                             (SmellTime (time + sTimeout)))))         -- determine player perception and continue with monster moves         withPerception handleMonsters @@ -158,12 +158,13 @@ playerCommand :: Action () playerCommand =   do+    lxsize <- gets (lxsize . slevel)     display -- draw the current surroundings     history -- update the message history and reset current message-    tryRepeatedlyWith stopRunning $ do -- on abort, just ask for a new command+    tryRepeatedlyWith stopRunning $  -- on abort, just ask for a new command       ifRunning continueRun $ do         k <- session nextCommand-        handleKey stdKeybindings k+        handleKey lxsize stdKeybindings k                -- Design thoughts (in order to get rid or partially rid of the somewhat               -- convoluted design we have): We have three kinds of commands.@@ -199,16 +200,17 @@ -- functions.  -- TODO: Should be defined in Command module.-helpCommand      = Described "display help"      displayHelp+helpCommand :: Described (Action ())+helpCommand = Described "display help"      displayHelp  -- | Display command help. TODO: Should be defined in Actions module. displayHelp :: Action () displayHelp = do-  let coImage session k =-        let macros = snd session+  let coImage sess k =+        let macros = snd sess             domain = M.keysSet macros-        in  if k `S.member` domain then [] else [k]-            ++ [ from | (from, to) <- M.assocs macros, to == k ]+        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@@ -228,9 +230,7 @@     kother = M.fromList $              heroSelection ++              [ -- interaction with the dungeon-               (K.Char 'o',  openCommand),                (K.Char 'c',  closeCommand),-               (K.Char 's',  searchCommand),                 (K.Char '<',  ascendCommand),                (K.Char '>',  descendCommand),@@ -249,8 +249,7 @@                (K.Char 'a',  aimCommand),                 -- wait-               -- (K.Char ' ',  waitCommand),  -- dangerous, space is -more- key-               (K.Char '.',  waitCommand),+               (K.Char '.',  Undescribed playerAdvanceTime),                 -- saving or ending the game                (K.Char 'X',  saveCommand),
+ src/Utils/Assert.hs view
@@ -0,0 +1,55 @@+module Utils.Assert (assert, blame, failure, allB, checkM, trueM, falseM) where++import Control.Exception (assert)+import Debug.Trace (trace)++infix 1 `blame`+-- | If the condition fails, Display the value blamed for the failure.+-- Used as in "assert (c /= 0 `blame` c) $ 10 / c".+blame :: Show a => Bool -> a -> Bool+{-# INLINE blame #-}+blame condition blamed+  | condition = True+  | otherwise =+    let s = "Contract failed and the following is to blame:\n" +++            "  " ++ show blamed+    in trace s False++-- | Like Prelude.undefined, but shows the source location+-- and also the value to blame for the failure. To be used as in:+-- assert `failure` ((x1, y1), (x2, y2), "designate a vertical line")+failure :: Show a => (Bool -> b -> b) -> a -> b+{-# INLINE failure #-}+failure assrt blamed =+  let s = "Internal failure occured and the following is to blame:\n" +++          "  " ++ show blamed+  in trace s $+     assrt False (error "Assert.failure: no error location (upgrade to GHC 7.4)")++-- | Like List.all, but if the predicate fails, blame all the list elements+-- and especially those for which it fails. To be used as in:+-- assert (allB (>= 0) [yf, xf, y1, x1, y2, x2])+allB :: Show a => (a -> Bool) -> [a] -> Bool+{-# INLINE allB #-}+allB predicate l =+  let s = show (filter (not . predicate) l) ++ " in the context of " ++ show l+  in blame (all predicate l) s++-- | Check that the value returned from a monad action satisfies a predicate.+-- Reports source location and the suspects. Drops the value.+checkM :: (Show a, Monad m) =>+          (Bool -> m () -> m ()) -> (c -> Bool) -> a -> c -> m ()+checkM assrt predicate blamed value+  | predicate value = return ()+  | otherwise =+    let s = "The returned value is wrong and the following is to blame:\n" +++            "  " ++ show blamed+    in trace s $+       assrt False+         (error "Assert.checkM: no error location (upgrade to GHC 7.4)")++-- | Verifies that the returned value is true (respectively, false). Used as in:+-- open newValve >>= assert `trueM` (newValve, "is already opened, not new")+trueM, falseM :: (Show a, Monad m) => (Bool -> m () -> m ()) -> a -> Bool -> m ()+trueM  assrt = checkM assrt id+falseM assrt = checkM assrt not
+ src/Utils/File.hs view
@@ -0,0 +1,34 @@+module Utils.File (encodeEOF, strictDecodeEOF) where++import System.IO+import Data.Binary+import qualified Data.ByteString.Lazy as LBS+import qualified Codec.Compression.Zlib as Z++-- Note that LBS.writeFile opens the file in binary mode.+encodeCompressedFile :: Binary a => FilePath -> a -> IO ()+encodeCompressedFile f = LBS.writeFile f . Z.compress . encode++-- The "OK" is used as an EOF marker to ensure any problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary a => FilePath -> a -> IO ()+encodeEOF f a = encodeCompressedFile f (a, "OK")++strictReadCompressedFile :: FilePath -> IO LBS.ByteString+strictReadCompressedFile f =+  withBinaryFile f ReadMode $ \ h -> do+    c <- LBS.hGetContents h+    let d = Z.decompress c+    LBS.length d `seq` return d++strictDecodeCompressedFile :: Binary a => FilePath -> IO a+strictDecodeCompressedFile = fmap decode . strictReadCompressedFile++-- The "OK" EOF marker ensures any detectable file corruption+-- is discovered and reported before the function returns.+strictDecodeEOF :: Binary a => FilePath -> IO a+strictDecodeEOF f = do+  (a, n) <- strictDecodeCompressedFile f+  if n == "OK"+    then return a+    else error $ "Fatal error: corrupted file " ++ f
+ src/Utils/Multiline.hs view
@@ -0,0 +1,8 @@+module Utils.Multiline (multiline) where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TQ++-- | Handle multiline verbatim string expressions.+multiline :: TQ.QuasiQuoter+multiline  = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined
src/WorldLoc.hs view
@@ -1,16 +1,16 @@-module WorldLoc where+module WorldLoc+  ( LevelId(..), levelName, levelNumber, WorldLoc) where -import Control.Monad import Data.Binary-import Geometry+import Loc --- | Level ids are just integers.+-- | Level ids are integers and (for now) ordered linearly. newtype LevelId = LambdaCave Int   deriving (Show, Eq, Ord)  instance Binary LevelId where   put (LambdaCave n) = put n-  get = liftM LambdaCave get+  get = fmap LambdaCave get  -- | Name of a level. levelName :: LevelId -> String
+ src/config.bot view
@@ -0,0 +1,62 @@+; This is the default config file, included in the binary itself.+; The game looks for the user config file in ~/.Allure/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 ~/.Allure/+; as described in README.md. In this way, you will not accidentally+; commit your private high scores (nor your save files) to the game+; git repository.++[dungeon]+; fixed caves for the first levels, then randomly picked caves+LambdaCave_1: caveRogue+LambdaCave_2: caveRogue+LambdaCave_3: caveEmpty+; access to stairs may be blocked, so normally only suitable for the last level:+LambdaCave_4: caveNoise+depth: 1000++[engine]+fovMode: digital+;fovMode: permissive+;fovMode: shadow+fovRadius: 4+;startingRandomGenerator: 42+;dungeonRandomGenerator: 42+;BotAllure 42 20000000 | Allure > /tmp/log++; paths to various game files; relative to ~/.Allure/+; (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: 1000000+extraHeroes: 4+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.+;+; Handy with Vi keys:+comma: g+; Angband compatibility:+v: t++[monsters]+smellTimeout: 1000++[ui]+historyMax: 500
src/config.default view
@@ -4,16 +4,17 @@ ; options are case-sensitive and permitting only ';' comments.  ; If you contribute to the game, please create directory ~/.Allure/-; as described in README.markdown. In this way, you will not accidentally+; as described in README.md. 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+; fixed caves for the first levels, then randomly picked caves+LambdaCave_1: caveRogue+LambdaCave_2: caveRogue+LambdaCave_3: caveEmpty ; access to stairs may be blocked, so only suitable for the last level:-LambdaCave_10: noiseRoom-LambdaCave_3: bigRoom+LambdaCave_10: caveNoise depth: 10  [engine]@@ -21,6 +22,8 @@ ;fovMode: permissive ;fovMode: shadow fovRadius: 40+;startingRandomGenerator: 42+;dungeonRandomGenerator: 42  ; paths to various game files; relative to ~/.Allure/ ; (or analogous prefixes for other OSes, see getAppUserDataDirectory)@@ -46,7 +49,9 @@ ; TODO: in gtk it could be implemented via unGetChan, ; unless we prefer an explicit command queue, with flushing, etc. ;-; Angband compatibility+; Handy with Vi keys:+comma: g+; Angband compatibility: v: t  [monsters]