packages feed

Allure (empty) → 0.4.1

raw patch · 58 files changed

+6776/−0 lines, 58 filesdep +ConfigFiledep +MissingHdep +basesetup-changedbinary-added

Dependencies added: ConfigFile, MissingH, base, binary, bytestring, containers, directory, filepath, gtk, hscurses, mtl, old-time, random, template-haskell, vty, zlib

Files

+ Allure.cabal view
@@ -0,0 +1,69 @@+cabal-version: >= 1.6+name:          Allure+version:       0.4.1+license:       BSD3+license-file:  LICENSE+tested-with:   GHC==7.0.3+data-files:    LICENSE, CREDITS, PLAYING.markdown,+               README.markdown, src/config.default, 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,+               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,+synopsis:      Near-future roguelike game in early development+homepage:      http://github.com/Mikolaj/Allure+category:      Game+build-type:    Simple++flag curses+  description:   enable curses support+  default:       False++flag vty+  description:   enable vty 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,+                 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+  if flag(curses) {+    other-modules: Display.Curses+    build-depends: hscurses >= 1.3 && < 2+    cpp-options:   -DCURSES+    extra-libraries: curses+  } else { if flag(vty) {+    other-modules: Display.Vty+    build-depends: vty >= 4.4+  } else {+    other-modules: Display.Gtk+    build-depends: gtk >= 0.11 && < 0.13+    cpp-options:   -DGTK+    ghc-options:   -threaded+  } }++Source-repository head+  type:              git+  location:          git://github.com/Mikolaj/Allure.git
+ CREDITS view
@@ -0,0 +1,6 @@+All kinds of contributions to Allure of the Stars are gratefully welcome!+Some of the contributors are listed below, in chronological order.++Andres Loeh+Mikolaj Konarski+Krzysztof Pławski
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2008--2011 Andres Loeh+Copyright (c) 2010--2011 Mikolaj Konarski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ PLAYING.markdown view
@@ -0,0 +1,152 @@+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.
+ README.markdown view
@@ -0,0 +1,58 @@+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
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ scores view

binary file changed (absent → 144 bytes)

+ src/Action.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+module Action where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.List as L+import qualified Data.IntMap as IM+-- import System.IO (hPutStrLn, stderr) -- just for debugging++import Perception+import Display hiding (display)+import Message+import State+import Level+import Movable+import MovableState+import MovableKind+import qualified Save++newtype Action a = Action+  { runAction ::+      forall r .+      Session ->+      IO r ->                             -- shutdown cont+      Perceptions ->                      -- cached perception+      (State -> Message -> a -> IO r) ->  -- continuation+      IO r ->                             -- failure/reset cont+      State ->                            -- current state+      Message ->                          -- current message+      IO r+  }++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)++-- | Distributes the session and shutdown continuation,+-- threads the state and message.+bindAction :: Action a -> (a -> Action b) -> Action b+bindAction m f = Action (\ s e p k a st ms ->+                           let next nst nm x =+                                 runAction (f x) s e p k a nst nm+                           in  runAction m s e p next a st ms)++instance MonadIO Action where+  liftIO x = Action (\ s e p k a st ms -> x >>= k st ms)++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 ())++-- | Exported function to run the monad.+handlerToIO :: Session -> State -> Message -> Action () -> IO ()+handlerToIO session state msg h =+  runAction h+    session+    (Save.rmBkp (sconfig state) >> shutdown session)  -- get out of the game+    (perception_ state)        -- cached perception+    (\ _ _ x -> return x)      -- final continuation returns result+    (ioError $ userError "unhandled abort")+    state+    msg++-- | 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)++-- | 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 the current message.+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 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)++-- | Set the current message.+messageWipeAndSet :: Message -> Action ()+messageWipeAndSet nm = Action (\ s e p k a st ms -> k st nm ())++-- | Add to the current message.+messageAdd :: Message -> Action ()+messageAdd nm = Action (\ s e p k a st ms -> k st (addMsg ms nm) ())++-- | Clear the current message.+resetMessage :: Action Message+resetMessage = Action (\ s e p k a st ms -> k st "" ms)++-- | Get the current message.+currentMessage :: Action Message+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)++-- | 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"++-- | Set the current exception handler. First argument is the handler,+-- second is the computation the handler scopes over.+tryWith :: Action () -> Action () -> Action ()+tryWith exc h = Action (\ s e p k a st ms -> runAction h s e p k (runAction exc s e p k a st ms) st ms)++-- | Takes a handler and a computation. If the computation fails, the+-- handler is invoked and then the computation is retried.+tryRepeatedlyWith :: Action () -> Action () -> Action ()+tryRepeatedlyWith exc h = tryWith (exc >> tryRepeatedlyWith exc h) h++-- | Try the given computation and silently catch failure.+try :: Action () -> Action ()+try = tryWith (return ())++-- | Try the given computation until it succeeds without failure.+tryRepeatedly :: Action () -> Action ()+tryRepeatedly = tryRepeatedlyWith (return ())++-- | Print a debug message or ignore.+debug :: String -> Action ()+debug x = return () -- liftIO $ hPutStrLn stderr x++-- | Print the given message, then abort.+abortWith :: Message -> Action a+abortWith msg = do+  messageWipeAndSet msg+  display+  abort++neverMind :: Bool -> Action a+neverMind b = abortIfWith b "never mind"++-- | Abort, and print the given message if the condition is true.+abortIfWith :: Bool -> Message -> Action a+abortIfWith True msg = abortWith msg+abortIfWith False _  = abortWith ""++-- | Print message, await confirmation. Return value indicates+-- if the player tried to abort/escape.+messageMoreConfirm :: Bool -> Message -> Action Bool+messageMoreConfirm blackAndWhite msg = do+  messageAdd (msg ++ more)+  if blackAndWhite then displayBW else display+  session getConfirm++-- | Print message, await confirmation, ignore confirmation.+messageMore :: Message -> Action ()+messageMore msg = resetMessage >> messageMoreConfirm False 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+  session getYesNo++-- | Print a message and an overlay, await confirmation. Return value+-- indicates if the player tried to abort/escape.+messageOverlayConfirm :: Message -> String -> Action Bool+messageOverlayConfirm msg txt = messageOverlaysConfirm msg [txt]++-- | 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 [] =+  do+    resetMessage+    display+    return True+messageOverlaysConfirm msg (x:xs) =+  do+    messageWipeAndSet msg+    b <- overlay (x ++ more)+    if b+      then do+        b <- session getConfirm+        if b+          then do+            messageOverlaysConfirm msg xs+          else stop+      else stop+  where+    stop = do+      resetMessage+      display+      return False++-- | Update the cached perception for the given computation.+withPerception :: Action () -> Action ()+withPerception h = Action (\ s e _ k a st ms ->+                            runAction h s e (perception_ st) k a st ms)++-- | Get the current perception.+currentPerception :: Action Perceptions+currentPerception = Action (\ s e p k a st ms -> k st ms p)++-- | If in targeting mode, check if the current level is the same+-- as player level and refuse performing the action otherwise.+checkCursor :: Action () -> Action ()+checkCursor h = do+  cursor <- gets scursor+  level  <- gets slevel+  if creturnLn cursor == lname level+    then h+    else abortWith "this command does not work on remote levels"++updateAnyActor :: Actor -> (Movable -> Movable) -> Action ()+updateAnyActor actor f = modify (updateAnyActorBody actor f)++updatePlayerBody :: (Movable -> Movable) -> Action ()+updatePlayerBody f = do+  pl <- gets splayer+  updateAnyActor pl f++-- | Advance the move time for the given actor.+advanceTime :: Actor -> Action ()+advanceTime actor = do+  time <- gets stime+  let upd m = m { mtime = time + (nspeed (mkind m)) }+  -- A hack to synchronize the whole party:+  pl <- gets splayer+  if (actor == pl || isAHero actor)+    then do+           modify (updateLevel (updateHeroes (IM.map upd)))+           when (not $ isAHero pl) $ updatePlayerBody upd+    else updateAnyActor actor upd++playerAdvanceTime :: Action ()+playerAdvanceTime = do+  pl <- gets splayer+  advanceTime pl
+ src/Actions.hs view
@@ -0,0 +1,634 @@+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 qualified Data.IntMap as IM+import Data.Maybe+import Data.Set as S+import System.Time++import Action+import Display hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified ItemKind+import qualified Keys as K+import Level+import LevelState+import Message+import Movable+import MovableState+import MovableKind+import MovableAdd+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++-- The Action stuff that is independent from ItemAction.hs.+-- (Both depend on EffectAction.hs).++displayHistory :: Action ()+displayHistory =+  do+    hst <- gets shistory+    messageOverlayConfirm "" (unlines hst)+    abort++dumpConfig :: Action ()+dumpConfig =+  do+    config <- gets sconfig+    let fn = "config.dump"+    liftIO $ Config.dump fn config+    abortWith $ "Current configuration dumped to file " ++ fn ++ "."++saveGame :: Action ()+saveGame =+  do+    b <- messageYesNo "Really save?"+    if b+      then do+        -- Save the game state+        st <- get+        liftIO $ Save.saveGame st+        ln <- gets (lname . slevel)+        let total = calculateTotal st+            status = H.Camping ln+        go <- handleScores False status total+        when go $ messageMore "See you soon, stronger and braver!"+        end+      else abortWith "Game resumed."++quitGame :: Action ()+quitGame =+  do+    b <- messageYesNo "Really quit?"+    if b+      then end -- no highscore display for quitters+      else abortWith "Game resumed."++-- | End targeting mode, accepting the current location or not.+endTargeting :: Bool -> Action ()+endTargeting accept = do+  returnLn <- gets (creturnLn . scursor)+  target   <- gets (mtarget . getPlayerBody)+  cloc     <- gets (clocation . scursor)+  lvlSwitch returnLn  -- return to the original level of the player+  modify (updateCursor (\ c -> c { ctargeting = False }))+  let isEnemy = case target of TEnemy _ _ -> True ; _ -> False+  when (not isEnemy) $+    if accept+       then updatePlayerBody (\ p -> p { mtarget = TLoc cloc })+       else updatePlayerBody (\ p -> p { mtarget = TCursor })+  endTargetingMsg++endTargetingMsg :: Action ()+endTargetingMsg = do+  pkind    <- gets (mkind . getPlayerBody)+  target <- gets (mtarget . getPlayerBody)+  state  <- get+  let verb = "target"+      targetMsg = case target of+                    TEnemy a _ll ->+                      case findActorAnyLevel a state of+                        Just (_, m) -> objectMovable (mkind m)+                        Nothing     -> "a long gone adversary"+                    TLoc loc -> "location " ++ show loc+                    TCursor  -> "current cursor position continuously"+  messageAdd $ subjectMovableVerb pkind verb ++ " " ++ targetMsg ++ "."++-- | Cancel something, e.g., targeting mode, resetting the cursor+-- to the position of the player. Chosen target is not invalidated.+cancelCurrent :: Action ()+cancelCurrent = do+  targeting <- gets (ctargeting . scursor)+  if targeting+    then endTargeting False+    else abortWith "Press Q to quit."++-- | Accept something, e.g., targeting mode, keeping cursor where it was.+-- Or perform the default action, if nothing needs accepting.+acceptCurrent :: Action () -> Action ()+acceptCurrent h = do+  targeting <- gets (ctargeting . scursor)+  if targeting+    then endTargeting True+    else h  -- nothing to accept right now++moveCursor :: Dir -> Int -> Action ()+moveCursor dir n = do+  (sy, sx) <- gets (lsize . slevel)+  let upd cursor =+        let (ny, nx) = iterate (`shift` dir) (clocation cursor) !! n+            cloc = (max 1 $ min ny (sy-1), max 1 $ min nx (sx-1))+        in  cursor { clocation = cloc }+  modify (updateCursor upd)+  doLook++move :: Dir -> Action ()+move dir = do+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if targeting then moveCursor dir 1 else moveOrAttack True True pl dir++run :: Dir -> Action ()+run dir = do+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if targeting+    then moveCursor dir 10+    else do+      updatePlayerBody (\ p -> p { mdir = Just dir })+      -- attacks and opening doors disallowed while running+      moveOrAttack False False pl dir++-- | This function implements the actual "logic" of running. It checks if we+-- have to stop running because something interested happened, and it checks+-- if we have to adjust the direction because we're in the corner of a corridor.+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+    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))+        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)+    -- 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 =+          -- 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+          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+                    [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+              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)++ifRunning :: (Dir -> Action a) -> Action a -> Action a+ifRunning t e =+  do+    mdir <- gets (mdir . getPlayerBody)+    maybe e t mdir++-- | 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)))++-- | 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)++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++-- | Attempt a level switch to k levels deeper.+-- TODO: perhaps set up some level name arithmetics in Level.hs+-- and hide there the fact levels are now essentially Ints.+lvlDescend :: Int -> Action ()+lvlDescend k =+  do+    state <- get+    let n = levelNumber (lname (slevel state))+        nln = n + k+    when (nln < 1 || nln > sizeDungeon (sdungeon state) + 1) $+      abortWith "no more levels in this direction"+    assertTrue $ liftM (k == 0 ||)  (lvlSwitch (LambdaCave nln))++-- | Attempt a level change via up level and down level keys.+-- Will quit the game if the player leaves the dungeon.+lvlChange :: VDir -> Action ()+lvlChange vdir =+  do+    cursor    <- gets scursor+    targeting <- gets (ctargeting . scursor)+    pbody     <- gets getPlayerBody+    pl        <- gets splayer+    map       <- gets (lmap . slevel)+    let loc = if targeting then clocation cursor else mloc pbody+    case Terrain.deStairs $ tterrain $ map `at` loc of+      Just (vdir', next)+        | vdir == vdir' -> -- stairs are in the right direction+          case next of+            Nothing ->+              -- we are at the "end" of the dungeon+              if targeting+              then abortWith "cannot escape dungeon in targeting mode"+              else do+                b <- messageYesNo "Really escape the dungeon?"+                if b+                  then fleeDungeon+                  else abortWith "Game resumed."+            Just (nln, nloc) -> do+              if targeting+                then do+                  -- this assertion says no stairs go back to the same level+                  assertTrue $ lvlSwitch nln+                  -- do not freely reveal the other end of the stairs+                  map <- gets (lmap . slevel)  -- lvlSwitch modifies map+                  let upd cursor =+                        let cloc = if isUnknown (rememberAt map nloc)+                                   then loc+                                   else nloc+                        in  cursor { clocation = cloc, clocLn = nln }+                  modify (updateCursor upd)+                  doLook+                else tryWith (abortWith "somebody blocks the staircase") $ do+                  -- Remove the player from the old level.+                  modify (deleteActor pl)+                  -- At this place the invariant that the player exists fails.+                  -- Change to the new level (invariant not needed).+                  assertTrue $ lvlSwitch nln+                  -- Add the player to the new level.+                  modify (insertActor pl pbody)+                  -- At this place the invariant is restored again.+                  -- Land the player at the other end of the stairs.+                  updatePlayerBody (\ p -> p { mloc = 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.+                  -- Create a backup of the savegame.+                  state <- get+                  liftIO $ 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 }+          modify (updateCursor upd)+          doLook+        else+          let txt = if vdir == Up then "up" else "down"+          in  abortWith ("no stairs " ++ txt)++-- | Hero has left the dungeon.+fleeDungeon :: Action ()+fleeDungeon =+  do+    state <- get+    let total = calculateTotal state+        items = L.concatMap mitems (levelHeroList state)+    if total == 0+      then do+             go <- resetMessage >> messageMoreConfirm False "Coward!"+             when go $+               messageMore "Next time try to grab some loot before escape!"+             end+      else do+             let winMsg = "Congratulations, you won! Your loot, worth " +++                          show total ++ " gold, is:"+             displayItems winMsg True items+             go <- session getConfirm+             when go $ do+               go <- handleScores True H.Victor total+               when go $ messageMore "Can it be done better, though?"+             end++-- | Switches current hero to the next hero on the level, if any, wrapping.+cycleHero :: Action ()+cycleHero =+  do+    pl <- gets splayer+    hs <- gets (lheroes . slevel)+    let i        = case pl of AHero n -> n ; _ -> -1+        (lt, gt) = IM.split i hs+    case IM.keys gt ++ IM.keys lt of+      [] -> abortWith "Cannot select another hero on this level."+      ni : _ -> assertTrue $ selectPlayer (AHero ni)++-- | Search for secret doors+search :: Action ()+search =+  do+    lmap   <- gets (lmap . slevel)+    ploc   <- gets (mloc . getPlayerBody)+    pitems <- gets (mitems . getPlayerBody)+    let delta = case strongestItem pitems "ring" of+                  Just i  -> 1 + ipower 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)))+    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)+  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++-- | Start the monster targeting mode. Cycle between monster targets.+-- TODO: also target a monster by moving the cursor, if in target monster mode.+-- TODO: sort monsters by distance to the player.+targetMonster :: Action ()+targetMonster = do+  pl        <- gets splayer+  ms        <- gets (lmonsters . slevel)+  per       <- currentPerception+  target    <- gets (mtarget . getPlayerBody)+  targeting <- gets (ctargeting . scursor)+  let i = case target of+            TEnemy (AMonster n) _ | targeting -> n  -- try next monster+            TEnemy (AMonster n) _ -> n - 1  -- try to retarget old monster+            _ -> -1  -- try to target first monster (e.g., number 0)+      dms = case pl of+              AMonster n -> IM.delete n ms  -- don't target yourself+              AHero _ -> ms+      (lt, gt) = IM.split i dms+      gtlt     = IM.assocs gt ++ IM.assocs lt+      lf = L.filter (\ (_, m) -> actorSeesLoc pl (mloc 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++-- | Set, activate and display cursor information.+setCursor :: Target -> Action ()+setCursor tgt = do+  state <- get+  per   <- currentPerception+  ploc  <- gets (mloc . getPlayerBody)+  ln    <- gets (lname . slevel)+  let upd cursor =+        let cloc = case targetToLoc (ptvisible per) state of+                     Nothing -> ploc+                     Just l  -> l+        in  cursor { ctargeting = True, clocation = cloc, clocLn = ln }+  modify (updateCursor upd)+  doLook++-- | Perform look around in the current location of the cursor.+-- TODO: depending on tgt, show extra info about tile or monster or both+doLook :: Action ()+doLook =+  do+    loc    <- gets (clocation . scursor)+    state  <- get+    lmap   <- gets (lmap . slevel)+    per    <- currentPerception+    target <- gets (mtarget . 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. "+                 Nothing -> ""+          else ""+        mode = case target of+                 TEnemy _ _ -> "[targeting monster] "+                 TLoc _   -> "[targeting location] "+                 TCursor  -> "[targeting current] "+        -- general info about current loc+        lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg+        -- check if there's something lying around at current loc+        t = lmap `at` loc+    if length (titems t) <= 2+      then do+             messageAdd lookMsg+      else do+             displayItems lookMsg False (titems t)+             session getConfirm+             messageAdd ""++-- | This function performs a move (or attack) by any actor,+-- i.e., it can handle monsters, heroes and both.+moveOrAttack :: Bool ->        -- allow attacks?+                Bool ->        -- auto-open doors on move+                Actor ->       -- who's moving?+                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+      -- We start by looking at the target position.+      state <- get+      pl    <- gets splayer+      lmap  <- gets (lmap . slevel)+      sm    <- gets (getActor actor)+      let sloc = mloc 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 ""++-- | 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+-- 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 _) =+  -- Select adjacent hero by bumping into him. Takes no time.+  assertTrue $ selectPlayer target+actorAttackActor source target = do+  state <- get+  sm    <- gets (getActor source)+  tm    <- gets (getActor target)+  per   <- currentPerception+  let groupName = "sword"+      verb = attackToVerb groupName+      sloc = mloc sm+      swordKindIndex = fromJust $ L.elemIndex ItemKind.sword ItemKind.loot+      -- The hand-to-hand "weapon", equivalent to +0 sword.+      h2h = Item swordKindIndex 0 Nothing 1+      str = strongestItem (mitems sm) groupName+      stack  = fromMaybe h2h str+      single = stack { icount = 1 }+      -- The message describes the source part of the action.+      -- TODO: right now it also describes the victim and weapon;+      -- perhaps, when a weapon is equipped, just say "you hit" or "you miss"+      -- and then "nose dies" or "nose yells in pain".+      msg = subjectVerbMObject sm verb tm $+              if isJust str then " with " ++ objectItem state single else ""+  when (sloc `S.member` ptvisible per) $ messageAdd msg+  -- Messages inside itemEffectAction describe the target part.+  itemEffectAction source target single+  advanceTime source++attackToVerb :: String -> String+attackToVerb "sword" = "hit"  -- TODO: "slash"? "pierce"? "swing"?+attackToVerb "mace" = "bludgeon"+attackToVerb _ = "hit"++-- | Resolves the result of an actor running into another.+-- This involves switching positions of the two movables.+actorRunActor :: Actor -> Actor -> 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 }+  if source == pl+    then stopRunning  -- do not switch positions repeatedly+    else if isAMonster source+         then focusIfAHero target+         else return ()+  advanceTime source++-- | Generate a monster, possibly.+generateMonster :: Action ()+generateMonster =+  do  -- TODO: simplify+    state  <- get+    nstate <- liftIO $ rndToIO $ rollMonster state+    modify (const nstate)++-- | Possibly regenerate HP for all movables on the current level.+regenerateLevelHP :: Action ()+regenerateLevelHP =+  do+    time  <- gets stime+    let upd m =+          let regen = nregen (mkind m) `div`+                      case strongestItem (mitems m) "amulet" of+                        Just i  -> ipower i+                        Nothing -> 1+          in if time `mod` regen /= 0+             then m+             else m { mhp = min (nhpMax (mkind m)) (mhp m + 1) }+    -- We really want hero selection to be a purely UI distinction,+    -- so all heroes need to regenerate, not just the player.+    -- Only the heroes on the current level regenerate (others are frozen+    -- in time together with their level). This prevents cheating+    -- via sending one hero to a safe level and waiting there.+    modify (updateLevel (updateHeroes   (IM.map upd)))+    modify (updateLevel (updateMonsters (IM.map upd)))
+ src/Color.hs view
@@ -0,0 +1,119 @@+module Color where++import Control.Monad+import qualified Data.Binary as Binary++data Color =+    Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | BrBlack+  | BrRed+  | BrGreen+  | BrYellow+  | BrBlue+  | BrMagenta+  | BrCyan+  | BrWhite+  deriving (Show, Eq, Ord, Enum, Bounded)++instance Binary.Binary Color where+  put = Binary.putWord8 . fromIntegral . fromEnum+  get = liftM (toEnum . fromIntegral) Binary.getWord8++defBG, defFG :: Color+defBG = Black+defFG = White++type Attr = (Color.Color, Color.Color)+defaultAttr :: Attr+defaultAttr = (Color.defFG, Color.defBG)++isBright :: Color -> Bool+isBright c = fromEnum c > 7  -- for terminals that display bright via bold++-- | Due to limitation of curses, only these are legal backgrounds.+legalBG :: [Color]+legalBG = [Black, White, Blue, Magenta]++-- Heavily modified Linux console colors.+colorToRGB :: Color -> String+colorToRGB Black     = "#000000"+colorToRGB Red       = "#D50000"+colorToRGB Green     = "#00AA00"+colorToRGB Yellow    = "#AA5500"  -- brown+colorToRGB Blue      = "#203AF0"+colorToRGB Magenta   = "#AA00AA"+colorToRGB Cyan      = "#00AAAA"+colorToRGB White     = "#BEBABA"+colorToRGB BrBlack   = "#6A6565"+colorToRGB BrRed     = "#FF5555"+colorToRGB BrGreen   = "#75FF45"+colorToRGB BrYellow  = "#FFE855"+colorToRGB BrBlue    = "#4090FF"+colorToRGB BrMagenta = "#FF77FF"+colorToRGB BrCyan    = "#60FFF0"+colorToRGB BrWhite   = "#FFFFFF"++-- For reference, the original Linux console colors.+-- Good old retro feel and more useful than xterm (e.g. brown).+colorToRGB' :: Color -> String+colorToRGB' Black     = "#000000"+colorToRGB' Red       = "#AA0000"+colorToRGB' Green     = "#00AA00"+colorToRGB' Yellow    = "#AA5500"  -- brown+colorToRGB' Blue      = "#0000AA"+colorToRGB' Magenta   = "#AA00AA"+colorToRGB' Cyan      = "#00AAAA"+colorToRGB' White     = "#AAAAAA"+colorToRGB' BrBlack   = "#555555"+colorToRGB' BrRed     = "#FF5555"+colorToRGB' BrGreen   = "#55FF55"+colorToRGB' BrYellow  = "#FFFF55"+colorToRGB' BrBlue    = "#5555FF"+colorToRGB' BrMagenta = "#FF55FF"+colorToRGB' BrCyan    = "#55FFFF"+colorToRGB' BrWhite   = "#FFFFFF"++-- Human-readable names, for item descriptions. The simple set.+colorToName :: Color -> String+colorToName Black     = "black"+colorToName Red       = "red"+colorToName Green     = "green"+colorToName Yellow    = "brown"+colorToName Blue      = "blue"+colorToName Magenta   = "purple"+colorToName Cyan      = "cyan"+colorToName White     = "ivory"+colorToName BrBlack   = "gray"+colorToName BrRed     = "coral"+colorToName BrGreen   = "lime"+colorToName BrYellow  = "yellow"+colorToName BrBlue    = "azure"+colorToName BrMagenta = "pink"+colorToName BrCyan    = "aquamarine"+colorToName BrWhite   = "white"++-- The fancy set.+colorToName' :: Color -> String+colorToName' Black     = "smoky black"+colorToName' Red       = "apple red"+colorToName' Green     = "forest green"+colorToName' Yellow    = "mahogany"+colorToName' Blue      = "royal blue"+colorToName' Magenta   = "indigo"+colorToName' Cyan      = "teal"+colorToName' White     = "silver gray"+colorToName' BrBlack   = "charcoal"+colorToName' BrRed     = "salmon"+colorToName' BrGreen   = "emerald"+colorToName' BrYellow  = "amber"+colorToName' BrBlue    = "sky blue"+colorToName' BrMagenta = "magenta"+colorToName' BrCyan    = "turquoise"+colorToName' BrWhite   = "ghost white"
+ src/Command.hs view
@@ -0,0 +1,41 @@+module Command where++import Action+import Actions+import ItemAction+import Geometry+import Level+import Version++data Described a = Described { chelp :: String, caction :: a }+                 | Undescribed { caction :: a }++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))+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)+floorCommand     = Described "target location"   targetFloor+monsterCommand   = Described "target monster"    (checkCursor targetMonster)+quaffCommand     = Described "quaff a potion"    (checkCursor quaffPotion)+readCommand      = Described "read a scroll"     (checkCursor readScroll)+throwCommand     = Described "throw a weapon"    (checkCursor throwItem)+aimCommand       = Described "aim a wand"        (checkCursor aimItem)+waitCommand      = Described "wait"              playerAdvanceTime+saveCommand      = Described "save and exit the game" saveGame+quitCommand      = Described "quit without saving" quitGame+cancelCommand    = Described "cancel action"     cancelCurrent+acceptCommand h  = Described "accept choice"     (acceptCurrent h)+historyCommand   = Described "display previous messages" displayHistory+dumpCommand      = Described "dump current configuration" dumpConfig+heroCommand      = Described "cycle among heroes on level" cycleHero+versionCommand   = Described "display game version" (abortWith version)++moveDirCommand   = Described "move in direction" move+runDirCommand    = Described "run in direction"  run
+ src/Config.hs view
@@ -0,0 +1,113 @@+module Config+ (CP, defaultCP, config, getOption, getItems, get, getFile, dump) where++import System.Directory+import System.FilePath+import System.IO+import Control.Monad.Error++import qualified Data.ConfigFile as CF+import Data.Either.Utils+import Data.Maybe+import qualified Data.Binary as Binary++import qualified ConfigDefault++newtype CP = CP CF.ConfigParser++instance Binary.Binary CP where+  put (CP config) = Binary.put $ CF.to_string config+  get = do+    string <- Binary.get+    -- use config in case savegame is from older version and lacks some options+    let c = CF.readstring defCF string+    return $ toCP $ forceEither c++instance Show CP where+  show (CP config) = show $ CF.to_string config++-- | Switches all names to case sensitive (unlike by default in ConfigFile).+toSensitive :: CF.ConfigParser -> CF.ConfigParser+toSensitive cp = cp {CF.optionxform = id}++-- | The default configuration taken from the default configuration file+-- included via CPP in ConfigDefault.hs.+defCF :: CF.ConfigParser+defCF  =+  let c = CF.readstring CF.emptyCP ConfigDefault.configDefault+  in  toSensitive $ forceEither c++toCP :: CF.ConfigParser -> CP+toCP cp = CP $ toSensitive cp++defaultCP :: CP+defaultCP = toCP defCF++-- | Path to the user configuration file.+file :: IO FilePath+file =+  do+    appData <- getAppUserDataDirectory "Allure"+    return $ combine appData "config"++-- | The configuration read from the user configuration file.+-- The default configuration file provides underlying defaults+-- in case some options, or the whole file, are missing.+config :: IO CP+config =+  -- evaluate, to catch config errors ASAP+  defCF `seq`+  do+    f <- file+    b <- doesFileExist f+    if not b+      then return $ toCP $ defCF+      else do+        c <- CF.readfile defCF f+        return $ toCP $ forceEither c++-- | A simplified access to an option in a given section,+-- with simple error reporting (no error is caught and hidden).+-- If there is no config file or no such option, gives Nothing.+getOption :: 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+  else Nothing++-- | A simplified access to an option in a given section.+get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a+get (CP config) s o =+  if CF.has_option config s o+  then forceEither $ CF.get config s o+  else error $ "unknown config option: " ++ s ++ "." ++ o++-- | An association list corresponding to a section.+getItems :: CP -> CF.SectionSpec -> [(String, String)]+getItems (CP config) s =+  if CF.has_section config s+  then forceEither $ CF.items config s+  else error $ "unknown config section: " ++ s++-- | Looks up a file path in the config file and makes it absolute.+-- If the game's configuration directory exists,+-- the path is appended to it; otherwise, it's appended+-- to the current directory.+getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath+getFile config s o =+  do+    current <- getCurrentDirectory+    appData <- getAppUserDataDirectory "Allure"+    let path    = get config s o+        appPath = combine appData path+        curPath = combine current path+    b <- doesDirectoryExist appData+    return $ if b then appPath else curPath++dump :: FilePath -> CP -> IO ()+dump fn (CP config) =+  do+    current <- getCurrentDirectory+    let path = combine current fn+        dump = CF.to_string config+    writeFile path dump
+ src/ConfigDefault.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP, QuasiQuotes #-}++module ConfigDefault (configDefault) where++import Multiline++-- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?)+-- as soon as the config file grows very big.++-- | The string containing the default configuration+-- included from file src/config.default.+-- Warning: cabal does not detect that the default config is changed,+-- so touching this file is needed to reinclude config and recompile.+configDefault :: String+configDefault = [$multiline|++#include "config.default"++|]
+ src/Display.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}++module Display where++-- wrapper for selected Display frontend++#ifdef CURSES+import qualified Display.Curses as D+#elif GTK+import qualified Display.Gtk as D+#else+import qualified Display.Vty as D+#endif++-- Display routines that are independent of the selected display frontend.++import qualified Data.Char as Char+import Data.Set as S+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2+import Data.Maybe++import Message+import qualified Color+import State+import Geometry+import Level+import LevelState+import Dungeon+import Perception+import Movable+import MovableState+import MovableKind+import Item+import qualified Keys as K+import WorldLoc++-- Re-exported from the display frontend, with an extra slot for function+-- for translating keys to a canonical form.+type InternalSession = D.Session+type Session = (InternalSession, M.Map K.Key K.Key)+display area = D.display area . fst+startup = D.startup+shutdown = D.shutdown . fst+displayId = D.displayId++-- | Next event translated to a canonical form.+nextCommand :: MonadIO m => Session -> m K.Key+nextCommand session =+  do+    e <- liftIO $ D.nextEvent (fst session)+    return $+      case M.lookup e (snd session) of+        Just key -> key+        Nothing  -> K.canonMoveKey e++-- | Displays a message on a blank screen. Waits for confirmation.+displayBlankConfirm :: Session -> String -> IO Bool+displayBlankConfirm session txt =+  let x = txt ++ more+      doBlank = const (Color.defaultAttr, ' ')+  in do+       display ((0, 0), normalLevelSize) session doBlank x ""+       getConfirm session++-- | Waits for a space or return or '?' or '*'. The last two act this way,+-- to let keys that request information toggle display the information off.+getConfirm :: MonadIO m => Session -> m Bool+getConfirm session =+  getOptionalConfirm return (const $ getConfirm session) session++getOptionalConfirm :: MonadIO m =>+                      (Bool -> m a) -> (K.Key -> m a) -> Session -> m a+getOptionalConfirm h k session =+  do+    e <- liftIO $ nextCommand session+    case e of+      K.Char ' ' -> h True+      K.Char '?' -> h True+      K.Char '*' -> h True+      K.Return   -> h True+      K.Esc      -> h False+      _          -> k e++-- | A yes-no confirmation.+getYesNo :: MonadIO m => Session -> m Bool+getYesNo session =+  do+    e <- liftIO $ nextCommand session+    case e of+      K.Char 'y' -> return True+      K.Char 'n' -> return False+      K.Esc      -> return False+      _          -> getYesNo session++splitOverlay :: Int -> String -> [[String]]+splitOverlay s xs = splitOverlay' (lines xs)+  where+    splitOverlay' ls+      | length ls <= s = [ls]  -- everything fits on one screen+      | otherwise      = let (pre,post) = splitAt (s - 1) ls+                         in  (pre ++ [more]) : splitOverlay' post++-- | Returns a function that looks up the characters in the+-- string by location. Takes the height of the display plus+-- the string. Returns also the number of screens required+-- to display all of the string.+stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)+stringByLocation sy xs =+  let+    ls   = splitOverlay sy xs+    m    = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))+    k    = length ls+  in+    (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)++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+      reachable = ptreachable per+      visible   = ptvisible per+      overlay   = fromMaybe "" moverlay+      (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed+      sSml   = ssensory state == Smell+      sVis   = case ssensory state of Vision _ -> True; _ -> False+      sOmn   = sdisplay state == Omniscient+      lAt    = if sOmn then at else rememberAt+      sVisBG = if sVis+               then \ vis rea -> if vis+                                 then Color.Blue+                                 else if rea+                                      then Color.Magenta+                                      else Color.defBG+                else \ vis rea -> Color.defBG+      wealth  = L.sum $ L.map itemPrice pitems+      damage  = case strongestItem pitems "sword" of+                  Just sw -> 3 + ipower sw+                  Nothing -> 3+      hs      = levelHeroList state+      ms      = levelMonsterList state+      dis n loc =+        let tile = lmap `lAt` loc+            sml  = ((smap ! loc) - time) `div` 100+            viewMovable loc (Movable { mkind = mk })+              | loc == ploc && ln == creturnLn cursor =+                  (nsymbol mk, Color.defBG)  -- highlight player+              | otherwise = (nsymbol mk, ncolor mk)+            viewSmell :: Int -> Char+            viewSmell n+              | n > 9     = '*'+              | n < 0     = '-'+              | otherwise = Char.intToDigit n+            rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1)+            (char, fg) =+              case L.find (\ m -> loc == 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+            reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)+            optVisually (fg, bg) =+              if fg == Color.defBG+              then reverseVideo+              else if bg == Color.defFG && fg == Color.defFG+                   then reverseVideo+                   else (fg, bg)+            a = if blackAndWhite+                then Color.defaultAttr+                else optVisually (fg, bg)+        in case over (loc `shift` ((sy+1) * n, 0)) of+             Just c -> (Color.defaultAttr, c)+             _      -> (a, char)+      status =+        take 30 (levelName ln ++ repeat ' ') +++        take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') +++        take 10 ("$: " ++ show wealth ++ repeat ' ') +++        take 10 ("Dmg: " ++ show damage ++ repeat ' ') +++        take 20 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ')+      disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg status+      msgs = splitMsg sx msg+      perf k []     = perfo k ""+      perf k [xs]   = perfo k xs+      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->+                      if b then perf k xs else return False+      perfo k xs+        | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->+                      if b then perfo (k+1) xs else return False+        | otherwise = disp k xs >> return True+  in  perf 0 msgs
+ src/Display/Curses.hs view
@@ -0,0 +1,126 @@+module Display.Curses+  (displayId, startup, shutdown, display, nextEvent, Session) where++import UI.HSCurses.Curses as C+import qualified UI.HSCurses.CursesHelper as C+import Data.List as L+import Data.Map as M+import Data.Char+import qualified Data.ByteString.Char8 as BS+import Control.Monad++import Geometry+import qualified Keys as K (Key(..))+import qualified Color++displayId = "curses"++data Session =+  Session+    { win :: Window,+      styles :: Map (Color.Color, Color.Color) C.CursesStyle }++startup :: (Session -> IO ()) -> IO ()+startup k =+  do+    C.start+    cursSet CursorInvisible+    let s = [ ((f, b), C.Style (toFColor f) (toBColor b))+            | f <- [minBound..maxBound],+              -- No more color combinations possible: 16*4, 64 is max.+              b <- Color.legalBG ]+    nr <- colorPairs+    when (nr < L.length s) $+      C.end >>+      error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")+    let (ks, vs) = unzip s+    ws <- C.convertStyles vs+    let styleMap = M.fromList (zip ks ws)+    k (Session C.stdScr styleMap)++shutdown :: Session -> IO ()+shutdown w = C.end++display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO ()+display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =+  do+    -- let defaultStyle = C.defaultCursesStyle+    -- Terminals with white background require this:+    let defaultStyle = s ! Color.defaultAttr+    C.erase+    C.setStyle defaultStyle+    mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg)  -- TODO: BS as in vty+    mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status)+    sequence_ [ C.setStyle (findWithDefault defaultStyle a s)+                >> mvWAddStr w (y+1) x [c]+              | x <- [x0..x1], y <- [y0..y1], let (a, c) = f (y, x) ]+    refresh++toWidth :: Int -> String -> String+toWidth n x = take n (x ++ repeat ' ')++keyTranslate :: C.Key -> K.Key+keyTranslate e =+  case e of+    C.KeyChar '\ESC' -> K.Esc+    C.KeyExit        -> K.Esc+    C.KeyChar '\n'   -> K.Return+    C.KeyChar '\r'   -> K.Return+    C.KeyEnter       -> K.Return+    C.KeyChar '\t'   -> K.Tab+    C.KeyUp          -> K.Up+    C.KeyDown        -> K.Down+    C.KeyLeft        -> K.Left+    C.KeyRight       -> K.Right+    C.KeyHome        -> K.Home+    C.KeyPPage       -> K.PgUp+    C.KeyEnd         -> K.End+    C.KeyNPage       -> K.PgDn+    C.KeyBeg         -> K.Begin+    C.KeyB2          -> K.Begin+    C.KeyClear       -> K.Begin+    -- No KP_ keys in hscurses and they do not seem actively maintained.+    -- For now, movement keys are more important than hero selection:+    C.KeyChar c+      | c `elem` ['1'..'9'] -> K.KP c+      | otherwise           -> K.Char c+    _                       -> K.Unknown (show e)++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- C.getKey refresh+    return (keyTranslate e)+--    case keyTranslate e of+--      Unknown _ -> nextEvent session+--      k -> return k++toFColor :: Color.Color -> C.ForegroundColor+toFColor Color.Black     = C.BlackF+toFColor Color.Red       = C.DarkRedF+toFColor Color.Green     = C.DarkGreenF+toFColor Color.Yellow    = C.BrownF+toFColor Color.Blue      = C.DarkBlueF+toFColor Color.Magenta   = C.PurpleF+toFColor Color.Cyan      = C.DarkCyanF+toFColor Color.White     = C.WhiteF+toFColor Color.BrBlack   = C.GreyF+toFColor Color.BrRed     = C.RedF+toFColor Color.BrGreen   = C.GreenF+toFColor Color.BrYellow  = C.YellowF+toFColor Color.BrBlue    = C.BlueF+toFColor Color.BrMagenta = C.MagentaF+toFColor Color.BrCyan    = C.CyanF+toFColor Color.BrWhite   = C.BrightWhiteF++toBColor :: Color.Color -> C.BackgroundColor+toBColor Color.Black     = C.BlackB+toBColor Color.Red       = C.DarkRedB+toBColor Color.Green     = C.DarkGreenB+toBColor Color.Yellow    = C.BrownB+toBColor Color.Blue      = C.DarkBlueB+toBColor Color.Magenta   = C.PurpleB+toBColor Color.Cyan      = C.DarkCyanB+toBColor Color.White     = C.WhiteB+toBColor _               = C.BlackB  -- a limitation of curses
+ src/Display/Gtk.hs view
@@ -0,0 +1,172 @@+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 Data.IORef+import Data.Map as M+import qualified Data.ByteString.Char8 as BS++import Geometry+import qualified Keys as K (Key(..), keyTranslate)+import qualified Color++displayId = "gtk"++data Session =+  Session {+    schan :: Chan String,+    stags :: Map Color.Attr TextTag,+    sview :: TextView }++startup :: (Session -> IO ()) -> IO ()+startup k =+  do+    -- initGUI+    unsafeInitGUIForThreadedRTS+    w <- windowNew++    ttt <- textTagTableNew+    -- text attributes+    tts <- fmap M.fromList $+           mapM (\ ak -> do+                           tt <- textTagNew Nothing+                           textTagTableAdd ttt tt+                           doAttr tt ak+                           return (ak, tt))+                [ (f, b) | f <- [minBound..maxBound], b <- Color.legalBG ]++    -- text buffer+    tb <- textBufferNew (Just ttt)+    textBufferSetText tb (unlines (replicate 25 (replicate 80 ' ')))++    -- create text view+    tv <- textViewNewWithBuffer tb+    containerAdd w tv+    textViewSetEditable tv False+    textViewSetCursorVisible tv False++    -- font+    f <- fontDescriptionNew+    fontDescriptionSetFamily f "Monospace"+    fontDescriptionSetSize f 12+    widgetModifyFont tv (Just f)+    currentfont <- newIORef f+    onButtonPress tv (\ e -> case e of+                               Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } ->+                                 do+                                   fsd <- fontSelectionDialogNew "Choose font"+                                   cf <- readIORef currentfont+                                   fd <- fontDescriptionToString cf+                                   fontSelectionDialogSetFontName fsd fd+                                   fontSelectionDialogSetPreviewText fsd "+##@##-...|"+                                   response <- dialogRun fsd+                                   when (response == ResponseOk) $+                                     do+                                       fn <- fontSelectionDialogGetFontName fsd+                                       case fn of+                                         Just fn' -> do+                                                       fd <- fontDescriptionFromString fn'+                                                       writeIORef currentfont fd+                                                       widgetModifyFont tv (Just fd)+                                         Nothing  -> return ()+                                   widgetDestroy fsd+                                   return True+                               _ -> return False)++    let black = Color minBound minBound minBound  -- Color.defBG == Color.Black+        white = Color 0xAAAA 0xAAAA 0xAAAA        -- 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)++    onDestroy w mainQuit -- set quit handler+    widgetShowAll w+    yield+    mainGUI++shutdown _ = mainQuit++display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String+           -> IO ()+display ((y0,x0), (y1,x1)) session f msg status =+  postGUIAsync $+  do+    tb <- textViewGetBuffer (sview session)+    let fLine y = let (as, cs) = unzip [ f (y, x) | x <- [x0..x1] ]+                  in  ((y, as), BS.pack cs)+        memo  = L.map fLine [y0..y1]+        attrs = L.map fst memo+        chars = L.map snd memo+        bs    = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status]+    textBufferSetByteString tb (BS.concat bs)+    mapM_ (setTo tb (stags session) x0) attrs++setTo :: TextBuffer -> Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) -> IO ()+setTo tb tts lx (ly, []) = return ()+setTo tb tts lx (ly, a:as) = do+  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx+  ie <- textIterCopy ib+  let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO ()+      setIter previous repetitions [] = do+        textIterForwardChars ie repetitions+        when (previous /= Color.defaultAttr) $+          textBufferApplyTag tb (tts ! previous) ib ie+      setIter previous repetitions (a:as)+        | a == previous =+            setIter a (repetitions + 1) as+        | otherwise = do+            textIterForwardChars ie repetitions+            when (previous /= Color.defaultAttr) $+              textBufferApplyTag tb (tts ! previous) ib ie+            textIterForwardChars ib repetitions+            setIter a 1 as+  setIter a 1 as++-- | reads until a non-dead key encountered+readUndeadChan :: Chan String -> IO String+readUndeadChan ch =+  do+    x <- readChan ch+    if dead x then readUndeadChan ch else return x+      where+        dead x =+          case x of+            "Shift_R"          -> True+            "Shift_L"          -> True+            "Control_L"        -> True+            "Control_R"        -> True+            "Super_L"          -> True+            "Super_R"          -> True+            "Menu"             -> True+            "Alt_L"            -> True+            "Alt_R"            -> True+            "ISO_Level2_Shift" -> True+            "ISO_Level3_Shift" -> True+            "ISO_Level2_Latch" -> True+            "ISO_Level3_Latch" -> True+            "Num_Lock"         -> True+            "Caps_Lock"        -> True+            _                  -> False++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- readUndeadChan (schan session)+    return (K.keyTranslate e)++doAttr :: TextTag -> Color.Attr -> IO ()+doAttr tt (fg, bg)+  | (fg, bg) == Color.defaultAttr = return ()+  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]+  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]+  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,+                                textTagBackground := Color.colorToRGB bg]
+ src/Display/Vty.hs view
@@ -0,0 +1,96 @@+module Display.Vty+  (displayId, startup, shutdown, display, nextEvent, Session) where++import Graphics.Vty as V+import Data.List as L+import Data.Char+import qualified Data.ByteString.Char8 as BS++import Geometry+import qualified Keys as K (Key(..))+import qualified Color++displayId = "vty"++type Session = V.Vty++startup :: (Session -> IO ()) -> IO ()+startup k = V.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+       (utf8_bytestring (setAttr Color.defaultAttr)+        (BS.pack (toWidth (x1 - x0 + 1) msg)) <->+        img <->+        utf8_bytestring (setAttr Color.defaultAttr)+        (BS.pack (toWidth (x1 - x0 + 1) status))))++toWidth :: Int -> String -> String+toWidth n x = take n (x ++ repeat ' ')++keyTranslate :: V.Event -> 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+    -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8+    -- For now, movement keys are more important than hero selection:+    V.EvKey (KASCII c) []+      | c `elem` ['1'..'9']  -> K.KP c+      | otherwise            -> K.Char c+    _                        -> K.Unknown (show e)++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- V.next_event session+    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.+hack c a = if Color.isBright c then with_style a bold else a++setAttr (fg, bg) =+-- This optimization breaks display for white background terminals:+--  if (fg, bg) == Color.defaultAttr+--  then def_attr+--  else+    hack fg $ hack bg $+      def_attr { attr_fore_color = SetTo (aToc fg),+                 attr_back_color = SetTo (aToc bg) }++aToc :: Color.Color -> Color+aToc Color.Black     = black+aToc Color.Red       = red+aToc Color.Green     = green+aToc Color.Yellow    = yellow+aToc Color.Blue      = blue+aToc Color.Magenta   = magenta+aToc Color.Cyan      = cyan+aToc Color.White     = white+aToc Color.BrBlack   = bright_black+aToc Color.BrRed     = bright_red+aToc Color.BrGreen   = bright_green+aToc Color.BrYellow  = bright_yellow+aToc Color.BrBlue    = bright_blue+aToc Color.BrMagenta = bright_magenta+aToc Color.BrCyan    = bright_cyan+aToc Color.BrWhite   = bright_white
+ src/Dungeon.hs view
@@ -0,0 +1,379 @@+module Dungeon where++import Prelude hiding (floor)+import Control.Monad+import qualified System.Random as R++import Data.Binary+import Data.Map as M+import Data.List as L+import Data.Ratio+import Data.Maybe++import 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)+  deriving Show++instance Binary Dungeon where+  put (Dungeon dng) = put (M.elems dng)+  get = liftM dungeon get++-- | Create a dungeon from a list of levels.+dungeon :: [Level] -> Dungeon+dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))++-- | Extract a level from a dungeon.+getDungeonLevel :: 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)++rollPillars :: LevelConfig -> Level -> Rnd [Loc]+rollPillars cfg lvl =+  do+    nri <- 100 *~ nrItems cfg+    replicateM nri $+      do+        l <- findLoc lvl (const floor)+        return l++emptyLMap :: (Y, X) -> LMap+emptyLMap (my, mx) =+  M.fromList [ ((y, x), newTile Terrain.rock) | x <- [0..mx], y <- [0..my] ]++-- | 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
+ src/DungeonState.hs view
@@ -0,0 +1,41 @@+module DungeonState where++import Data.Map as M++import Geometry+import Level+import Dungeon+import Random+import qualified Config+import WorldLoc++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++matchGenerator n Nothing = rogueRoom  -- the default+matchGenerator n (Just "bigRoom")   = bigRoom+matchGenerator n (Just "noiseRoom") = noiseRoom+matchGenerator n (Just "rogueRoom") = rogueRoom+matchGenerator n (Just s) =+  error $ "matchGenerator: unknown: " ++ show n ++ ", " ++ s++findGenerator config n =+  let ln = "LambdaCave_" ++ show n+      genName = Config.getOption config "dungeon" ln+  in  matchGenerator n genName (defaultLevelConfig n) (LambdaCave n)++-- | Generate the dungeon for a new game.+generate :: Config.CP -> Rnd (Loc, Level, Dungeon)+generate config = do+  let depth = Config.get config "dungeon" "depth"+  levels <- mapM (findGenerator config) [1..depth]+  let lvls = connect (Just Nothing) levels+      ploc = ((\ (_,x,_) -> x) (head levels))+  return $ (ploc, head lvls, dungeon (tail lvls))
+ src/Effect.hs view
@@ -0,0 +1,45 @@+module Effect where++import Random+import WorldLoc++data Effect =+    NoEffect+  | Heal            -- healing strength in ipower+  | Wound RollDice  -- base damage, to-dam bonus in ipower+  | Dominate+  | SummonFriend+  | SummonEnemy+  | ApplyPerfume+  | Regneration+  | Searching+  | Teleport WorldLoc+  deriving (Show, Eq, Ord)++effectToName :: Effect -> String+effectToName NoEffect = ""+effectToName Heal = "of healing"+effectToName (Wound (a, b)) = if a == 0 && b == 0+                              then "of wounding"+                              else "(" ++ show a ++ "d" ++ show b ++ ")"+effectToName Dominate = "of domination"+effectToName SummonFriend = "of aid calling"+effectToName SummonEnemy = "of summoning"+effectToName ApplyPerfume = "of rose water"+effectToName Regneration = "of regeneration"+effectToName Searching = "of searching"+effectToName (Teleport _) = "of teleport"++-- | How much AI benefits from applying the effect. Multipllied by item power.+-- Negative means harm to the enemy when thrown. Zero won't ever be used.+effectToBenefit :: Effect -> Int+effectToBenefit NoEffect = 0+effectToBenefit Heal = 10           -- TODO: depends on (maxhp - hp)+effectToBenefit (Wound _) = -10     -- TODO: dice ignored for now+effectToBenefit Dominate = 0        -- AI can't use this+effectToBenefit SummonFriend = 100+effectToBenefit SummonEnemy = 0+effectToBenefit ApplyPerfume = 0+effectToBenefit Regneration = 0     -- much more benefit from carrying around+effectToBenefit Searching = 0       -- AI does not need to search+effectToBenefit (Teleport _) = 0    -- AI does not know when to teleport
+ src/EffectAction.hs view
@@ -0,0 +1,328 @@+module EffectAction where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Function+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Set as S+import System.Time+import Control.Exception (assert)++import Action+import Display hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified ItemKind+import qualified Keys as K+import Level+import LevelState+import Message+import Movable+import MovableState+import MovableKind+import MovableAdd+import Perception+import Random+import State+import qualified Config+import qualified Save+import qualified Effect+import WorldLoc++-- 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.+-- 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 ->+                  Action (Bool, String)+effectToAction Effect.NoEffect source target power = nullEffect+effectToAction Effect.Heal _source target power = do+  tm <- gets (getActor target)+  if mhp tm >= nhpMax (mkind 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+    focusIfAHero target+    tm <- gets (getActor target)+    let newHP  = mhp 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.+    when killed $ do+      -- Place the actor's possessions on the map.+      modify (updateLevel (dropItemsAt (mitems tm) (mloc tm)))+      -- Clean bodies up.+      pl <- gets splayer+      if target == pl+        then checkPartyDeath  -- kills the player and checks game over+        else modify (deleteActor target)  -- kills the enemy+    return (True, msg)+effectToAction Effect.Dominate source target power =+  if isAMonster target  -- Monsters have weaker will than heroes.+  then do+         assertTrue $ selectPlayer target+         -- Prevent AI from getting a few free moves until new player ready.+         updatePlayerBody (\ m -> m { mtime = 0})+         stopRunning+         display+         return (True, "")+  else nullEffect+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)+  return (True, "")+effectToAction Effect.SummonEnemy source target power = do+  tm <- gets (getActor target)+  if not $ isAHero source  -- a trick: monster player will summon a hero+    then summonHeroes (1 + power) (mloc tm)+    else summonMonsters (1 + power) (mloc tm)+  return (True, "")+effectToAction Effect.ApplyPerfume source target _ =+  if source == target+  then return (True, "Tastes like water, but with a strong rose scent.")+  else do+    let upd lvl = lvl { lsmell = M.map (const (-100)) (lsmell lvl) }+    modify (updateLevel upd)+    return (True, "The fragrance quells all scents in the vicinity.")+effectToAction Effect.Regneration source target power =+  effectToAction Effect.Heal source target power+effectToAction Effect.Searching source target power =+  return (True, "It gets lost and you search in vain.")++nullEffect :: Action (Bool, String)+nullEffect = return (False, "Nothing happens.")++-- | The source actor affects the target actor, with a given item.+-- If either actor is a hero, the item may get identified.+itemEffectAction :: 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+  -- The message describes the target part of the action.+  (b, msg) <- effectToAction effect source target (ipower 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+     then messageAdd msg+     else if not b+          then return ()  -- Victim is not seen, nothing interestng happens.+          else messageAdd "You hear some noises."+  -- If something happens, the item gets identified.+  when (b && (isAHero source || isAHero target)) $ discover item+  return b++-- | Given item is now known to the player.+discover :: Item -> Action ()+discover i = do+  state <- get+  let ik = ikind i+      obj = unwords $ tail $ words $ objectItem state i+      msg = "The " ++ obj ++ " turns out to be "+      kind = ItemKind.getIK ik+      alreadyIdentified = L.length (ItemKind.jflavour kind) == 1 ||+                          ik `S.member` sdiscoveries state+  if alreadyIdentified+    then return ()+    else do+           modify (updateDiscoveries (S.insert ik))+           state <- get+           messageAdd $ msg ++ objectItem state i ++ "."++-- | 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+selectPlayer actor =+  do+    pl <- gets splayer+    if (actor == pl)+      then return False -- already selected+      else do+        state <- get+        case findActorAnyLevel actor state of+          Nothing -> abortWith $ "No such member of the party."+          Just (nln, pbody) -> do+            -- Make the new actor the player-controlled actor.+            modify (\ s -> s { splayer = actor })+            -- Record the original level of the new player.+            modify (updateCursor (\ c -> c { creturnLn = nln }))+            -- 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++focusIfAHero :: Actor -> Action ()+focusIfAHero target =+  if isAHero target+  then do+    -- Focus on the hero being wounded.+    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)+  modify (\ state -> iterate (addHero loc) state !! n)+  assertTrue $ selectPlayer (AHero newHeroIndex)+  -- 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)++-- | Remove dead heroes, check if game over.+-- For now we only check the selected hero, but if poison, etc.+-- is implemented, we'd need to check all heroes on the level.+checkPartyDeath :: Action ()+checkPartyDeath =+  do+    ahs    <- gets allHeroesAnyLevel+    pl     <- gets splayer+    pbody  <- gets getPlayerBody+    config <- gets sconfig+    when (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" ++ "."+      history  -- Prevent the messages from being repeated.+      let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"+      if firstDeathEnds+        then gameOver go+        else case L.filter (\ (actor, _) -> actor /= pl) ahs of+               [] -> gameOver go+               (actor, _nln) : _ -> do+                 messageAdd "The survivors carry on."+                 -- Remove the dead player.+                 modify (deleteActor pl)+                 -- At this place the invariant that the player exists fails.+                 -- Focus on the new hero (invariant not needed).+                 assertTrue $ selectPlayer actor+                 -- At this place the invariant is restored again.++-- | End game, showing the ending screens, if requested.+gameOver :: Bool -> Action ()+gameOver showEndingScreens =+  do+    when showEndingScreens $ do+      state <- get+      ln <- gets (lname . slevel)+      let total = calculateTotal state+          status = H.Killed ln+      handleScores True status total+      messageMore "Let's hope another party can save the day!"+    end++-- | Calculate loot's worth for heroes on the current level.+calculateTotal :: State -> Int+calculateTotal s =+  L.sum $ L.map itemPrice $ L.concatMap mitems (levelHeroList s)++-- | Handle current score and display it with the high scores. Scores+-- should not be shown during the game,+-- because ultimately the worth of items might give+-- information about the nature of the items.+-- False if display of the scores was void or interrupted by the user+handleScores :: Bool -> H.Status -> Int -> Action Bool+handleScores write status total =+  if (total == 0)+  then return False+  else do+    config  <- gets sconfig+    time    <- gets stime+    curDate <- liftIO getClockTime+    let points = case status of+                   H.Killed _ -> (total + 1) `div` 2+                   _ -> total+    let score = H.ScoreRecord points (-time) curDate status+    (placeMsg, slideshow) <- liftIO $ H.register config write score+    messageOverlaysConfirm placeMsg slideshow++-- | Perform a level switch to a given level. False, if nothing to do.+lvlSwitch :: 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)+  let ovl = inv ++ more+  messageWipeAndSet msg+  overlay ovl++stopRunning :: Action ()+stopRunning = updatePlayerBody (\ p -> p { mdir = Nothing })++-- | Store current message in the history and reset current message.+history :: Action ()+history =+  do+    (_, sx) <- gets (lsize . slevel)+    msg     <- resetMessage+    config  <- gets sconfig+    let historyMax = Config.get config "ui" "historyMax"+        -- TODO: not ideal, continuations of sentences are atop beginnings.+        split = splitMsg sx (msg ++ " ")+    unless (L.null msg) $+      modify (updateHistory (take historyMax . (L.reverse split ++)))
+ src/FOV.hs view
@@ -0,0 +1,49 @@+module FOV where++import Data.Map as M+import Data.Set as S+import Data.List as L+import Data.Ratio+import Data.Maybe++import FOV.Common+import FOV.Digital+import FOV.Permissive+import FOV.Shadow+import Geometry+import Level++-- import Debug.Trace++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 =+  case fovMode of+    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]+    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+      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
+ src/FOV/Common.hs view
@@ -0,0 +1,58 @@+module FOV.Common where++import Data.List as L++import Geometry++type Interval = (Rational, Rational)+type Distance = Int+type Progress = Int+newtype Bump      = B Loc  deriving (Show)+type Line         = (Bump, Bump)+type ConvexHull   = [Bump]+type Edge         = (Line, ConvexHull)+type EdgeInterval = (Edge, Edge)++-- | The translation, rotation and symmetry functions for octants.+tr0 (oy,ox) (d,p) = (oy + d,ox + p)+tr1 (oy,ox) (d,p) = (oy + d,ox - p)+tr2 (oy,ox) (d,p) = (oy - d,ox + p)+tr3 (oy,ox) (d,p) = (oy - d,ox - p)+tr4 (oy,ox) (d,p) = (oy + p,ox + d)+tr5 (oy,ox) (d,p) = (oy + p,ox - d)+tr6 (oy,ox) (d,p) = (oy - p,ox + d)+tr7 (oy,ox) (d,p) = (oy - p,ox - d)++-- | The translation and rotation functions for quadrants.+qtr0, qtr1, qtr2, qtr3 :: Loc -> Bump -> Loc+qtr0 (oy, ox) (B(y, x)) = (oy - y, ox + x)  -- first quadrant+qtr1 (oy, ox) (B(y, x)) = (oy - x, ox - y)  -- then rotated clockwise 90 degrees+qtr2 (oy, ox) (B(y, x)) = (oy + y, ox - x)+qtr3 (oy, ox) (B(y, x)) = (oy + x, ox + y)++-- | Integer division, rounding up.+divUp n k = - (-n) `div` k++-- | Maximal element of a non-empty list. Prefers elements from the rear,+-- which is essential for PFOV, to avoid ill-defined lines.+maximal :: (a -> a -> Bool) -> [a] -> a+maximal gte = L.foldl1' (\ acc x -> if gte x acc then x else acc)++-- | Check if the line from the second point to the first is more steep+-- than the line from the third point to the first. This is related+-- to the formal notion of gradient (or angle), but hacked wrt signs+-- to work in this particular setup. Returns True for ill-defined lines.+steeper :: Bump ->  Bump -> Bump -> Bool+steeper (B(yf, xf)) (B(y1, x1)) (B(y2, x2)) =+  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)++-- | Adds a bump to the convex hull of bumps represented as a list.+addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull+addHull gte b l =+  case l of+    x:y:zs ->+      if gte x y+      then addHull gte b (y:zs)+      else b : l+    _ -> b : l+
+ src/FOV/Digital.hs view
@@ -0,0 +1,138 @@+module FOV.Digital where++import Data.Set as S++import FOV.Common+import Geometry+import Level+import qualified Tile++-- Digital FOV with a given range.++-- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation,+-- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been+-- implemented before. The algorithm is based on the PFOV algorithm,+-- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View.+-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los+-- for some more context.++-- | The current state of a scan is kept in Maybe (Line, ConvexHull).+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]])+    -- the scanned area is a square, which is a sphere in this metric; good+    where+      ps = let (n, k) = dintersect sl d       -- minimal progress to check+           in  n `div` k+      pe = let (n, k) = dintersect el d       -- maximal progress to check+               -- Corners obstruct view, so the steep line, constructed+               -- from corners, is itself not a part of the view,+               -- so if its intersection with the line of diagonals is only+               -- at a corner, choose the diamond leading to a smaller view.+           in  -1 + n `divUp` k+      outside+        | d >= r = S.empty+        | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe))+        | 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++      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++      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++      dline p1 p2 =+        ddebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      dsteeper f p1 p2 =+        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        steeper f p1 p2++-- | The x coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of diamonds at distance d from (0, 0).+dintersect :: Line -> Distance -> (Int, Int)+dintersect (B(y, x), B(yf, xf)) d =+  ((d - y)*(xf - x) + x*(yf - y), yf - y)+{-+Derivation of the formula:+The intersection point (yt, xt) satisfies the following equalities:+yt = d+(yt - y) (xf - x) = (xt - x) (yf - y)+hence+(yt - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) + x (yf - y) = xt (yf - y)+xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)++General remarks:+A diamond is denoted by its left corner. Hero at (0,0).+Order of processing in the first quadrant rotated by 45 degrees is+ 45678+  123+   @+so the first processed diamond is at (-1, 1). The order is similar+as for the shadow casting algorithm above and reversed wrt PFOV.+The line in the curent state of scan' is called the shallow line,+but it's the one that delimits the view from the left, while the steep+line is on the right, opposite to PFOV. We start scanning from the left.++The Loc coordinates are cartesian, the Bump coordinates are cartesian,+translated so that the hero is at (0, 0) and rotated so that he always+looks at the first roatated quadrant, the (Distance, Progress) cordinates+coincide with the Bump coordinates, unlike in PFOV.+-}++-- | Debug functions for DFOV:++-- | Debug: calculate steeper for DFOV in another way and compare results.+ddebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+ddebugSteeper f p1 p2 x =+  let (n1, k1) = dintersect (p1, f) 0+      (n2, k2) = dintersect (p2, f) 0+  in  if x == (n1 * k2 >= k1 * n2)+      then x+      else error $ "dsteeper: " ++ show (f, p1, p2, x)++-- | Debug: check is a view border line for DFOV is legal.+ddebugLine :: Line -> Line+ddebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "ddebugLine: wrongly defined line " ++ show line+  | y2 - y1 == 0 =+      error $ "ddebugLine: horizontal line " ++ show line+  | crossL0 =+      error $ "ddebugLine: crosses the X axis below 0 " ++ show line+  | crossG1 =+      error $ "ddebugLine: crosses the X axis above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = dintersect line 0+      (q, r)  = if k == 0 then (0, 0) else n `divMod` k+      crossL0 = q < 0  -- q truncated toward negative infinity+      crossG1 = q >= 1 && (q > 1 || r /= 0)
+ src/FOV/Permissive.hs view
@@ -0,0 +1,151 @@+module FOV.Permissive where++import Data.Set as S++import FOV.Common+import Geometry+import Level+import qualified Tile++-- Permissive FOV with a given range.++-- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View,+-- though the general structure is more influenced by recursive shadow casting,+-- as implemented in Shadow.hs. In the result, this algorithm is much faster+-- than the original algorithm on dense maps, since it does not scan+-- areas blocked by shadows.+-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los+-- for some more context.++-- TODO: Scanning squares on horizontal lines in octants, not squares+-- on diagonals in quadrants, may be much faster and a bit simpler.+-- Right now we build new view on each end of each visible wall tile+-- and this is necessary only for straight, thin, diagonal walls.++-- | The current state of a scan is kept in Maybe (Line, ConvexHull).+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  if illegal+  then S.empty+  else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]])+    -- the area is diagonal, which is incorrect, but looks good enough+    where+      (ns, ks) = pintersect sl d+      (ne, ke) = pintersect el d+      -- Corners are translucent, so they are invisible, so if intersection+      -- is at a corner, choose pe that creates the smaller view.+      (ps, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check+      -- Single ray from an extremity, produces non-permissive digital lines.+      illegal  = let (n, k) = pintersect sl 0+                 in  ns*ke == ne*ks && (n == 0 || n == k)+      outside+        | d >= r = S.empty+        | 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++      dp2bump     (d, p) = B(p, d - p)+      bottomRight (d, p) = B(p, d - p + 1)+      tr = ptr . dp2bump++      pscan' :: Maybe Edge -> Progress -> Set Loc+      pscan' (Just s@(_, sBumps)) ps+        | ps > pe =                            -- reached end, scan next+            pscan r ptr l (d+1) (s, e)+        | 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++      pscan' Nothing ps+        | ps > ne `div` ke = S.empty           -- reached absolute end+        | otherwise =                          -- out of shadow, shallow bump+            -- the light can be just through a corner of diagonal walls+            -- and the recursive call verifies that at the same ps coordinate+            let shallowBump = bottomRight (d, ps)+                gte = psteeper shallowBump+                nsp = maximal gte eBumps+                nsBumps = addHull gte shallowBump sBumps+            in  pscan' (Just (pline nsp shallowBump, nsBumps)) ps++      pline p1 p2 =+        pdebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      psteeper f p1 p2 =+        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        steeper f p1 p2++-- | The y coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of squares at distance d from (0, 0).+pintersect :: Line -> Distance -> (Int, Int)+pintersect (B(y, x), B(yf, xf)) d =+  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))+{-+Derivation of the formula:+The intersection point (yt, xt) satisfies the following equalities:+xt = 1 + d - yt+(yt - y) (xf - x) = (xt - x) (yf - y)+hence+(yt - y) (xf - x) = (xt - x) (yf - y)+yt (xf - x) - y xf = xt (yf - y) - x yf+yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf+yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf+yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)++General remarks:+A square is denoted by its bottom-left corner. Hero at (0,0).+Order of processing in the first quadrant is+9+58+247+@136+so the first processed square is at (0, 1). The order is reversed+wrt the shadow casting algorithm above. The line in the curent state+of scan' is not the steep line, but the shallow line,+and we start scanning from the bottom right.++The Loc coordinates are cartesian, the Bump coordinates are cartesian,+translated so that the hero is at (0, 0) and rotated so that he always+looks at the first quadrant, the (Distance, Progress) cordinates+are mangled and not used for geometry.+-}++-- | Debug functions for PFOV:++-- | Debug: calculate steeper for PFOV in another way and compare results.+pdebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+pdebugSteeper f p1 p2 x =+  let (n1, k1) = pintersect (p1, f) 0+      (n2, k2) = pintersect (p2, f) 0+  in  if x == (n1 * k2 <= k1 * n2)+      then x+      else error $ "psteeper: " ++ show (f, p1, p2, x)++-- | Debug: checks postconditions of borderLine.+pdebugLine :: Line -> Line+pdebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "pdebugLine: wrongly defined line " ++ show line+  | x2 - x1 == - (y2 - y1) =+      error $ "pdebugLine: diagonal line " ++ show line+  | crossL0 =+      error $ "pdebugLine: crosses diagonal below 0 " ++ show line+  | crossG1 =+      error $ "pdebugLine: crosses diagonal above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = pintersect line 0+      (q, r)  = if k == 0 then (0, 0) else n `divMod` k+      crossL0 = q < 0  -- q truncated toward negative infinity+      crossG1 = q >= 1 && (q > 1 || r /= 0)
+ src/FOV/Shadow.hs view
@@ -0,0 +1,106 @@+module FOV.Shadow where++import Data.Ratio+import Data.Set as S++import FOV.Common+import Geometry+import Level+import qualified Tile++-- Recursive Shadow Casting.++-- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.+-- It's not designed for dungeons with diagonal walls, so they block visibility,+-- though they don't block movement. Such cases appear in the game only+-- when two corridors touch diagonally by accident and on the random pillars+-- levels.++{-+Field Of View+-------------++The algorithm used is a variant of Shadow Casting. We first compute+fields that are reachable (have unobstructed line of sight) from the hero's+position. Later, in Perception.hs,  from this information we compute+the fields that are visible (not hidden in darkness, etc.).++As input to the algorithm, we require information about fields that+block light. As output, we get information on the reachability of all fields.+We assume that the hero is located at position (0, 0)+and we only consider fields (line, row) where line >= 0 and 0 <= row <= line.+This is just about one eighth of the whole hero's surroundings,+but the other parts can be computed in the same fashion by mirroring+or rotating the given algorithm accordingly.++      fov (blocks, maxline) =+         shadow := \empty_set+         reachable (0, 0) := True+         for l \in [ 1 .. maxline ] do+            for r \in [ 0 .. l ] do+              reachable (l, r) := ( \exists a. a \in interval (l, r) \and+                                    a \not_in shadow)+              if blocks (l, r) then+                 shadow := shadow \union interval (l, r)+              end if+            end for+         end for+         return reachable++      interval (l, r) = return [ angle (l + 0.5, r - 0.5),+                                 angle (l - 0.5, r + 0.5) ]+      angle (l, r) = return atan (r / l)++The algorithm traverses the fields line by line, row by row.+At every moment, we keep in shadow the intervals which are in shadow,+measured by their angle. A square is reachable when any point+in it is not in shadow --- the algorithm is permissive in this respect.+We could also require that a certain fraction of the field is reachable,+or a specific point. Our choice has certain consequences. For instance,+a single blocking field throws a shadow, but the fields immediately behind+the blocking field are still visible.++We can compute the interval of angles corresponding to one square field+by computing the angle of the line passing the upper left corner+and the angle of the line passing the lower right corner.+This is what interval and angle do. If a field is blocking, the interval+for the square is added to the shadow set.+-}++-- | The current state of a scan is kept in a variable of Maybe Rational.+-- If Just something, we're in a visible interval. If Nothing, we're in+-- a shadowed interval.+scan :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc+scan tr l d (s,e) =+    let ps = downBias (s * fromIntegral d)   -- minimal progress to check+        pe = upBias (e * fromIntegral d)     -- maximal progress to check+        st = if Tile.open (l `at` tr (d,ps)) then Just s   -- start in light+                                             else Nothing  -- start in shadow+    in+        -- trace (show (d,s,e,ps,pe)) $+        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)+  where+    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc+    -- scan' st ps pe+    --   | trace (show (st,ps,pe)) False = undefined+    scan' (Just s) ps pe+      | s  >= e  = S.empty               -- empty interval+      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next+      | Tile.closed (l `at` tr (d,ps)) =+                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))+                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe+                                      -- entering shadow+      | otherwise = scan' (Just s) (ps+1) pe+                                      -- continue in light+    scan' Nothing ps pe+      | ps > pe  = S.empty            -- reached end while in shadow+      | Tile.open (l `at` tr (d,ps)) =+                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))+                   in  scan' (Just ns) (ps+1) pe+                                      -- moving out of shadow+      | otherwise = scan' Nothing (ps+1) pe+                                      -- continue in shadow++downBias, upBias :: (Integral a, Integral b) => Ratio a -> b+downBias x = round (x - 1 % (denominator x * 3))+upBias   x = round (x + 1 % (denominator x * 3))
+ src/File.hs view
@@ -0,0 +1,22 @@+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/Frequency.hs view
@@ -0,0 +1,31 @@+module Frequency where++import Control.Monad++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, +                             (q, y) <- runFrequency (f x) ]+  fail ""   =  Frequency []++instance MonadPlus Frequency where+  mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys)+  mzero = Frequency []++instance Functor Frequency where+  fmap f (Frequency xs) = Frequency (map (\ (p, x) -> (p, f x)) xs)++-- only try the second possibility if the first fails+melse :: Frequency a -> Frequency a -> Frequency a+melse (Frequency []) y = y+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))
+ src/Geometry.hs view
@@ -0,0 +1,116 @@+module Geometry where++import Data.List as L++-- | Game time in turns. (Placement in module Geometry is not ideal.)+type Time = Int++-- | Vertical directions.+data VDir = Up | Down+  deriving (Eq, Ord, Show, Enum, Bounded)++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)++fromTo1 :: X -> X -> [X]+fromTo1 x0 x1+  | x0 <= x1  = [x0..x1]+  | otherwise = [x0,x0-1..x1]++normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))+normalize (a,b) | a <= b    = (a,b)+                | otherwise = (b,a)++normalizeArea :: Area -> Area+normalizeArea a@((y0,x0),(y1,x1)) =+  ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))++grid :: (Y,X) -> Area -> [((Y,X), Area)]+grid (ny,nx) ((y0,x0),(y1,x1)) =+  let yd = y1 - y0+      xd = x1 - x0+  in [ ((y, x), ((y0 + (yd * y `div` ny),+                  x0 + (xd * x `div` nx)),+                 (y0 + (yd * (y + 1) `div` ny - 1),+                  x0 + (xd * (x + 1) `div` nx - 1))))+     | x <- [0..nx-1], y <- [0..ny-1] ]
+ src/GeometryRnd.hs view
@@ -0,0 +1,58 @@+module GeometryRnd where++import Data.List as L+import Data.Set as S++import Geometry+import Random++findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc+findLocInArea a@((y0, x0), (y1, x1)) p = do+  rx <- randomR (x0, x1)+  ry <- randomR (y0, y1)+  let loc = (ry, rx)+  if p loc then return loc else findLocInArea a p++locInArea :: Area -> Rnd Loc+locInArea a = findLocInArea a (const True)++connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X), (Y,X))] ->+                Rnd [((Y,X), (Y,X))]+connectGrid' (ny, nx) unconnected candidates acc+  | S.null candidates = return (L.map normalize acc)+  | otherwise = do+      c <- oneOf (S.toList candidates)+      -- potential new candidates:+      let ns = S.fromList $ neighbors ((0,0),(ny-1,nx-1)) c+          nu = S.delete c unconnected  -- new unconnected+          -- (new candidates, potential connections):+          (nc, ds) = S.partition (`S.member` nu) ns+      new <- if S.null ds+             then return id+             else do+                    d <- oneOf (S.toList ds)+                    return ((c,d) :)+      connectGrid' (ny,nx) nu (S.delete c (candidates `S.union` nc)) (new acc)++connectGrid :: (Y,X) -> Rnd [((Y,X), (Y,X))]+connectGrid (ny, nx) = do+  let unconnected = S.fromList [ (y, x) | x <- [0..nx-1], y <- [0..ny-1] ]+  -- candidates are neighbors that are still unconnected; we start with+  -- a random choice+  rx <- randomR (0, nx-1)+  ry <- randomR (0, ny-1)+  let candidates  = S.fromList [ (ry, rx) ]+  connectGrid' (ny, nx) unconnected candidates []++randomConnection :: (Y,X) -> Rnd ((Y,X), (Y,X))+randomConnection (ny, nx) = do+  rb  <- randomR (False, True)+  if rb+    then do+           rx  <- randomR (0, nx-2)+           ry  <- randomR (0, ny-1)+           return (normalize ((ry, rx), (ry, rx+1)))+    else do+           ry  <- randomR (0, ny-2)+           rx  <- randomR (0, nx-1)+           return (normalize ((ry, rx), (ry+1, rx)))
+ src/Grammar.hs view
@@ -0,0 +1,84 @@+module Grammar where++import Data.Char+import Data.Set as S+import Data.List as L+import qualified Data.IntMap as IM++import Item+import Movable+import MovableKind+import State+import ItemKind+import Effect+++suffixS :: String -> String+suffixS word = case last word of+                'y' -> init word ++ "ies"+                's' -> word ++ "es"+                'x' -> word ++ "es"+                _   -> word ++ "s"++capitalize :: String -> String+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++-- | How to refer to a movable in subject position of a sentence.+subjectMovable :: MovableKind -> String+subjectMovable x = capitalize $ objectMovable x++verbMovable :: MovableKind -> String -> String+verbMovable mk v = if nname mk == "you" then v else suffixS v++-- | Sentences such like "The dog barks".+subjectMovableVerb :: MovableKind -> String -> String+subjectMovableVerb x v = subjectMovable x ++ " " ++ verbMovable x v++compoundVerbMovable :: MovableKind -> String -> String -> String+compoundVerbMovable m v p = verbMovable m v ++ " " ++ p++subjectVerbIObject :: State -> Movable -> String -> Item -> String -> String+subjectVerbIObject state m v o add =+  subjectMovable (mkind m) ++ " " +++  verbMovable (mkind m) v ++ " " +++  objectItem state o ++ add ++ "."++subjectVerbMObject :: Movable -> String -> Movable -> String -> String+subjectVerbMObject m v o add =+  subjectMovable (mkind m) ++ " " +++  verbMovable (mkind m) v ++ " " +++  objectMovable (mkind o) ++ add ++ "."++subjCompoundVerbIObj :: State -> Movable -> String -> String ->+                        Item -> String -> String+subjCompoundVerbIObj state m v p o add =+  subjectMovable (mkind m) ++ " " +++  compoundVerbMovable (mkind m) v p ++ " " +++  objectItem state o ++ add ++ "."++makeObject :: Int -> (String -> String) -> String -> String+makeObject 1 adj obj = let b = adj obj+                       in  case b of+                             (c:_) | c `elem` "aeio" -> "an " ++ b+                             _                       -> "a " ++ b+makeObject n adj obj = show n ++ " " ++ adj (suffixS obj)++objectItem :: State -> Item -> String+objectItem state o =+  let ik = ikind o+      kind = ItemKind.getIK ik+      identified = L.length (jflavour kind) == 1 ||+                   ik `S.member` sdiscoveries state+      addSpace s = if s == "" then "" else " " ++ s+      eff = effectToName (jeffect kind)+      pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")"+      adj name = if identified+                 then name ++ addSpace eff ++ addSpace pwr+                 else let flavour = getFlavour (sassocs state) ik+                      in  flavourToName flavour ++ " " ++ name+  in  makeObject (icount o) adj (jname kind)
+ src/HighScores.hs view
@@ -0,0 +1,161 @@+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 File+import Dungeon+import qualified Config+import WorldLoc++-- | A single score.+-- TODO: add heroes' names, exp and level, cause of death, user number/name.+-- Note: I tried using Date.Time, but got all kinds of problems,+-- including build problems and opaque types that make serialization difficult,+-- and I couldn't use Datetime because it needs old base (and is under GPL).+-- TODO: When we finally move to Date.Time, let's take timezone into account.+data ScoreRecord = ScoreRecord+                     { points  :: Int,+                       negTurn :: Int,+                       date    :: ClockTime,+                       status  :: Status}+  deriving (Eq, Ord)++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+  put Victor       = putWord8 2+  get = do+          tag <- getWord8+          case tag of+            0 -> liftM Killed  get+            1 -> liftM Camping get+            2 -> return Victor++instance Binary ScoreRecord where+  put (ScoreRecord points negTurn date status) =+    do+      put points+      put negTurn+      put date+      put status+  get =+    do+      points <- get+      negTurn <- get+      date <- get+      status <- get+      return (ScoreRecord points negTurn date status)++-- | Show a single high score.+showScore :: (Int, ScoreRecord) -> String+showScore (pos, score) =+  let died  =+        case status score of+          Killed (LambdaCave n)  -> "perished on level " ++ show n ++ ","+          Camping (LambdaCave n) -> "is camping on level " ++ show n ++ ","+          Victor     -> "emerged victorious"+      time  = calendarTimeToString . toUTCTime . date $ score+      big   = "                                                 "+      lil   = "              "+      -- TODO: later: https://github.com/kosmikus/LambdaHack/issues#issue/9+      steps = negTurn score `div` (-10)+  in+   printf+     "%s\n%4d. %6d  This adventuring party %s after %d steps  \n%son %s.  \n"+     big pos (points score) died steps lil time++-- | The list of scores, in decreasing order.+type ScoreTable = [ScoreRecord]++-- | Empty score table+empty :: ScoreTable+empty = []++-- | Name of the high scores file.+file :: Config.CP -> IO String+file config = Config.getFile config "files" "highScores"++-- | We save a simple serialized version of the high scores table.+-- The 'False' is used only as an EOF marker.+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)++-- | 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 [])++-- | 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+  (prefix ++ [s] ++ suffix, L.length prefix + 1)++-- | Show a screenful of the high scores table.+-- Parameter height is the number of (3-line) scores to be shown.+showTable :: ScoreTable -> Int -> Int -> String+showTable h start height =+  let zipped    = zip [1..] h+      screenful = take height . drop (start - 1) $ zipped+  in+   L.concatMap showScore screenful++-- | Produces a couple of renderings of the high scores table.+slideshow :: Int -> ScoreTable -> Int -> [String]+slideshow pos h height =+  if pos <= height+  then [showTable h 1 height]+  else [showTable h 1 height,+        showTable h (max (height + 1) (pos - height `div` 2)) height]++-- | Take care of a new score, return a list of messages to display.+register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String])+register config write s =+  do+    h <- restore config+    let (h', pos) = insertPos s h+        (lines, _) = normalLevelSize+        height = lines `div` 3+        (msgCurrent, msgUnless) =+          case status s of+            Killed _  -> (" short-lived", " (score halved)")+            Camping _ -> (" current", " (unless you are slain)")+            Victor    -> (" glorious",+                          if pos <= height+                          then " among the greatest heroes"+                          else "")+        msg = printf "Your%s exploits award you place >> %d <<%s."+                msgCurrent pos msgUnless+    if write then save config h' else return ()+    return (msg, slideshow pos h' height)
+ src/Item.hs view
@@ -0,0 +1,191 @@+module Item where++import Data.Binary+import Data.Set as S+import Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Char+import Data.Function+import Control.Monad++import Random+import ItemKind+import qualified Color++data Item = Item+  { ikind    :: !Int,+    ipower   :: !Int,  -- https://github.com/Mikolaj/Allure/issues#issue/11+    iletter  :: Maybe Char,  -- ^ inventory identifier+    icount   :: !Int }+  deriving Show++instance Binary Item where+  put (Item ikind ipower iletter icount ) =+    put ikind >> put ipower >> put iletter >> put icount+  get = liftM4 Item get get get get++type Assocs = IM.IntMap Flavour++type Discoveries = S.Set Int++-- | Assinges 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)++-- | 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++getFlavour :: Assocs -> Int -> Flavour+getFlavour assocs ik =+  let kind = ItemKind.getIK ik+  in  case jflavour kind of+        []  -> error "getFlavour"+        [f] -> f+        _:_ -> assocs IM.! ik++viewItem :: Int -> Assocs -> (Char, Color.Color)+viewItem ik assocs = (jsymbol (getIK ik), flavourToColor $ getFlavour assocs ik)++itemLetter :: ItemKind -> Maybe Char+itemLetter ik = if jsymbol 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)+  if count == 0+    then newItem lvl  -- Rare item; beware of inifite loops.+    else do+      power <- rollQuad lvl (jpower kind)+      return $ Item ikChosen power (itemLetter kind) count++-- | Assigns a letter to an item, for inclusion+-- in the inventory of a hero. Takes a remembered+-- letter and a starting letter.+assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char+assignLetter r c is =+    case r of+      Just l | l `L.elem` allowed -> Just l+      _ -> listToMaybe free+  where+    current    = S.fromList (concatMap (maybeToList . iletter) is)+    allLetters = ['a'..'z'] ++ ['A'..'Z']+    candidates = take (length allLetters) $+                   drop (fromJust (L.findIndex (==c) allLetters)) $+                     cycle allLetters+    free       = L.filter (\x -> not (x `S.member` current)) candidates+    allowed    = '$' : free++cmpLetter :: Char -> Char -> Ordering+cmpLetter x y = compare (isUpper x, toLower x) (isUpper y, toLower y)++cmpLetter' :: Maybe Char -> Maybe Char -> Ordering+cmpLetter' Nothing  Nothing   = EQ+cmpLetter' Nothing  (Just _)  = GT+cmpLetter' (Just _) Nothing   = LT+cmpLetter' (Just l) (Just l') = cmpLetter l l'++maxBy :: (a -> a -> Ordering) -> a -> a -> a+maxBy cmp x y = case cmp x y of+                  LT  ->  y+                  _   ->  x++maxLetter = maxBy cmpLetter++mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char+mergeLetter = mplus++letterRange :: [Char] -> String+letterRange xs = sectionBy (sortBy cmpLetter xs) Nothing+  where+    succLetter c d = ord d - ord c == 1++    sectionBy []     Nothing      = ""+    sectionBy []     (Just (c,d)) = finish (c,d)+    sectionBy (x:xs) Nothing      = sectionBy xs (Just (x,x))+    sectionBy (x:xs) (Just (c,d))+      | succLetter d x            = sectionBy xs (Just (c,x))+      | otherwise                 = finish (c,d) ++ sectionBy xs (Just (x,x))++    finish (c,d) | c == d         = [c]+                 | succLetter c d = [c,d]+                 | otherwise      = [c,'-',d]++letterLabel :: Maybe Char -> String+letterLabel Nothing  = "    "+letterLabel (Just c) = c : " - "++-- | Adds an item to a list of items, joining equal items.+-- Also returns the joined item.+-- TODO: the resulting list can contain items with the same letter.+-- TODO: name [Item] Inventory and have some invariants, e.g. no equal letters.+joinItem :: Item -> [Item] -> (Item, [Item])+joinItem i is =+  case findItem (equalItemIdentity i) is of+    Nothing     -> (i, i : is)+    Just (j,js) -> let n = i { icount = icount i + icount j,+                               iletter = mergeLetter (iletter j) (iletter i) }+                   in (n, n : js)++-- | Removes an item from a list of items.+-- Takes an equality function (i.e., by letter or ny kind) as an argument.+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 []+                      else [x]++equalItemIdentity :: Item -> Item -> Bool+equalItemIdentity i1 i2 = ipower i1 == ipower i2 && ikind i1 == ikind i2++removeItemByIdentity = removeItemBy equalItemIdentity++equalItemLetter :: Item -> Item -> Bool+equalItemLetter = (==) `on` iletter++removeItemByLetter = removeItemBy equalItemLetter++-- | Finds an item in a list of items.+findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])+findItem p is = findItem' [] is+  where+    findItem' acc []     = 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+  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+    _ -> 0
+ src/ItemAction.hs view
@@ -0,0 +1,319 @@+module ItemAction where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Function+import Data.List as L+import Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe+import Data.Set as S+import System.Time++import Action+import Display hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified ItemKind+import qualified Keys as K+import Level+import LevelState+import Message+import Movable+import MovableState+import MovableKind+import MovableAdd+import Perception+import Random+import State+import qualified Config+import qualified Save+import qualified Effect+import EffectAction+import qualified Tile++-- Item UI code with the Action type and everything it depends on+-- that is not already in Action.hs and EffectAction.hs.+-- This file should not depend on Action.hs.++-- | Display inventory+inventory :: Action a+inventory = do+  items <- gets (mitems . getPlayerBody)+  if L.null items+    then abortWith "Not carrying anything."+    else do+           displayItems "Carrying:" True items+           session getConfirm+           abortWith ""++-- | Let the player choose any item with a given group name.+-- Note that this does not guarantee an item from the group to be chosen,+-- as the player can override the choice.+getGroupItem :: [Item] ->  -- all objects in question+                String ->  -- name of the group+                String ->  -- prompt+                String ->  -- how to refer to the collection of objects+                Action (Maybe Item)+getGroupItem is groupName prompt packName =+  let choice i = groupName == ItemKind.jname (ItemKind.getIK (ikind i))+      header = capitalize $ suffixS groupName+  in  getItem prompt choice header is packName++applyGroupItem :: Actor ->   -- actor applying the item; on current level+                  String ->  -- how the "applying" is called+                  Item ->    -- the item to be applied+                  Action ()+applyGroupItem actor verb item = do+  state <- get+  body  <- gets (getActor actor)+  per   <- currentPerception+  -- only one item consumed, even if several in inventory+  let consumed = item { icount = 1 }+      msg = subjectVerbIObject state body verb consumed ""+      loc = mloc body+  removeFromInventory actor consumed loc+  when (loc `S.member` ptvisible per) $ messageAdd msg+  itemEffectAction actor actor consumed+  advanceTime actor++playerApplyGroupItem :: String -> Action ()+playerApplyGroupItem groupName = do+  is   <- gets (mitems . getPlayerBody)+  iOpt <- getGroupItem is groupName+            ("What to " ++ applyToVerb groupName ++ "?") "in inventory"+  pl   <- gets splayer+  case iOpt of+    Just i  ->+      let verb = applyToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))+      in  applyGroupItem pl verb i+    Nothing -> neverMind True++applyToVerb :: String -> String+applyToVerb "potion" = "quaff"+applyToVerb "scroll" = "read"+applyToVerb _ = "destructively apply"++quaffPotion :: Action ()+quaffPotion = playerApplyGroupItem "potion"++readScroll :: Action ()+readScroll = playerApplyGroupItem "scroll"++zapGroupItem :: 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+                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+  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+      -- Messages inside itemEffectAction describe the target part.+      b <- itemEffectAction source ta consumed+      when (not b) $+        modify (updateLevel (dropItemsAt [consumed] loc))+    Nothing ->+      modify (updateLevel (dropItemsAt [consumed] loc))+  advanceTime source++playerZapGroupItem :: String -> Action ()+playerZapGroupItem groupName = do+  state <- get+  is    <- gets (mitems . getPlayerBody)+  iOpt  <- getGroupItem is groupName+             ("What to " ++ zapToVerb groupName ++ "?") "in inventory"+  pl    <- gets splayer+  per   <- currentPerception+  case iOpt of+    Just i  ->+      case targetToLoc (ptvisible per) state of+        Nothing  -> abortWith "target invalid"+        Just loc ->+          -- TODO: draw digital line and see if obstacles prevent firing+          if actorReachesLoc pl loc per (Just pl)+          then let verb = zapToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))+               in  zapGroupItem pl loc verb i+          else abortWith "target not reachable"+    Nothing -> neverMind True++zapToVerb :: String -> String+zapToVerb "wand" = "aim"+zapToVerb "dart" = "throw"+zapToVerb _ = "furiously zap"++aimItem :: Action ()+aimItem = playerZapGroupItem "wand"++throwItem :: Action ()+throwItem = playerZapGroupItem "dart"++-- | Drop a single item.+-- TODO: allow dropping a given number of identical items.+dropItem :: Action ()+dropItem = do+  pl    <- gets splayer+  state <- get+  pbody <- gets getPlayerBody+  ploc  <- gets (mloc . getPlayerBody)+  items <- gets (mitems . getPlayerBody)+  iOpt  <- getAnyItem "What to drop?" items "inventory"+  case iOpt of+    Just stack -> do+      let i = stack { icount = 1 }+      removeOnlyFromInventory pl i (mloc pbody)+      messageAdd (subjectVerbIObject state pbody "drop" i "")+      modify (updateLevel (dropItemsAt [i] ploc))+    Nothing -> neverMind True+  playerAdvanceTime++-- TODO: this is a hack for dropItem, because removeFromInventory+-- makes it impossible to drop items if the floor not empty.+removeOnlyFromInventory :: Actor -> Item -> Loc -> Action ()+removeOnlyFromInventory actor i loc = do+  updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems m) })++-- | Remove given item from an actor's inventory or floor.+-- TODO: this is subtly wrong: if identical items are on the floor and in+-- inventory, the floor one will be chosen, regardless of player intention.+-- TODO: right now it ugly hacks (with the ploc) around removing items+-- of dead heros/monsters. The subtle incorrectness helps here a lot,+-- because items of dead heroes land on the floor, so we use them up+-- in inventory, but remove them after use from the floor.+removeFromInventory :: Actor -> Item -> Loc -> Action ()+removeFromInventory actor i loc = do+  b <- removeFromLoc i loc+  when (not b) $+    updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems 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))+    then return False+    else+      modify (updateLevel (updateLMap adj)) >>+      return True+        where+          adj = M.adjust (\ (t, rt) -> (remove t, rt)) loc+          remove t = t { Tile.titems = removeItemByIdentity i (Tile.titems t) }++actorPickupItem :: Actor -> Action ()+actorPickupItem actor = do+  state <- get+  pl    <- gets splayer+  per   <- currentPerception+  lmap  <- gets (lmap . slevel)+  body  <- gets (getActor actor)+  let loc       = mloc body+      t         = lmap `at` loc -- the map tile in question+      perceived = loc `S.member` ptvisible per+      isPlayer  = actor == pl+  -- check if something is here to pick up+  case Tile.titems t of+    []   -> abortIfWith isPlayer "nothing here"+    i:rs -> -- pick up first item; TODO: let player select item;not for monsters+      case assignLetter (iletter i) (mletter body) (mitems body) of+        Just l -> do+          let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems body)+          -- message depends on who picks up and if a hero can perceive it+          if isPlayer+            then messageAdd (letterLabel (iletter ni) ++ objectItem state ni)+            else when perceived $+                   messageAdd $ subjCompoundVerbIObj state body "pick" "up" i ""+          assertTrue $ removeFromLoc i loc+          -- add item to actor's inventory:+          updateAnyActor actor $ \ m ->+            m { mitems = nitems, mletter = maxLetter l (mletter body) }+        Nothing -> abortIfWith isPlayer "cannot carry any more"+  advanceTime actor++pickupItem :: Action ()+pickupItem = do+  pl <- gets splayer+  actorPickupItem pl++-- TODO: I think that player handlers should be wrappers+-- around more general actor handlers, but+-- the actor handlers should be performing+-- specific actions, i.e., already specify the item to be+-- picked up. It doesn't make sense to invoke dialogues+-- for arbitrary actors, and most likely the+-- decision for a monster is based on perceiving+-- a particular item to be present, so it's already+-- known. In actor handlers we should make sure+-- that messages are printed to the player only if the+-- hero can perceive the action.+-- Perhaps this means half of this code should be split and moved+-- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed.++-- | Let the player choose any item from a list of items.+-- TODO: you can drop an item on the floor, which works correctly,+-- but is weird and useless.+getAnyItem :: String ->  -- prompt+              [Item] ->  -- all objects in question+              String ->  -- how to refer to the collection of objects+              Action (Maybe Item)+getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn++-- | Let the player choose a single item from a list of items.+getItem :: String ->              -- prompt message+           (Item -> Bool) ->      -- which items to consider suitable+           String ->              -- how to describe suitable objects+           [Item] ->              -- all objects in question+           String ->              -- how to refer to the collection of objects+           Action (Maybe Item)+getItem prompt p ptext is0 isn = do+  lmap  <- gets (lmap . slevel)+  body  <- gets getPlayerBody+  let loc       = mloc body+      t         = lmap `at` loc -- the map tile in question+      tis       = Tile.titems t+      floorMsg  = if L.null tis then "" else " -,"+      is = L.filter p is0+      choice = if L.null is+               then "[*," ++ floorMsg ++ " ESC]"+               else let r = letterRange (concatMap (maybeToList . iletter) is)+                    in  "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]"+      interact = do+        when (L.null is0 && L.null tis) $+          abortWith "Not carrying anything."+        messageWipeAndSet (prompt ++ " " ++ choice)+        display+        session nextCommand >>= perform+      perform command = do+        resetMessage+        case command of+          K.Char '?' -> do+            -- filter for supposedly suitable objects+            b <- displayItems (ptext ++ " " ++ isn) True is+            if b then session (getOptionalConfirm (const interact) perform)+                 else interact+          K.Char '*' -> do+            -- show all objects+            b <- displayItems ("Objects " ++ isn) True is0+            if b then session (getOptionalConfirm (const interact) perform)+                 else interact+          K.Char '-' ->+            case tis of+              []   -> return Nothing+              i:rs -> -- use first item; TODO: let player select item+                      return $ Just i+          K.Char l   ->+            return (find (\ i -> maybe False (== l) (iletter i)) is0)+          K.Return   ->  -- TODO: i should be the first displayed (except $)+            return (case is of [] -> Nothing ; i : _ -> Just i)+          _          -> return Nothing+  interact
+ src/ItemKind.hs view
@@ -0,0 +1,169 @@+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
@@ -0,0 +1,41 @@+module Keybindings where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Map as M+import Data.List as L++import Action+import Command+import qualified Keys as K++-- | Keybindings.+data Keybindings = Keybindings+  { 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 ++ ")"++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) ' '+    blank   = fmt "" ""+    title   = fmt "keys" "command"+    footer  = fmts "(See file PLAYING.markdown.)"+    disp k  = L.concatMap show $ aliases k+    rest    = [ fmt (disp k) h+              | (k, Described h _) <- M.toAscList (kother kb) ]+  in+    unlines ([blank, title] ++ rest ++ [blank, footer, blank])
+ src/Keys.hs view
@@ -0,0 +1,156 @@+module Keys where++import Prelude hiding (Left, Right)++import Geometry hiding (Up, Down)+import Data.Maybe+import Data.List as L+import Data.Map as M++-- | Library-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | Tab+  | PgUp+  | PgDn+  | Left+  | Right+  | Up+  | Down+  | 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+  deriving (Ord, Eq)++showKey :: Key -> String+showKey (Char ' ') = "<space>"  -- warnings about "command ( )" look wrong+showKey (Char c) = [c]+showKey Esc      = "ESC"  -- these three are common and terse abbreviations+showKey Return   = "RET"+showKey Tab      = "TAB"+showKey PgUp     = "<page-up>"+showKey PgDn     = "<page-down>"+showKey Left     = "<left>"+showKey Right    = "<right>"+showKey Up       = "<up>"+showKey Down     = "<down>"+showKey End      = "<end>"+showKey Begin    = "<begin>"+showKey Home     = "<home>"+showKey (KP c)   = "<KeyPad " ++ [c] ++ ">"+showKey (Unknown s) = s++instance Show Key where+  show = showKey++-- | Maps a keypad movement key to the canonical form.+-- Hard-coded not to bloat config files.+canonMoveKey :: Key -> Key+canonMoveKey e =+  case e of+    KP '8' -> Char 'K'+    KP '2' -> Char 'J'+    KP '4' -> Char 'H'+    KP '6' -> Char 'L'+    KP '7' -> Char 'Y'+    KP '9' -> Char 'U'+    KP '1' -> Char 'B'+    KP '3' -> Char 'N'+    KP '5' -> Char '.'+    Up     -> Char 'k'+    Down   -> Char 'j'+    Left   -> Char 'h'+    Right  -> Char 'l'+    Home   -> Char 'y'+    PgUp   -> Char 'u'+    End    -> Char 'b'+    PgDn   -> Char 'n'+    Begin  -> Char '.'+    k      -> k++-- | Configurable event handler for the direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleDirection :: Key -> (Dir -> a) -> a -> a+handleDirection e h k =+  case e of+    Char 'k' -> h up+    Char 'j' -> h down+    Char 'h' -> h left+    Char 'l' -> h right+    Char 'y' -> h upleft+    Char 'u' -> h upright+    Char 'b' -> h downleft+    Char 'n' -> h downright+    _          -> k++-- | Configurable event handler for the upper direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleUDirection :: Key -> (Dir -> a) -> a -> a+handleUDirection e h k =+  case e of+    Char 'K' -> h up+    Char 'J' -> h down+    Char 'H' -> h left+    Char 'L' -> h right+    Char 'Y' -> h upleft+    Char 'U' -> h upright+    Char 'B' -> h downleft+    Char 'N' -> h downright+    _          -> k++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the macros in the config file.+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "comma"         = Char ','+keyTranslate "space"         = Char ' '+keyTranslate "question"      = Char '?'+keyTranslate "dollar"        = Char '$'+keyTranslate "asterisk"      = Char '*'+keyTranslate "KP_Multiply"   = Char '*'+keyTranslate "slash"         = Char '/'+keyTranslate "KP_Divide"     = Char '/'+keyTranslate "underscore"    = Char '_'+keyTranslate "minus"         = Char '-'+keyTranslate "KP_Subtract"   = Char '-'+keyTranslate "Escape"        = Esc+keyTranslate "Return"        = Return+keyTranslate "Tab"           = Tab+keyTranslate "KP_Up"         = Up+keyTranslate "KP_Down"       = Down+keyTranslate "KP_Left"       = Left+keyTranslate "KP_Right"      = Right+keyTranslate "KP_Home"       = Home+keyTranslate "KP_End"        = End+keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "KP_Begin"      = Begin+keyTranslate "KP_Enter"      = Return+keyTranslate ['K','P','_',c] = KP c+keyTranslate [c]             = Char c+keyTranslate s               = Unknown s++-- | Maps a key to the canonical key for the command it denotes.+-- Takes into account the keypad and any macros from a config file.+-- Macros cannot depend on each other, but they can on canonMoveKey.+-- This has to be fully evaluated to catch errors in macro definitions early.+macroKey :: [(String, String)] -> M.Map Key Key+macroKey section =+  let trans k = case keyTranslate k of+                  Unknown s -> error $ "unknown macro key " ++ s+                  kt -> kt+      trMacro (from, to) = let fromTr = trans from+                               !toTr  = canonMoveKey $ trans to+                           in  if fromTr == toTr+                               then error $ "degenerate alias for " ++ show toTr+                               else (fromTr, toTr)+  in  M.fromList $ L.map trMacro section
+ src/Level.hs view
@@ -0,0 +1,128 @@+module Level where++import Control.Monad++import Data.Binary+import Data.Map as M+import Data.List as L+import qualified Data.IntMap as IM++import Geometry+import GeometryRnd+import Movable+import Item+import Random+import qualified Terrain+import WorldLoc+import Data.Maybe+import qualified Tile++type Party = IM.IntMap Movable++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 }+  deriving Show++updateLMap :: (LMap -> LMap) -> Level -> Level+updateLMap f lvl = lvl { lmap = f (lmap lvl) }++updateSMap :: (SMap -> SMap) -> Level -> Level+updateSMap f lvl = lvl { lsmell = f (lsmell lvl) }++updateMonsters :: (Party -> Party) -> Level -> Level+updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) }++updateHeroes :: (Party -> Party) -> Level -> Level+updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) }++emptyParty :: Party+emptyParty = IM.empty++instance Binary Level where+  put (Level nm hs sz@(sy,sx) ms lsmell lmap lmeta) =+        do+          put nm+          put hs+          put sz+          put ms+          put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]+          put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ]+          put lmeta+  get = do+          nm <- get+          hs <- get+          sz@(sy,sx) <- 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++at         l p = fst (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l)+rememberAt l p = snd (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l)++-- 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++-- 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++-- 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++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++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++-- 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
+ src/LevelState.hs view
@@ -0,0 +1,35 @@+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++-- | Produces a textual description of the terrain and items at an already+-- explored location. Mute for unknown locations.+-- The "detailed" variant is for use in the targeting mode.+lookAt :: Bool -> Bool -> State -> LMap -> Loc -> String -> String+lookAt detailed canSee s lmap loc msg+  | detailed  =+    Terrain.lookTerrain (Tile.tterrain (lmap `rememberAt` loc)) ++ " " ++ msg ++ isd+  | otherwise = msg ++ isd+  where+    is  = Tile.titems (lmap `rememberAt` loc)+    prefixSee = if canSee then "You see " else "You remember "+    prefixThere = if canSee+                  then "There are several objects here"+                  else "You remember several objects here"+    isd = case is of+            []    -> ""+            [i]   -> prefixSee ++ objectItem s i ++ "."+            [i,j] -> prefixSee ++ objectItem s i ++ " and "+                               ++ objectItem s j ++ "."+            _     -> prefixThere ++ if detailed then ":" else "."
+ src/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import System.Directory+import Data.Map as M++import Action+import State+import DungeonState+import qualified Display+import Random+import qualified Save+import Turn+import qualified Config+import MovableAdd+import Item+import qualified Keys as K++main :: IO ()+main = Display.startup start++-- | Either restore a saved game, or setup a new game.+start :: Display.InternalSession -> IO ()+start internalSession = do+  config <- Config.config+  let section = Config.getItems config "macros"+      !macros = K.macroKey section+      session = (internalSession, macros)+  -- check if we have a savegame+  f <- Save.file config+  b <- doesFileExist f+  restored <- if b+              then do+                     Display.displayBlankConfirm session "Restoring save game"+                     Save.restoreGame config+              else return $ Right "Welcome to 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 }+          hstate = initialHeroes ploc state+      handlerToIO session hstate msg handle+    Left state ->+      handlerToIO session state "Welcome back to Allure of the Stars." handle
+ src/Message.hs view
@@ -0,0 +1,32 @@+module Message where++import Data.List as L+import Data.Char++type Message = String++more :: Message+more = " --more--  "++yesno :: Message+yesno = " [yn]"++addMsg :: Message -> Message -> Message+addMsg [] x  = x+addMsg xs [] = xs+addMsg xs x  = xs ++ " " ++ x++splitMsg :: Int -> Message -> [String]+splitMsg w xs+  | w <= m = [xs]   -- border case, we cannot make progress+  | l <= w = [xs]   -- no problem, everything fits+  | otherwise =+      let (pre, post) = splitAt (w - m) xs+          (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre+          rpost = dropWhile isSpace ppost+      in  if L.null rpost+          then pre : splitMsg w post+          else reverse rpost : splitMsg w (reverse ppre ++ post)+  where+    m = length more+    l = length xs
+ src/Movable.hs view
@@ -0,0 +1,83 @@+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 view
@@ -0,0 +1,109 @@+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 view
@@ -0,0 +1,111 @@+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 view
@@ -0,0 +1,123 @@+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 view
@@ -0,0 +1,8 @@+module Multiline (multiline) where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TQ++-- | Used to handle multiline verbatim string expressions, see ConfigDefault.hs.+multiline :: TQ.QuasiQuoter+multiline  = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined
+ src/Perception.hs view
@@ -0,0 +1,114 @@+module Perception where++import qualified Data.Set as S+import Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad++import Geometry+import State+import Level+import Movable+import MovableState+import qualified MovableKind+import FOV+import qualified Config+import qualified Tile++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 }++ptreachable, ptvisible :: Perceptions -> S.Set Loc+ptreachable = preachable . ptotal+ptvisible   = pvisible . ptotal++actorPrLoc :: (Perception -> S.Set Loc) ->+              Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+actorPrLoc projection actor loc per pl =+  let tryHero = case actor of+                  AMonster _ -> Nothing+                  AHero i -> do+                    hper <- IM.lookup i (pheroes per)+                    return $ loc `S.member` (projection hper)+      tryPl   = do  -- the case for a monster under player control+                  guard $ Just actor == pl+                  pper <- pplayer per+                  return $ loc `S.member` projection pper+      tryAny  = tryHero `mplus` tryPl+  in  fromMaybe False tryAny  -- assume not visible, if no perception found++actorSeesLoc    :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+actorSeesLoc    = actorPrLoc pvisible++actorReachesLoc :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool+actorReachesLoc = actorPrLoc preachable++-- Not quite correct if FOV not symmetric (Shadow).+actorReachesActor :: Actor -> Actor -> Loc -> Loc -> Perceptions -> Maybe Actor+                     -> Bool+actorReachesActor actor1 actor2 loc1 loc2 per pl =+  actorReachesLoc actor1 loc2 per pl ||+  actorReachesLoc actor2 loc1 per pl++perception_ :: State -> Perceptions+perception_ state@(State { splayer = pl,+                           slevel   = Level { lmap = lmap, lheroes = hs },+                           sconfig  = config,+                           ssensory = sensory }) =+  let mode   = Config.get config "engine" "fovMode"+      radius = Config.get config "engine" "fovRadius"+      fovMode m = if not $ MovableKind.nsight (mkind m) then Blind else+        -- terrible, temporary hack+        case sensory of+          Vision 3 -> Digital radius+          Vision 2 -> Permissive radius+          Vision 1 -> Shadow+          _        ->+            -- this is not a hack+            case mode of+              "permissive" -> Permissive radius+              "digital"    -> Digital radius+              "shadow"     -> Shadow+              _            -> error $ "perception_: unknown mode: " ++ show mode++      -- Perception for a player-controlled monster on the current level.+      pper = if isAMonster pl && memActor pl state+             then let m = getPlayerBody state+                  in Just $ perception (fovMode m) (mloc m) lmap+             else Nothing+      pers = IM.map (\ h -> perception (fovMode h) (mloc h) lmap) hs+      lpers = maybeToList pper ++ IM.elems pers+      reachable = S.unions (L.map preachable lpers)+      visible = S.unions (L.map pvisible lpers)+  in  Perceptions { pplayer = pper,+                    pheroes = pers,+                    ptotal = Perception reachable visible }++-- | 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 =+  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 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))+        reachable+    -- Visible fields are either lit or adjacent to lit.+    visible = S.union litVisible adjVisible+  in Perception reachable visible
+ src/Random.hs view
@@ -0,0 +1,100 @@+module Random (module Frequency, module Random) where++import qualified Data.Binary as Binary+import Data.Ratio+import Data.List as L+import qualified System.Random as R+import Control.Monad.State++import Frequency++type Rnd a = State R.StdGen a++-- Written in a "portable" way because the implementation of+-- State changes between mtl versions 1 and 2.+randomR :: (R.Random a) => (a, a) -> Rnd a+randomR rng =+  do+    g <- get+    let (x, ng) = R.randomR rng g+    put ng+    return x++binaryChoice :: a -> a -> Rnd a+binaryChoice p0 p1 =+  do+    b <- randomR (False,True)+    return (if b then p0 else p1)++chance :: Rational -> Rnd Bool+chance r =+  do+    let n = numerator r+        d = denominator r+    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)++oneOf :: [a] -> Rnd a+oneOf xs =+  do+    r <- randomR (0, length xs - 1)+    return (xs !! r)++frequency :: Frequency a -> Rnd a+frequency (Frequency xs) =+  do+    r <- randomR (1, sum (map fst xs))+    return (frequency' r xs)+ where+  frequency' :: Int -> [(Int, a)] -> a+  frequency' _ [(_, x)] = x+  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 *~+infixl 6 ~+~++(~+~) :: Num a => Rnd a -> Rnd a -> Rnd a+(~+~) = liftM2 (+)++(*~) :: Num a => Int -> Rnd a -> Rnd a+x *~ r = liftM sum (replicateM x r)++-- RollDice: 1d7, 3d3, etc. (a, b) represent (a *~ d b).+type RollDice = (Binary.Word8, Binary.Word8)++rollDice :: RollDice -> Rnd Int+rollDice (a', b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in  a *~ d b++-- rollQuad (a, b, x, y) = a *~ d b + (lvl * (x *~ d y)) / 10+type RollQuad = (Binary.Word8, Binary.Word8, Binary.Word8, Binary.Word8)++rollQuad :: Int -> RollQuad -> Rnd Int+rollQuad lvl (a, b, x, y) = do+  aDb <- rollDice (a, b)+  xDy <- rollDice (x, y)+  return $ aDb + (lvl * xDy) `div` 10++intToQuad :: Int -> RollQuad+intToQuad 0 = (0, 0, 0, 0)+intToQuad n = let n' = fromIntegral n+              in  if n' > maxBound || n' < minBound+                  then error "intToQuad"+                  else (n', 1, 0, 0)
+ src/Save.hs view
@@ -0,0 +1,52 @@+module Save where++import System.Directory+import Control.Exception as E hiding (handle)++import File+import Level+import State+import qualified Config++-- | Name of the save game.+file :: Config.CP -> IO FilePath+file config = Config.getFile config "files" "saveGame"++-- | We save a simple serialized version of the current level and+-- the current state. The 'False' is used only as an EOF marker.+saveGame :: State -> IO ()+saveGame state =+  do+    f <- file (sconfig state)+    encodeCompressedFile f (state, False)++-- | Restore a saved game. Returns either the current level and+-- game state, or a string containing an error message if restoring+-- 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+                    _ -> return (Right $+                                   "Restore failed: "+                                   ++ (unwords . lines) (show e)))++-- | Move the savegame file to a backup slot.+mvBkp :: Config.CP -> IO ()+mvBkp config =+  do+    f <- file config+    renameFile f (f ++ ".bkp")++-- | Remove the backup of the savegame. Should be called before any+-- non-error exit from the game.+rmBkp :: Config.CP -> IO ()+rmBkp config =+  do+    f <- file config+    E.catch (removeFile (f ++ ".bkp"))+      (\ e -> case e :: IOException of _ -> return ())
+ src/State.hs view
@@ -0,0 +1,178 @@+module State where++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap as IM+import Control.Monad+import Data.Binary+import qualified Config++import Movable+import Geometry+import Level+import 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+  }+  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+  }+  deriving Show++defaultState :: Dungeon -> Level -> State+defaultState dng lvl =+  State+    (AHero 0)+    (Cursor False (LambdaCave (-1)) (-1, -1) (lname lvl))+    []+    Implicit Normal+    0+    IM.empty+    S.empty+    dng+    lvl+    (0, 0)+    (Config.defaultCP)++updateCursor :: (Cursor -> Cursor) -> State -> State+updateCursor f s = s { scursor = f (scursor s) }++updateHistory :: ([String] -> [String]) -> State -> State+updateHistory f s = s { shistory = f (shistory s) }++updateTime :: (Time -> Time) -> State -> State+updateTime f s = s { stime = f (stime s) }++updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State+updateDiscoveries f s = s { sdiscoveries = f (sdiscoveries s) }++updateLevel :: (Level -> Level) -> State -> State+updateLevel f s = s { slevel = f (slevel s) }++updateDungeon :: (Dungeon -> Dungeon) -> State -> State+updateDungeon f s = s {sdungeon = f (sdungeon s)}++toggleVision :: State -> State+toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Smell+                                                   Vision n -> Vision (n-1)+                                                   Smell    -> Implicit+                                                   Implicit -> Vision 3 }++toggleOmniscient :: State -> State+toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient+                                    then Normal+                                    else Omniscient }++toggleTerrain :: State -> State+toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal+                                                    Terrain n -> Terrain (n-1)+                                                    _         -> Terrain 4 }++instance Binary State where+  put (State player cursor hst sense disp time assocs discs dng lvl ct config) =+    do+      put player+      put cursor+      put hst+      put sense+      put disp+      put time+      put assocs+      put discs+      put dng+      put lvl+      put ct+      put config+  get =+    do+      player <- get+      cursor <- get+      hst    <- get+      sense  <- get+      disp   <- get+      time   <- get+      assocs <- get+      discs  <- get+      dng    <- get+      lvl    <- get+      ct     <- get+      config <- get+      return+        (State player cursor hst sense disp time assocs discs dng lvl ct config)++instance Binary Cursor where+  put (Cursor act cln loc rln) =+    do+      put act+      put cln+      put loc+      put rln+  get =+    do+      act <- get+      cln <- get+      loc <- get+      rln <- get+      return (Cursor act cln loc rln)++data SensoryMode =+    Implicit+  | Vision Int+  | Smell+  deriving (Show, Eq)++instance Binary SensoryMode where+  put Implicit   = putWord8 0+  put (Vision n) = putWord8 1 >> put n+  put Smell      = putWord8 2+  get = do+          tag <- getWord8+          case tag of+            0 -> return Implicit+            1 -> liftM Vision get+            2 -> return Smell+            _ -> fail "no parse (SensoryMode)"++data DisplayMode =+    Normal+  | Omniscient+  | Terrain Int  -- TODO: unused right now+  deriving (Show, Eq)++instance Binary DisplayMode where+  put Normal      = putWord8 0+  put Omniscient  = putWord8 1+  put (Terrain n) = putWord8 2 >> put n+  get = do+          tag <- getWord8+          case tag of+            0 -> return Normal+            1 -> return Omniscient+            2 -> liftM Terrain get+            _ -> fail "no parse (DisplayMode)"
+ src/Strategy.hs view
@@ -0,0 +1,50 @@+module Strategy where++import Control.Monad++import Frequency++-- Monster strategies++-- | A strategy is a choice of frequency tables.+newtype Strategy a = Strategy { runStrategy :: [Frequency a] }+  deriving Show++-- | Strategy is a monad. TODO: Can we write this as a monad transformer?+instance Monad Strategy where+  return x = Strategy $ return (Frequency [(1, x)])+  m >>= f  = Strategy $+               filter (\ (Frequency xs) -> not (null xs))+               [ Frequency [ (p * q, b)+                           | (p, a) <- runFrequency x,+                             y <- runStrategy (f a),+                             (q, b) <- runFrequency y ]+               | x <- runStrategy m ]++liftFrequency :: Frequency a -> Strategy a+liftFrequency f  =+  Strategy $ filter (\ (Frequency xs) -> not (null xs)) $ return f++instance MonadPlus Strategy where+  mzero = Strategy []+  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)++infixr 2 .|++(.|) :: Strategy a -> Strategy a -> Strategy a+(.|) = mplus++reject :: Strategy a+reject = mzero++infix 3 .=>++(.=>) :: Bool -> Strategy a -> Strategy a+p .=> m | p          =  m+        | otherwise  =  mzero++only :: (a -> Bool) -> Strategy a -> Strategy a+only p s =+  do+    x <- s+    p x .=> return x
+ src/StrategyState.hs view
@@ -0,0 +1,217 @@+module StrategyState where++import Data.List as L+import Data.Map as M+import Data.Set as S+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad+import Control.Monad.State hiding (State)+import Control.Exception (assert)++import Geometry+import Level+import Movable+import MovableState+import MovableKind+import Random+import Perception+import Strategy+import State+import Action+import Actions+import ItemAction+import qualified ItemKind+import Item+import qualified Effect+import qualified Tile++-- import Debug.Trace++{-+Monster movement+----------------++Not all monsters use the same algorithm to find the hero.+Some implemented and unimplemented methods are listed below:++* Random+The simplest way to have a monster move is at random.++* Sight+If a monster can see the hero (as an approximation,+we assume it is the case when the hero can see the monster),+the monster should move toward the hero.++* Smell+The hero leaves a trail when moving toward the dungeon.+For a certain timespan (100--200 moves), it is possible+for certain monsters to detect that a hero has been at a certain field.+Once a monster is following a trail, it should move to the+neighboring field where the hero has most recently visited.++* Noise+The hero makes noise. If the distance between the hero+and the monster is small enough, the monster can hear the hero+and moves into the approximate direction of the hero.+-}++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+  where+    Movable { mkind = mk, mloc = me, mdir = mdir,+              mtarget = tgt, mitems = items } =+      getActor actor oldState+    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 ||+      -- Any enemy is visible if adjacent (e. g., a monster player).+      memActor a delState && adjacent me l+    -- If no heroes on the level, monsters go at each other. TODO: let them+    -- earn XP by killing each other to make this dangerous to the player.+    hs = L.map (\ (i, m) -> (AHero i, mloc m)) $+         IM.assocs $ lheroes $ slevel delState+    ms = L.map (\ (i, m) -> (AMonster i, mloc m)) $+         IM.assocs $ lmonsters $ slevel delState+    -- Below, "foe" is the hero (or a monster, or loc) chased by the actor.+    (newTgt, floc) =+      case tgt of+        TEnemy a ll | focusedMonster ->+          case findActorAnyLevel a delState of+            Just (_, m) ->+              let l = mloc m+              in  if enemyVisible a l+                  then (TEnemy a l, Just l)+                  else if isJust (snd closest) || me == ll+                       then closest         -- prefer visible foes+                       else (tgt, Just ll)  -- last known location of enemy+            Nothing -> closest  -- enemy dead, monsters can feel it+        TLoc loc -> if me == loc+                    then closest+                    else (tgt, Just loc)  -- ignore everything and go to loc+        _  -> closest+    closest =+      let hsAndTraitor = if isAMonster pl+                         then (pl, mloc $ getPlayerBody delState) : hs+                         else hs+          foes = if L.null hsAndTraitor then ms else hsAndTraitor+          -- We assume monster sight is infravision, so light has no effect.+          foeVisible = L.filter (\ (a, l) -> enemyVisible a l) foes+          foeDist = L.map (\ (a, l) -> (distance (me, l), l, a)) foeVisible+      in  case foeDist of+            [] -> (TCursor, Nothing)+            _  -> let (_, l, a) = L.minimum foeDist+                  in  (TEnemy a l, Just l)+    onlyFoe        = onlyMoves (maybe (const False) (==) floc) me+    towardsFoe     = case floc of+                       Nothing -> const mzero+                       Just loc ->+                         let foeDir = towards (me, loc)+                         in  only (\ x -> distance (foeDir, x) <= 1)+    lootHere       = (\ x -> not $ L.null $ Tile.titems $ lmap `at` x)+    onlyLoot       = onlyMoves lootHere me+    exitHere       = (\ x -> let t = lmap `at` x in Tile.open t && 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+    -- 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+    onlyOpenable   = onlyMoves openableHere me+    accessibleHere = accessible lmap me+    onlySensible   = onlyMoves (\ l -> accessibleHere l || openableHere l) me+    focusedMonster = niq mk > 10+    smells         =+      L.map fst $+      L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $+      L.filter (\ (_, s) -> s > 0) $+      L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves+    fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d++    strategy =+      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+    freqs = [applyFreq items 1, applyFreq tis 2,+             throwFreq items 2, throwFreq tis 5, towardsFreq]+    applyFreq is multi = Frequency+      [ (benefit * multi, actionApply (ItemKind.jname ik) i)+      | i <- is,+        let ik = ItemKind.getIK (ikind i),+        let benefit =+              (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+        benefit > 0,+        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)+      | i <- is,+        let ik = ItemKind.getIK (ikind i),+        let benefit =+              - (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),+        benefit > 0,+        -- Wasting swords would be too cruel to the player.+        not (ItemKind.jname ik == "sword")]+    actionThrow groupName item =+      zapGroupItem actor (fromJust floc) (zapToVerb groupName) item+    towardsFreq =+      let freqs = runStrategy $ fromDir False moveTowards+      in  if nsight mk && not (L.null freqs)+          then scale 30 $ head freqs+          else mzero+    moveTowards =+      onlySensible $+        onlyUnoccupied (towardsFoe moveFreely)+        .| towardsFoe moveFreely+    moveAround =+      onlySensible $+        (if nsight mk then onlyUnoccupied else id) $+          nsmell mk .=> L.foldr (.|) reject (L.map return 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+                 .| onlyKeepsDir_9 moveRandomly+                 .| moveRandomly++dirToAction :: Actor -> Target -> Bool -> Dir -> Action ()+dirToAction actor tgt allowAttacks dir =+  assert (dir /= (0,0)) $ do+  -- set new direction+  updateAnyActor actor $ \ m -> m { mdir = Just dir, mtarget = 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 actor = return $ advanceTime actor
+ src/Terrain.hs view
@@ -0,0 +1,227 @@+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
@@ -0,0 +1,59 @@+module Tile where++import Control.Monad++import Data.Binary+import Data.List as L++import Item+import qualified Terrain++data Tile = Tile+              { tterrain :: Terrain.Terrain,+                titems   :: [Item] }+  deriving Show++instance Binary Tile where+  put (Tile t is) = put t >> put is+  get = liftM2 Tile get get++unknownTile :: Tile+unknownTile = Tile Terrain.unknown []++-- | blocks moves and vision+closed :: Tile -> Bool+closed = not . open++floor :: Tile -> Bool+floor = Terrain.isFloor . tterrain++canBeDoor :: Tile -> Bool+canBeDoor t =+  case Terrain.deDoor $ tterrain t of+    Just o | secret o -> True+    _ ->+      Terrain.isRock (tterrain t) ||+      Terrain.isUnknown (tterrain t)++secret :: Maybe Int -> Bool+secret (Just n) | n /= 0 = True+secret _ = False++isUnknown :: Tile -> Bool+isUnknown = Terrain.isUnknown . tterrain++toOpen :: Bool -> Maybe Int+toOpen True = Nothing+toOpen False = Just 0++-- | allows moves and vision+open :: Tile -> Bool+open = Terrain.isOpen . tterrain++-- | is lighted on its own+light :: Tile -> Bool+light = Terrain.isAlight . tterrain++-- | marks an exit from a room+isExit :: Tile -> Bool+isExit = Terrain.isExit . tterrain
+ src/Turn.hs view
@@ -0,0 +1,273 @@+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 qualified Data.Ord as Ord+import qualified Data.IntMap as IM+import qualified Data.Char as Char++import Action+import Actions+import Command+import qualified Config+import Display hiding (display)+import EffectAction+import Keybindings+import qualified Keys as K+import Level+import Movable+import MovableState+import Random+import State+import Strategy+import StrategyState++-- One turn proceeds through the following functions:+--+-- handle+-- handleMonsters, handleMonster+-- nextMove+-- handle (again)+--+-- OR:+--+-- handle+-- handlePlayer, playerCommand+-- handleMonsters, handleMonster+-- nextMove+-- handle (again)+--+-- What's happening where:+--+-- handle: determine who moves next,+--   dispatch to handleMonsters or handlePlayer+--+-- handlePlayer: remember, display, get and process commmand(s),+--   update smell map, update perception+--+-- handleMonsters: find monsters that can move+--+-- handleMonster: determine and process monster action, advance monster time+--+-- nextMove: advance global game time, HP regeneration, monster generation+--+-- This is rather convoluted, and the functions aren't named very aptly, so we+-- should clean this up later. TODO.++-- | Decide if the hero is ready for another move.+-- Dispatch to either 'handleMonsters' or 'handlePlayer'.+handle :: Action ()+handle =+  do+    debug "handle"+    state <- get+    pl <- gets splayer+    let ptime = mtime (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!++-- | 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.+handleMonsters :: Action ()+handleMonsters =+  do+    debug "handleMonsters"+    time <- gets stime+    ms   <- gets (lmonsters . slevel)+    pl   <- gets splayer+    if IM.null ms+      then nextMove+      else let order  = Ord.comparing (mtime . snd)+               (i, m) = L.minimumBy order (IM.assocs ms)+               actor = AMonster i+           in  if mtime 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 actor =+  do+    debug "handleMonster"+    state <- get+    per <- currentPerception+    -- Run the AI: choses an action from those given by the AI strategy.+    action <-+      liftIO $ rndToIO $+        frequency (head (runStrategy (strategy actor state per .| wait actor)))+    action+    handleMonsters++-- | After everything has been handled for the current game time, we can+-- advance the time. Here is the place to do whatever has to be done for+-- every time unit; currently, that's monster generation.+-- TODO: nextMove may not be a good name. It's part of the problem of the+-- current design that all of the top-level functions directly call each+-- other, rather than being called by a driver function.+nextMove :: Action ()+nextMove =+  do+    debug "nextMove"+    modify (updateTime (+1))+    regenerateLevelHP+    generateMonster+    handle++-- | Handle the move of the hero.+handlePlayer :: Action ()+handlePlayer =+  do+    debug "handlePlayer"+    remember  -- the hero perceives his (potentially new) surroundings+    -- determine perception before running player command, in case monsters+    -- have opened doors ...+    oldPlayerTime <- gets (mtime . 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)+    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)+            sTimeout = Config.get (sconfig state) "monsters" "smellTimeout"+        -- update smell+        when (isAHero pl) $  -- only humans leave strong scent+          modify (updateLevel (updateSMap (M.insert ploc (time + sTimeout))))+        -- determine player perception and continue with monster moves+        withPerception handleMonsters++-- | Determine and process the next player command.+playerCommand :: Action ()+playerCommand =+  do+    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+      ifRunning continueRun $ do+        k <- session nextCommand+        handleKey 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.+              --+              -- Normal commands: they take time, so after handling the command, state changes,+              -- time passes and monsters get to move.+              --+              -- Instant commands: they take no time, and do not change the state.+              --+              -- Meta commands: they take no time, but may change the state.+              --+              -- Ideally, they can all be handled via the same (event) interface. We maintain an+              -- event queue where we store what has to be handled next. The event queue is a sorted+              -- list where every event contains the timestamp when the event occurs. The current game+              -- time is equal to the head element of the event queue. Currently, we only have action+              -- events. An actor gets to move on an event. The actor is responsible for reinsterting+              -- itself in the event queue. Possible new events may include HP regeneration events,+              -- monster generation events, or actor death events.+              --+              -- If an action does not take any time, the actor just reinserts itself with the current+              -- time into the event queue. If the insert algorithm makes sure that later events with+              -- the same time get precedence, this will work just fine.+              --+              -- It's important that we decouple issues like HP regeneration from action events if we+              -- do it like that, because otherwise, HP regeneration may occur multiple times.+              --+              -- Given this scheme, we may get orphaned events: a HP regeneration event for a dead+              -- monster may be scheduled. Or a move event for a monster suddenly put to sleep. We+              -- therefore have to given handlers the option of accessing and cleaning up the event+              -- queue.++-- The remaining functions in this module are individual actions or helper+-- functions.++-- TODO: Should be defined in Command module.+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+            domain = M.keysSet macros+        in  if k `S.member` domain then [] else [k]+            ++ [ from | (from, to) <- M.assocs macros, to == k ]+  aliases <- session (return . coImage)+  let helpString = keyHelp aliases stdKeybindings+  messageOverlayConfirm "Basic keys:" helpString+  abort++heroSelection :: [(K.Key, Command)]+heroSelection =+  let heroSelect k = (K.Char (Char.intToDigit k),+                      Undescribed $+                      selectPlayer (AHero k) >> withPerception playerCommand)+  in  fmap heroSelect [0..9]++stdKeybindings :: Keybindings+stdKeybindings = Keybindings+  { kdir   = moveDirCommand,+    kudir  = runDirCommand,+    kother = M.fromList $+             heroSelection +++             [ -- interaction with the dungeon+               (K.Char 'o',  openCommand),+               (K.Char 'c',  closeCommand),+               (K.Char 's',  searchCommand),++               (K.Char '<',  ascendCommand),+               (K.Char '>',  descendCommand),++               (K.Char '*',  monsterCommand),+               (K.Char '/',  floorCommand),+               (K.Tab     ,  heroCommand),++               -- items+               (K.Char 'g',  pickupCommand),+               (K.Char 'd',  dropCommand),+               (K.Char 'i',  inventoryCommand),+               (K.Char 'q',  quaffCommand),+               (K.Char 'r',  readCommand),+               (K.Char 't',  throwCommand),+               (K.Char 'a',  aimCommand),++               -- wait+               -- (K.Char ' ',  waitCommand),  -- dangerous, space is -more- key+               (K.Char '.',  waitCommand),++               -- saving or ending the game+               (K.Char 'X',  saveCommand),+               (K.Char 'Q',  quitCommand),++               -- debug modes+               (K.Char 'R',  Undescribed $ modify toggleVision),+               (K.Char 'O',  Undescribed $ modify toggleOmniscient),+               (K.Char 'T',  Undescribed $ modify toggleTerrain),+               (K.Char 'I',  Undescribed $ gets (lmeta . slevel) >>= abortWith),++               -- information for the player+               (K.Char 'V',  versionCommand),+               (K.Char 'P',  historyCommand),+               (K.Char 'D',  dumpCommand),+               (K.Char '?',  helpCommand),+               (K.Return  ,  acceptCommand displayHelp),+               (K.Esc     ,  cancelCommand)+             ]+  }
+ src/Version.hs view
@@ -0,0 +1,11 @@+module Version where++import Data.Version++-- Cabal+import qualified Paths_Allure as Self (version)++import qualified Display++version :: String+version = showVersion Self.version ++ " (" ++ Display.displayId ++ " frontend)"
+ src/WorldLoc.hs view
@@ -0,0 +1,24 @@+module WorldLoc where++import Control.Monad+import Data.Binary+import Geometry++-- | Level ids are just integers.+newtype LevelId = LambdaCave Int+  deriving (Show, Eq, Ord)++instance Binary LevelId where+  put (LambdaCave n) = put n+  get = liftM LambdaCave get++-- | Name of a level.+levelName :: LevelId -> String+levelName (LambdaCave n) = "The Lambda Cave " ++ show n++-- | Depth of a level.+levelNumber :: LevelId -> Int+levelNumber (LambdaCave n) = n++-- | A world location is a level together with a location on that level.+type WorldLoc = (LevelId, Loc)
+ src/config.default view
@@ -0,0 +1,56 @@+; 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.markdown. In this way, you will not accidentally+; commit your private high scores (nor your save files) to the game+; git repository.++[dungeon]+; the hardcoded default for levels with no specified layout:+LambdaCave_1: rogueRoom+; access to stairs may be blocked, so only suitable for the last level:+LambdaCave_10: noiseRoom+LambdaCave_3: bigRoom+depth: 10++[engine]+fovMode: digital+;fovMode: permissive+;fovMode: shadow+fovRadius: 40++; 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: 50+extraHeroes: 0+firstDeathEnds: False++[macros]+; TODO: the following does not work yet:+; ; throw a dart at the closest monster+; t: asterisk Return t Return+; TODO: in gtk it could be implemented via unGetChan,+; unless we prefer an explicit command queue, with flushing, etc.+;+; Angband compatibility+v: t++[monsters]+smellTimeout: 1000++[ui]+historyMax: 500