packages feed

LambdaHack 0.1.20110918 → 0.2.0

raw patch · 133 files changed

+9730/−6907 lines, 133 filesdep +LambdaHackdep +arraydep −MissingHdep ~ConfigFiledep ~basedep ~binarynew-component:exe:DumbBot

Dependencies added: LambdaHack, array

Dependencies removed: MissingH

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

Files

CREDITS view
@@ -1,4 +1,4 @@-All kinds of contributions to LambdaHack are gratefully welcome!+All kinds of contributions to the LambdaHack engine are gratefully welcome! Some of the contributors are listed below, in chronological order.  Andres Loeh
− DESIGN.markdown 
@@ -1,200 +0,0 @@-Design notes-============--Here is a rationale for some design decisions and implementation details.-Not all of the sketched features are implemented and not everything-is implemented as described.---Level generation-------------------Each level 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.---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, 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.--Once we compute the reachable fields using FOV, it is possible-to compute what the hero can actually see. Fields adjacent to the hero-(also diagonally) can always be seen (except for walls).-Fields that have light and are reachable can also be seen.-We treat floor of rooms as having light, whereas corridors and rock are dark.--Walls reflect light. They can be seen only if an adjacent floor field-can also be seen. In particular, walls cannot be seen when passing-a corridor on the outside of a room, but can be seen from the inside of a room.---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.---Dungeon tiles----------------Abstract musings for now; not implemented.--The hero and the monsters (later, in short, 'monsters') can transform a tile,-which can be represented by a graph, with edges labeled by prerequisites-and cost of transformation. Monsters can also melee across a tile border,-and it's always permitted (e.g. fighting a ghost embedded in a wall)-and the kind of the tiles involved is irrelevant.--For tile design, I disregard sound and the monster's sense of hearing,-because sound is best conveyed to the player through sound effects,-not by painting tiles, and this requires lots of work.-Acoustics is quite complex, too. Right now, sound ignores tiles-and sound cues are given as text messages, e.g., when a monster attacks-or is hit or when distant (but not too distant?) monsters fight or when-a level is eerie silent, when the hero enters.--Monsters can interact directly and non-destructively with dungeon tiles-in the following ways: they can move trough, see through, shoot through-and smell (or inhale) across.--Three different kinds of things can pass through a tile:--  * objects: big, slow, pushy things (monsters passing through tiles-    and throwing objects from inventory across tiles)--  * projectiles and gases: monsters shooting small, fast and sharp things-    (arrows and bolts from the quiver) and monsters inhaling tiny, slow-    particles (smells, smoke, fog, poisonous gases)--  * light: monsters seeing clearly across a tile (light that just leaks-    through a cloth or produces a distorted image though a waterfall-    does not count)--For simplicity I assume that if big objects can move through,-small objects can as well (no Kevlar curtains nor automatic doors).-Also, I merged projectiles and gases, assuming that if small objects-can get through, so can tiny objects (no self-sealing rubber walls)-and the reverse (no vents in walls).--I can find no such simplifications for light. I only assume that the light-that carries the picture is in itself too weak to illuminate any tile-(so you can stand in a pitch dark corridor and observe a nearby sunny room).-Consequently, room lighting and monster field of view calculations-are very loosely coupled.--Below are tables with examples of different tile kinds.--The case of tiles that can be shot through and smelled through:--                   can see through    cannot see through--    can pass       floor, open door   curtain, waterfall--    cannot pass    fence, grate       grate with waterfall--The case of tiles that cannot be shot through and that block smell:--                   can see through    cannot see through--    can pass       none               none--    cannot pass    crystal, glass     rock, closed door--Note that acid pools and pits do not count as "cannot pass" tiles.-First, axes and rocks can be thrown across (or into) them.-Second, the hero and monsters can be pushed into them (and perish).-The player cannot steer the hero into the acid pool not by physical-impossibility, but by the self preservation instinct of the hero.-So, an acid pool is in the same category as empty floor and it's up to the-monster AI routines to check if the monster has wings (and a brain of any size)-before entering. Such tiles should probably be marked as "damage this large-unless flying". Similarly with water and swimming, lava pool and fire-resistance, poison cloud and poison resistance, etc. No action is forbidden-there, but each action has consequences.
+ DumbBot/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import qualified System.Random as R+import System.Environment+import Control.Monad++move :: R.StdGen -> Int -> IO ()+move g k = do+  let (c, ng) = R.randomR ('0', 'z') g+  putChar c+  when (k > 0) $ move ng (k - 1)++main :: IO ()+main = do+  args <- getArgs+  case args of+    [seed, count] -> do+      -- Start by dumping config (hack: ' ', see Std.hs) with the game seed.+      putChar ' '+      -- Note that the seed is separate from the game seed.+      move (R.mkStdGen (read seed)) (read count)+    _ -> error "Two integer arguments required: random seed and iteration count."
+ Game/LambdaHack/Action.hs view
@@ -0,0 +1,344 @@+-- TODO: Add an export list, with sections, after the file is rewritten+-- according to #17. Perhaps make some types abstract.+-- | Game action monad and basic building blocks+-- for player and monster actions.+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+module Game.LambdaHack.Action where++import Control.Monad+import Control.Monad.State hiding (State, state)+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Maybe+-- import System.IO (hPutStrLn, stderr) -- just for debugging++import Game.LambdaHack.Perception+import Game.LambdaHack.Display+import Game.LambdaHack.Msg+import Game.LambdaHack.State+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Content.ActorKind+import qualified Game.LambdaHack.Save as Save+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Random+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Binding++-- | The constant session information, not saved to the game save file.+data Session = Session+  { sfs   :: FrontendSession         -- ^ frontend session information+  , scops :: Kind.COps               -- ^ game content+  , skeyb :: Binding (Action ())     -- ^ binding of keys to commands+  }++-- | The type of the function inside any action.+-- (Separated from the @Action@ type to document each argument with haddock.)+type ActionFun r a =+   Session                           -- ^ session setup data+   -> (State -> Diary -> IO r)       -- ^ shutdown continuation+   -> Perception                     -- ^ cached perception+   -> (State -> Diary -> a -> IO r)  -- ^ continuation+   -> IO r                           -- ^ failure/reset continuation+   -> State                          -- ^ current state+   -> Diary                          -- ^ current diary+   -> IO r++-- | Actions of player-controlled characters and of any other actors.+newtype Action a = Action+  { runAction :: forall r . ActionFun r a+  }++instance Show (Action a) where+  show _ = "an action"++-- TODO: check if it's strict enough, if we don't keep old states for too long,+-- Perhaps make state type fields strict for that, too?+instance Monad Action where+  return = returnAction+  (>>=)  = bindAction++instance Functor Action where+  fmap f (Action g) = Action (\ s e p k a st ms ->+                               let k' st' ms' = k st' ms' . f+                               in g s e p k' a st ms)++-- | Invokes the action continuation on the provided argument.+returnAction :: a -> Action a+returnAction x = Action (\ _s _e _p k _a st m -> k st m x)++-- | Distributes the session and shutdown continuation,+-- threads the state and diary.+bindAction :: Action a -> (a -> Action b) -> Action b+bindAction m f = Action (\ s e p k a st ms ->+                          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 ())++-- | Run an action, with a given session, state and diary, in the @IO@ monad.+handlerToIO :: Session -> State -> Diary -> Action () -> IO ()+handlerToIO sess@Session{sfs, scops} state diary h =+  runAction h+    sess+    (\ ns ndiary -> Save.rmBkpSaveDiary ns ndiary+                 >> shutdown sfs)  -- get out of the game+    (perception scops state)  -- create and cache perception+    (\ _ _ x -> return x)    -- final continuation returns result+    (ioError $ userError "unhandled abort")+    state+    diary++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: Rnd a -> Action a+rndToAction r = do+  g <- gets srandom+  let (a, ng) = runState r g+  modify (\ state -> state {srandom = ng})+  return a++-- | Invoke a session command.+session :: (Session -> Action a) -> Action a+session f = Action (\ sess e p k a st ms ->+                     runAction (f sess) sess e p k a st ms)++-- | Invoke a session @IO@ command.+sessionIO :: (Session -> IO a) -> Action a+sessionIO f = Action (\ sess _e _p k _a st ms -> f sess >>= k st ms)++-- | Display the current level with modified current msg.+displayGeneric :: ColorMode -> (Msg -> Msg) -> Action Bool+displayGeneric dm f =+  Action (\ Session{sfs, scops} _e p k _a st ms ->+           displayLevel dm sfs scops p st (f (smsg ms)) Nothing+           >>= k st ms)++-- | Display the current level, with the current msg and color.+displayAll :: Action Bool+displayAll = displayGeneric ColorFull id++-- | Display an overlay on top of the current screen.+overlay :: String -> Action Bool+overlay txt =+  Action (\ Session{sfs, scops} _e p k _a st ms ->+           displayLevel ColorFull sfs scops p st (smsg ms) (Just txt)+           >>= k st ms)++-- | Get the current diary.+currentDiary :: Action Diary+currentDiary = Action (\ _s _e _p k _a st diary -> k st diary diary)++-- | Wipe out and set a new value for the current diary.+diaryReset :: Diary -> Action ()+diaryReset ndiary = Action (\ _s _e _p k _a st _diary -> k st ndiary ())++-- | Get the current msg.+currentMsg :: Action Msg+currentMsg = Action (\ _s _e _p k _a st ms -> k st ms (smsg ms))++-- | Wipe out and set a new value for the current msg.+msgReset :: Msg -> Action ()+msgReset nm = Action (\ _s _e _p k _a st ms -> k st ms{smsg = nm} ())++-- | Add to the current msg.+msgAdd :: Msg -> Action ()+msgAdd nm = Action (\ _s _e _p k _a st ms ->+                     k st ms{smsg = addMsg (smsg ms) nm} ())++-- | Clear the current msg.+msgClear :: Action ()+msgClear = Action (\ _s _e _p k _a st ms -> k st ms{smsg = ""} ())++-- | Get the content operations.+contentOps :: Action Kind.COps+contentOps = Action (\ Session{scops} _e _p k _a st ms -> k st ms scops)++-- | Get the content operations modified by a function (usually a selector).+contentf :: (Kind.COps -> a) -> Action a+contentf f = Action (\ Session{scops} _e _p k _a st ms -> k st ms (f scops))++-- | End the game, i.e., invoke the shutdown continuation.+end :: Action ()+end = Action (\ _s e _p _k _a s diary -> e s diary)++-- | 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)++-- | Set the current exception handler. First argument is the handler,+-- second is the computation the handler scopes over.+tryWith :: Action () -> Action () -> Action ()+tryWith exc h = Action (\ s e p k a st ms ->+                         let runA = runAction exc s e p k a st ms+                         in runAction h s e p k runA st ms)++-- | Take a handler and a computation. If the computation fails, the+-- handler is invoked and then the computation is retried.+tryRepeatedlyWith :: Action () -> Action () -> Action ()+tryRepeatedlyWith exc h = tryWith (exc >> tryRepeatedlyWith exc h) h++-- | 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 ())++-- | Debugging.+debug :: String -> Action ()+debug _x = return () -- liftIO $ hPutStrLn stderr _x++-- | Print the given msg, then abort.+abortWith :: Msg -> Action a+abortWith msg = do+  msgReset msg+  displayAll+  abort++-- | Abort, and print the given msg if the condition is true.+abortIfWith :: Bool -> Msg -> Action a+abortIfWith True msg = abortWith msg+abortIfWith False _  = abortWith ""++-- | Abort conditionally, with a fixed message.+neverMind :: Bool -> Action a+neverMind b = abortIfWith b "never mind"++-- | Wait for a player keypress.+nextCommand :: Session -> Action K.Key+nextCommand Session{sfs, skeyb} = do+  nc <- liftIO $ nextEvent sfs+  return $ fromMaybe nc $ M.lookup nc $ kmacro skeyb++-- | A yes-no confirmation.+getYesNo :: Session -> Action Bool+getYesNo sess@Session{sfs} = do+  e <- liftIO $ nextEvent sfs+  case e of+    K.Char 'y' -> return True+    K.Char 'n' -> return False+    K.Esc      -> return False+    _          -> getYesNo sess++-- | Waits for a SPACE or ESC. Passes along any other key, including RET,+-- to an argument function.+getOptionalConfirm :: (Bool -> Action a)+                    -> (K.Key -> Action a)+                    -> Session+                    -> Action a+getOptionalConfirm h k Session{sfs} = do+  e <- liftIO $ nextEvent sfs+  case e of+    K.Space    -> h True+    K.Esc      -> h False+    _          -> k e++-- | Ignore unexpected kestrokes until a SPACE or ESC is pressed.+getConfirm :: Session -> Action Bool+getConfirm Session{sfs} = liftIO $ getConfirmD sfs++-- | Print msg, await confirmation. Return value indicates+-- if the player tried to abort/escape.+msgMoreConfirm :: ColorMode -> Msg -> Action Bool+msgMoreConfirm dm msg = do+  msgAdd (msg ++ more)+  displayGeneric dm id+  session getConfirm++-- | Print msg, await confirmation, ignore confirmation.+msgMore :: Msg -> Action ()+msgMore msg = msgClear >> msgMoreConfirm ColorFull msg >> return ()++-- | Print a yes/no question and return the player's answer.+msgYesNo :: Msg -> Action Bool+msgYesNo msg = do+  msgReset (msg ++ yesno)+  displayGeneric ColorBW id  -- turn player's attention to the choice+  session getYesNo++-- | Clear message and overlay.+clearDisplay :: Action Bool+clearDisplay = do+  msgClear+  displayAll+  return False++-- | Print a msg and several overlays, one per page, and await confirmation.+-- The return value indicates if the player tried to abort/escape.+msgOverlaysConfirm :: Msg -> [String] -> Action Bool+msgOverlaysConfirm _msg [] = return True+msgOverlaysConfirm msg [x] = do+  msgReset msg+  b0 <- overlay (x ++ msgEnd)+  if b0+    then return True+    else clearDisplay+msgOverlaysConfirm msg (x:xs) = do+  msgReset msg+  b0 <- overlay (x ++ more)+  if b0+    then do+      b <- session getConfirm+      if b+        then msgOverlaysConfirm msg xs+        else clearDisplay+    else clearDisplay++-- | Update the cached perception for the given computation.+withPerception :: Action () -> Action ()+withPerception h = Action (\ sess@Session{scops} e _ k a st ms ->+                            runAction h sess e (perception scops st) k a st ms)++-- | Get the current perception.+currentPerception :: Action Perception+currentPerception = Action (\ _s _e p k _a st ms -> k st ms p)++-- | Update actor stats. Works for actors on other levels, too.+updateAnyActor :: ActorId -> (Actor -> Actor) -> Action ()+updateAnyActor actor f = modify (updateAnyActorBody actor f)++-- | Update player-controlled actor stats.+updatePlayerBody :: (Actor -> Actor) -> Action ()+updatePlayerBody f = do+  pl <- gets splayer+  updateAnyActor pl f++-- | Advance the move time for the given actor.+advanceTime :: ActorId -> Action ()+advanceTime actor = do+  Kind.Ops{okind} <- contentf Kind.coactor+  time <- gets stime+  let upd m = m { btime = time + aspeed (okind (bkind m)) }+  -- A hack to synchronize the whole party:+  pl <- gets splayer+  if actor == pl || isAHero actor+    then do+      modify (updateLevel (updateHeroes (IM.map upd)))+      unless (isAHero pl) $ updatePlayerBody upd+    else do+      s <- get+      -- If actor dead or not on current level, don't bother.+      when (memActor actor s) $ updateAnyActor actor upd++-- | Add a turn to the player time counter.+playerAdvanceTime :: Action ()+playerAdvanceTime = do+  pl <- gets splayer+  advanceTime pl++-- | Display command help.+displayHelp :: Action ()+displayHelp = do+  let disp Session{skeyb} =+        msgOverlaysConfirm "Basic keys. [press SPACE or ESC]" $ keyHelp skeyb+  session disp+  abort
+ Game/LambdaHack/Actions.hs view
@@ -0,0 +1,462 @@+-- | The game action stuff that is independent from ItemAction.hs+-- (both depend on EffectAction.hs).+-- TODO: Add an export list and document after it's rewritten according to #17.+module Game.LambdaHack.Actions where++import Control.Monad+import Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import qualified Data.IntSet as IS++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Action+import Game.LambdaHack.Point+import Game.LambdaHack.Vector+import Game.LambdaHack.Grammar+import qualified Game.LambdaHack.Dungeon as Dungeon+import qualified Game.LambdaHack.HighScore as H+import Game.LambdaHack.Item+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Perception+import Game.LambdaHack.State+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Save as Save+import qualified Game.LambdaHack.Effect as Effect+import Game.LambdaHack.EffectAction+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import qualified Game.LambdaHack.Feature as F+import Game.LambdaHack.DungeonState+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.TileKind as TileKind+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Random++displayHistory :: Action ()+displayHistory = do+  diary <- currentDiary+  msgOverlaysConfirm "History:" [unlines $ shistory diary]+  abort++dumpConfig :: Action ()+dumpConfig = do+  config <- gets sconfig+  let fn = "config.dump"+  liftIO $ Config.dump fn config+  abortWith $ "Current configuration dumped to file " ++ fn ++ "."++saveGame :: Action ()+saveGame = do+  b <- msgYesNo "Really save?"+  if b+    then do+      -- Save the game state+      cops <- contentf Kind.coitem+      state <- get+      diary <- currentDiary+      liftIO $ Save.saveGame state diary+      let total = calculateTotal cops state+          status = H.Camping+      go <- handleScores False status total+      when go $ msgMore "See you soon, stronger and braver!"+      end+    else abortWith "Game resumed."++quitGame :: Action ()+quitGame = do+  b <- msgYesNo "Really quit?"+  if b+    then end -- no highscore display for quitters+    else abortWith "Game resumed."++moveCursor :: Vector -> Int -> Action ()+moveCursor dir n = do+  lxsize <- gets (lxsize . slevel)+  lysize <- gets (lysize . slevel)+  let upd cursor =+        let shiftB loc =+              shiftBounded lxsize (1, 1, lxsize - 2, lysize - 2) loc dir+            cloc = iterate shiftB (clocation cursor) !! n+        in cursor { clocation = cloc }+  modify (updateCursor upd)+  doLook++-- TODO: Think about doing the mode dispatch elsewhere, especially if over+-- time more and more commands need to do the dispatch inside their code+-- (currently only a couple do).+move :: Vector -> Action ()+move dir = do+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if targeting /= TgtOff then moveCursor dir 1 else moveOrAttack True pl dir++ifRunning :: ((Vector, Int) -> Action a) -> Action a -> Action a+ifRunning t e = do+  ad <- gets (bdir . getPlayerBody)+  maybe e t ad++-- | Guess and report why the bump command failed.+guessBump :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Action ()+guessBump cotile F.Openable t | Tile.hasFeature cotile F.Closable t =+  abortWith "already open"+guessBump _ F.Openable _ =+  abortWith "not a door"+guessBump cotile F.Closable t | Tile.hasFeature cotile F.Openable t =+  abortWith "already closed"+guessBump _ F.Closable _ =+  abortWith "not a door"+guessBump cotile F.Ascendable t | Tile.hasFeature cotile F.Descendable t =+  abortWith "the way goes down, not up"+guessBump _ F.Ascendable _ =+  abortWith "no stairs up"+guessBump cotile F.Descendable t | Tile.hasFeature cotile F.Ascendable t =+  abortWith "the way goes up, not down"+guessBump _ F.Descendable _ =+  abortWith "no stairs down"+guessBump _ _ _ = neverMind True++-- | Player tries to trigger a tile using a feature.+bumpTile :: Point -> F.Feature -> Action ()+bumpTile dloc feat = do+  cotile <- contentf Kind.cotile+  lvl    <- gets slevel+  let t = lvl `at` dloc+  if Tile.hasFeature cotile feat t+    then triggerTile dloc+    else guessBump cotile feat t+  playerAdvanceTime++-- | Perform the action specified for the tile in case it's triggered.+triggerTile :: Point -> Action ()+triggerTile dloc = do+  Kind.Ops{okind, opick} <- contentf Kind.cotile+  lvl <- gets slevel+  let f (F.Cause effect) = do+        pl <- gets splayer+        (_b, _msg) <- effectToAction effect 0 pl pl 0+        return ()+      f (F.ChangeTo group) = do+        state <- get+        let hms = levelHeroList state ++ levelMonsterList state+        case lvl `atI` dloc of+          [] -> if unoccupied hms dloc+                then do+                  newTileId <- rndToAction $ opick group (const True)+                  let adj = (Kind.// [(dloc, newTileId)])+                  modify (updateLevel (updateLMap adj))+                else abortWith "blocked"  -- by monsters or heroes+          _ : _ -> abortWith "jammed"  -- by items+      f _ = return ()+  mapM_ f $ TileKind.tfeature $ okind $ lvl `at` dloc++-- | Ask for a direction and trigger a tile, if possible.+playerTriggerDir :: F.Feature -> Action ()+playerTriggerDir feat = do+  msgReset "direction?"+  displayAll+  e <- session nextCommand+  lxsize <- gets (lxsize . slevel)+  K.handleDir lxsize e (playerBumpDir feat) (neverMind True)++-- | Player tries to trigger a tile in a given direction.+playerBumpDir :: F.Feature -> Vector -> Action ()+playerBumpDir feat dir = do+  pl    <- gets splayer+  body  <- gets (getActor pl)+  let dloc = bloc body `shift` dir+  bumpTile dloc feat++-- | Player tries to trigger the tile he's standing on.+playerTriggerTile :: F.Feature -> Action ()+playerTriggerTile feat = do+  ploc <- gets (bloc . getPlayerBody)+  bumpTile ploc feat++-- | An actor opens a door. Player (hero or controlled monster) or enemy.+actorOpenDoor :: ActorId -> Vector -> Action ()+actorOpenDoor actor dir = do+  Kind.COps{ cotile+           , coitem+           , coactor=Kind.Ops{okind}+           } <- contentOps+  lvl  <- gets slevel+  pl   <- gets splayer+  body <- gets (getActor actor)+  bitems <- gets (getActorItem actor)+  let dloc = shift (bloc body) dir  -- the location we act upon+      t = lvl `at` dloc+      isPlayer = actor == pl+      isVerbose = isPlayer  -- don't report, unless it's player-controlled+      iq = aiq $ okind $ bkind body+      openPower = Tile.SecretStrength $+        if isPlayer+        then 1  -- player can't open hidden doors+        else case strongestSearch coitem bitems of+               Just i  -> iq + jpower i+               Nothing -> iq+  unless (openable cotile lvl openPower dloc) $ neverMind isVerbose+  if Tile.hasFeature cotile F.Closable t+    then abortIfWith isVerbose "already open"+    else if not (Tile.hasFeature cotile F.Closable t ||+                 Tile.hasFeature cotile F.Openable t ||+                 Tile.hasFeature cotile F.Hidden t)+         then neverMind isVerbose  -- not doors at all+         else triggerTile dloc+  advanceTime actor++-- | Change the displayed level in targeting mode to (at most)+-- k levels shallower. Enters targeting mode, if not already in one.+tgtAscend :: Int -> Action ()+tgtAscend k = do+  cotile    <- contentf Kind.cotile+  cursor    <- gets scursor+  targeting <- gets (ctargeting . scursor)+  slid      <- gets slid+  lvl       <- gets slevel+  st        <- get+  dungeon   <- gets sdungeon+  let loc = clocation cursor+      tile = lvl `at` loc+      rightStairs =+        k ==  1 && Tile.hasFeature cotile (F.Cause Effect.Ascend)  tile ||+        k == -1 && Tile.hasFeature cotile (F.Cause Effect.Descend) tile+  if rightStairs  -- stairs, in the right direction+    then case whereTo st k of+      Nothing ->  -- we are at the "end" of the dungeon+        abortWith "no more levels in this direction"+      Just (nln, nloc) ->+        assert (nln /= slid `blame` (nln, "stairs looped")) $ do+          modify (\ state -> state {slid = nln})+          -- do not freely reveal the other end of the stairs+          lvl2 <- gets slevel+          let upd cur =+                let clocation =+                      if Tile.hasFeature cotile F.Exit (lvl2 `rememberAt` nloc)+                      then nloc  -- already know as an exit, focus on it+                      else loc   -- unknow, do not reveal the position+                in cur { clocation, clocLn = nln }+          modify (updateCursor upd)+    else do  -- no stairs in the right direction+      let n = Dungeon.levelNumber slid+          depth = Dungeon.depth dungeon+          nln = Dungeon.levelDefault $ min depth $ max 1 $ n - k+      when (nln == slid) $ abortWith "no more levels in this direction"+      modify (\ state -> state {slid = nln})+      let upd cur = cur {clocLn = nln}+      modify (updateCursor upd)+  when (targeting == TgtOff) $ do+    let upd cur = cur {ctargeting = TgtExplicit}+    modify (updateCursor upd)+  doLook++-- | 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 any other hero on this level."+    ni : _ -> selectPlayer (AHero ni)+              >>= assert `trueM` (pl, ni, "hero duplicated")++-- | Search for hidden doors.+search :: Action ()+search = do+  Kind.COps{coitem, cotile} <- contentOps+  lvl    <- gets slevel+  le     <- gets (lsecret . slevel)+  lxsize <- gets (lxsize . slevel)+  ploc   <- gets (bloc . getPlayerBody)+  pitems <- gets getPlayerItem+  let delta = case strongestSearch coitem pitems of+                Just i  -> 1 + jpower i+                Nothing -> 1+      searchTile sle mv =+        let loc = shift ploc mv+            t = lvl `at` loc+            k = Tile.secretStrength (le IM.! loc) - delta+        in if Tile.hasFeature cotile F.Hidden t+           then if k > 0+                then IM.insert loc (Tile.SecretStrength k) sle+                else IM.delete loc sle+           else sle+      leNew = L.foldl' searchTile le (moves lxsize)+  modify (updateLevel (\ l -> l {lsecret = leNew}))+  lvlNew <- gets slevel+  let triggerHidden mv = do+        let dloc = shift ploc mv+            t = lvlNew `at` dloc+        when (Tile.hasFeature cotile F.Hidden t && IM.notMember dloc leNew) $+          triggerTile dloc+  mapM_ triggerHidden (moves lxsize)+  playerAdvanceTime++-- | This function performs a move (or attack) by any actor,+-- i.e., it can handle monsters, heroes and both.+moveOrAttack :: Bool       -- ^ allow attacks?+             -> ActorId    -- ^ who's moving?+             -> Vector     -- ^ in which direction?+             -> Action ()+moveOrAttack allowAttacks actor dir = do+  -- We start by looking at the target position.+  cops@Kind.COps{cotile = cotile@Kind.Ops{okind}} <- contentOps+  state  <- get+  pl     <- gets splayer+  lvl    <- gets slevel+  sm     <- gets (getActor actor)+  let sloc = bloc sm           -- source location+      tloc = sloc `shift` dir  -- target location+  tgt <- gets (locToActor tloc)+  case tgt of+    Just target+      | allowAttacks ->+          -- Attacking does not require full access, adjacency is enough.+          actorAttackActor actor target+      | accessible cops lvl sloc tloc -> do+          -- Switching positions requires full access.+          actorRunActor actor target+          when (actor == pl) $+            msgAdd $ lookAt cops False True state lvl tloc ""+      | otherwise -> abortWith ""+    Nothing+      | accessible cops lvl sloc tloc -> do+          -- perform the move+          updateAnyActor actor $ \ body -> body {bloc = tloc}+          when (actor == pl) $+            msgAdd $ lookAt cops False True state lvl tloc ""+          advanceTime actor+      | allowAttacks && actor == pl+        && Tile.canBeHidden cotile (okind $ lvl `rememberAt` tloc) -> do+          msgAdd "You search your surroundings."  -- TODO: proper msg+          search+      | otherwise -> actorOpenDoor actor dir  -- try to open a door, TODO: playerBumpDir instead: TriggerDir { verb = "open", object = "door", feature = Openable }++-- | Resolves the result of an actor moving into another. Usually this+-- involves melee attack, but with two heroes it just changes focus.+-- Actors on blocked locations can be attacked without any restrictions.+-- For instance, an actor embedded in a wall+-- can be attacked from an adjacent position.+-- This function is analogous to projectGroupItem, but for melee+-- and not using up the weapon.+actorAttackActor :: ActorId -> ActorId -> Action ()+actorAttackActor source@(AHero _) target@(AHero _) =+  -- Select adjacent hero by bumping into him. Takes no time.+  selectPlayer target+  >>= assert `trueM` (source, target, "player bumps into himself")+actorAttackActor source target = do+  Kind.COps{coactor, coitem=coitem@Kind.Ops{opick, okind}} <- contentOps+  state <- get+  sm    <- gets (getActor source)+  tm    <- gets (getActor target)+  per   <- currentPerception+  bitems <- gets (getActorItem source)+  let h2hGroup = if isAHero source then "unarmed" else "monstrous"+  h2hKind <- rndToAction $ opick h2hGroup (const True)+  let sloc = bloc sm+      -- The picked bodily "weapon".+      h2h = Item h2hKind 0 Nothing 1+      str = strongestSword coitem bitems+      stack  = fromMaybe h2h str+      single = stack { jcount = 1 }+      verb = iverbApply $ okind $ jkind single+      -- The msg describes the source part of the action.+      -- TODO: right now it also describes the victim and weapon;+      -- perhaps, when a weapon is equipped, just say "you hit" or "you miss"+      -- and then "nose dies" or "nose yells in pain".+      msg = actorVerbActorExtra coactor sm verb tm $+              if isJust str+              then " with " ++ objectItem coitem state single+              else ""+      visible = sloc `IS.member` totalVisible per+  when visible $ msgAdd msg+  -- Msgs inside itemEffectAction describe the target part.+  itemEffectAction 0 source target single+  advanceTime source++-- | Resolves the result of an actor running (not walking) into another.+-- This involves switching positions of the two actors.+actorRunActor :: ActorId -> ActorId -> Action ()+actorRunActor source target = do+  pl   <- gets splayer+  sloc <- gets (bloc . getActor source)  -- source location+  tloc <- gets (bloc . getActor target)  -- target location+  updateAnyActor source $ \ m -> m { bloc = tloc }+  updateAnyActor target $ \ m -> m { bloc = sloc }+  if source == pl+    then stopRunning  -- do not switch positions repeatedly+    else when (isAMonster source) $ focusIfAHero target+  advanceTime source++-- | Create a new monster in the level, at a random position.+rollMonster :: Kind.COps -> Perception -> State -> Rnd State+rollMonster Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} per state = do+  let lvl = slevel state+      hs = levelHeroList state+      ms = levelMonsterList state+      isLit = Tile.isLit cotile+  rc <- monsterGenChance (Dungeon.levelNumber $ slid state) (L.length ms)+  if not rc+    then return state+    else do+      let distantAtLeast d =+            \ l _ -> L.all (\ h -> chessDist (lxsize lvl) (bloc h) l > d) hs+      loc <-+        findLocTry 20 (lmap lvl)  -- 20 only, for unpredictability+          [ \ _ t -> not (isLit t)+          , distantAtLeast 30+          , distantAtLeast 20+          , \ l t -> not (isLit t) || distantAtLeast 20 l t+          , distantAtLeast 10+          , \ l _ -> not $ l `IS.member` totalVisible per+          , distantAtLeast 5+          , \ l t -> Tile.hasFeature cotile F.Walkable t+                     && l `notElem` L.map bloc (hs ++ ms)+          ]+      mk <- opick "monster" (const True)+      hp <- rollDice $ ahp $ okind mk+      return $ addMonster cotile mk hp loc state++-- | Generate a monster, possibly.+generateMonster :: Action ()+generateMonster = do+  cops    <- contentOps+  state   <- get+  per     <- currentPerception+  nstate  <- rndToAction $ rollMonster cops per state+  srandom <- gets srandom+  put $ nstate {srandom}++-- | Possibly regenerate HP for all actors on the current level.+regenerateLevelHP :: Action ()+regenerateLevelHP = do+  Kind.COps{ coitem+           , coactor=coactor@Kind.Ops{okind}+           } <- contentOps+  time <- gets stime+  let upd itemIM a m =+        let ak = okind $ bkind m+            bitems = fromMaybe [] $ IM.lookup a itemIM+            regen = max 10 $+                      aregen ak `div`+                      case strongestRegen coitem bitems of+                        Just i  -> 5 * jpower i+                        Nothing -> 1+        in if time `mod` regen /= 0+           then m+           else addHp coactor 1 m+  -- We really want hero selection to be a purely UI distinction,+  -- so all heroes need to regenerate, not just the player.+  -- Only the heroes on the current level regenerate (others are frozen+  -- in time together with their level). This prevents cheating+  -- via sending one hero to a safe level and waiting there.+  hi  <- gets (lheroItem . slevel)+  modify (updateLevel (updateHeroes   (IM.mapWithKey (upd hi))))+  mi  <- gets (lmonItem . slevel)+  modify (updateLevel (updateMonsters (IM.mapWithKey (upd mi))))
+ Game/LambdaHack/Actor.hs view
@@ -0,0 +1,166 @@+-- | Actors in the game: monsters and heroes. No operation in this module+-- involves the 'State' or 'Action' type.+module Game.LambdaHack.Actor+  ( -- * Actor identifiers and related operations+    ActorId(..), isAHero, isAMonster, invalidActorId+  , findHeroName, monsterGenChance+    -- * The@ Acto@r type+  , Actor(..), template, addHp, unoccupied, heroKindId+    -- * Type of na actor target+  , Target(..)+  ) where++import Control.Monad+import Data.Binary+import Data.Maybe+import Data.Ratio++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Misc+import Game.LambdaHack.Vector+import Game.LambdaHack.Point+import Game.LambdaHack.Content.ActorKind+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Random+import qualified Game.LambdaHack.Config as Config++-- | Actor properties that are changing throughout the game.+-- If they are dublets of properties from @ActorKind@,+-- they are usually modified temporarily, but tend to return+-- to the original value from @ActorKind@ over time. E.g., HP.+data Actor = Actor+  { bkind   :: !(Kind.Id ActorKind)    -- ^ the kind of the actor+  , bsymbol :: !(Maybe Char)           -- ^ individual map symbol+  , bname   :: !(Maybe String)         -- ^ individual name+  , bhp     :: !Int                    -- ^ current hit points+  , bdir    :: !(Maybe (Vector, Int))  -- ^ direction and distance of running+  , btarget :: Target                  -- ^ target for ranged attacks and AI+  , bloc    :: !Point                  -- ^ current location+  , bletter :: !Char                   -- ^ next inventory letter+  , btime   :: !Time                   -- ^ time of next action+  }+  deriving Show++instance Binary Actor where+  put (Actor ak an as ah ad at al ale ati) = do+    put ak+    put an+    put as+    put ah+    put ad+    put at+    put al+    put ale+    put ati+  get = do+    ak  <- get+    an  <- get+    as  <- get+    ah  <- get+    ad  <- get+    at  <- get+    al  <- get+    ale <- get+    ati <- get+    return (Actor ak an as ah ad at al ale ati)++-- ActorId operations++-- | A unique identifier of an actor in a dungeon.+data ActorId = AHero    !Int  -- ^ hero index (on the lheroes intmap)+             | AMonster !Int  -- ^ monster index (on the lmonsters intmap)+  deriving (Show, Eq, Ord)++instance Binary ActorId where+  put (AHero n)    = putWord8 0 >> put n+  put (AMonster n) = putWord8 1 >> put n+  get = do+    tag <- getWord8+    case tag of+      0 -> liftM AHero get+      1 -> liftM AMonster get+      _ -> fail "no parse (ActorId)"++-- | Checks whether an actor identifier represents a hero.+isAHero :: ActorId -> Bool+isAHero (AHero _) = True+isAHero (AMonster _) = False++-- | Checks whether an actor identifier represents a monster.+isAMonster :: ActorId -> Bool+isAMonster = not . isAHero++-- | An actor that is not on any level.+invalidActorId :: ActorId+invalidActorId = AMonster (-1)++-- | Find a hero name in the config file, or create a stock name.+findHeroName :: Config.CP -> Int -> String+findHeroName config n =+  let heroName = Config.getOption config "heroes" ("HeroName_" ++ show n)+  in fromMaybe ("hero number " ++ show n) heroName++-- | 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. How many and which monsters are generated+-- will also depend on the cave kind used to build the level.+monsterGenChance :: Int -> Int -> Rnd Bool+monsterGenChance d numMonsters =+  chance $ 1%(fromIntegral (250 + 200 * (numMonsters - d)) `max` 50)++-- Actor operations++-- TODO: Setting the time of new monsters to 0 makes them able to+-- move immediately after generation. This does not seem like+-- a bad idea, but it would certainly be "more correct" to set+-- the time to the creation time instead.+-- | A template for a new actor. The initial target is invalid+-- to force a reset ASAP.+template :: Kind.Id ActorKind -> Maybe Char -> Maybe String -> Int -> Point+         -> Actor+template mk mc ms hp loc =+  let invalidTarget = TEnemy invalidActorId loc+  in Actor mk mc ms hp Nothing invalidTarget loc 'a' 0++-- | Increment current hit points of an actor.+addHp :: Kind.Ops ActorKind -> Int -> Actor -> Actor+addHp Kind.Ops{okind} extra m =+  assert (extra >= 0 `blame` extra) $+  let maxHP = maxDice (ahp $ okind $ bkind m)+      currentHP = bhp m+  in if currentHP > maxHP+     then m+     else m {bhp = min maxHP (currentHP + extra)}++-- | Checks for the presence of actors in a location.+-- Does not check if the tile is walkable.+unoccupied :: [Actor] -> Point -> Bool+unoccupied actors loc =+  all (\ body -> bloc body /= loc) actors++-- | The unique kind of heroes.+heroKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind+heroKindId Kind.Ops{ouniqGroup} = ouniqGroup "hero"++-- Target++-- | The type of na actor target.+data Target =+    TEnemy ActorId Point  -- ^ target an actor with its last seen location+  | TLoc Point            -- ^ target a given location+  | TCursor               -- ^ target 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)"
+ Game/LambdaHack/ActorState.hs view
@@ -0,0 +1,222 @@+-- | Operations on the 'Actor' type that need the 'State' type,+-- but not the 'Action' type.+-- TODO: Add an export list and document after it's rewritten according to #17.+module Game.LambdaHack.ActorState where++import Control.Monad+import qualified Data.List as L+import qualified Data.IntSet as IS+import qualified Data.IntMap as IM+import Data.Maybe+import qualified Data.Char as Char++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Point+import Game.LambdaHack.Actor+import Game.LambdaHack.Level+import Game.LambdaHack.Dungeon+import Game.LambdaHack.State+import Game.LambdaHack.Item+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import qualified Game.LambdaHack.Feature as F++-- The operations with "Any", and those that use them, consider all the dungeon.+-- All the other actor and level operations only consider the current level.++-- | Finds an actor body on any level. Fails if not found.+findActorAnyLevel :: ActorId -> State -> (LevelId, Actor, [Item])+findActorAnyLevel actor state@State{slid, sdungeon} =+  assert (not (absentHero actor state) `blame` actor) $+  let chk (ln, lvl) =+        let (m, mi) = case actor of+              AHero n    -> (IM.lookup n (lheroes lvl),+                             IM.lookup n (lheroItem lvl))+              AMonster n -> (IM.lookup n (lmonsters lvl),+                             IM.lookup n (lmonItem lvl))+        in fmap (\ a -> (ln, a, fromMaybe [] mi)) m+  in case mapMaybe chk (currentFirst slid sdungeon) of+    []      -> assert `failure` actor+    res : _ -> res  -- checking if res is unique would break laziness++-- | Checks whether an actor is a hero, but not a member of the party.+absentHero :: ActorId -> State -> Bool+absentHero a State{sparty} =+  case a of+    AHero n    -> IS.notMember n sparty+    AMonster _ -> False++getPlayerBody :: State -> Actor+getPlayerBody s@State{splayer} =+  let (_, actor, _) = findActorAnyLevel splayer s+  in actor++getPlayerItem :: State -> [Item]+getPlayerItem s@State{splayer} =+  let (_, _, items) = findActorAnyLevel splayer s+  in items++-- | The list of actors and their levels for all heroes in the dungeon.+allHeroesAnyLevel :: State -> [(ActorId, LevelId)]+allHeroesAnyLevel State{slid, sdungeon} =+  let one (ln, Level{lheroes}) =+        L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs lheroes)+  in L.concatMap one (currentFirst slid sdungeon)++updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State+updateAnyActorBody actor f state =+  let (ln, _, _) = findActorAnyLevel actor state+  in case actor of+       AHero n    -> updateAnyLevel (updateHeroes   $ IM.adjust f n) ln state+       AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state++updateAnyActorItem :: ActorId -> ([Item] -> [Item]) -> State -> State+updateAnyActorItem actor f state =+  let (ln, _, _) = findActorAnyLevel actor state+      g Nothing   = Just $ f []+      g (Just is) = Just $ f is+  in case actor of+       AHero n    -> updateAnyLevel (updateHeroItem $ IM.alter g n) ln state+       AMonster n -> updateAnyLevel (updateMonItem  $ IM.alter g n) ln state++updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State+updateAnyLevel f ln s@State{slid, sdungeon}+  | ln == slid = updateLevel f s+  | otherwise = updateDungeon (const $ adjust f ln sdungeon) s++-- | Calculate the location of player's target.+targetToLoc :: IS.IntSet -> State -> Maybe Point+targetToLoc visible s@State{slid, scursor} =+  case btarget (getPlayerBody s) of+    TLoc loc -> Just loc+    TCursor  ->+      if slid == clocLn scursor+      then Just $ clocation scursor+      else Nothing  -- cursor invalid: set at a different level+    TEnemy a _ll -> do+      guard $ memActor a s           -- alive and on the current level?+      let loc = bloc (getActor a s)+      guard $ IS.member loc visible  -- visible?+      return loc++-- The operations below disregard levels other than the current.++-- | Checks if the actor is present on the current level.+memActor :: ActorId -> State -> Bool+memActor a state =+  case a of+    AHero n    -> IM.member n (lheroes (slevel state))+    AMonster n -> IM.member n (lmonsters (slevel state))++-- | Gets actor body from the current level. Error if not found.+getActor :: ActorId -> State -> Actor+getActor a state =+  case a of+    AHero n    -> lheroes   (slevel state) IM.! n+    AMonster n -> lmonsters (slevel state) IM.! n++-- | Gets actor's items from the current level. Empty list, if not found.+getActorItem :: ActorId -> State -> [Item]+getActorItem a state =+  fromMaybe [] $+  case a of+    AHero n    -> IM.lookup n (lheroItem (slevel state))+    AMonster n -> IM.lookup n (lmonItem  (slevel state))++-- | Removes the actor, if present, from the current level.+deleteActor :: ActorId -> State -> State+deleteActor a =+  case a of+    AHero n ->+      updateLevel (updateHeroes (IM.delete n) . updateHeroItem (IM.delete n))+    AMonster n ->+      updateLevel (updateMonsters (IM.delete n) . updateMonItem (IM.delete n))++-- | Add actor to the current level.+insertActor :: ActorId -> Actor -> State -> State+insertActor a m =+  case a of+    AHero n    -> updateLevel (updateHeroes   (IM.insert n m))+    AMonster n -> updateLevel (updateMonsters (IM.insert n m))++-- | Removes a player from the current level and party list.+deletePlayer :: State -> State+deletePlayer s@State{splayer, sparty} =+  let s2 = deleteActor splayer s+  in case splayer of+    AHero n    -> s2{sparty = IS.delete n sparty}+    AMonster _ -> s2++levelHeroList, levelMonsterList :: State -> [Actor]+levelHeroList    state = IM.elems $ lheroes   $ slevel state+levelMonsterList state = IM.elems $ lmonsters $ slevel state++-- | Finds an actor at a location on the current level. Perception irrelevant.+locToActor :: Point -> State -> Maybe ActorId+locToActor loc state =+  let l = locToActors loc state+  in assert (L.length l <= 1 `blame` l) $+     listToMaybe l++locToActors :: Point -> State -> [ActorId]+locToActors loc state =+  getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero)+ where+  getIndex (projection, injection) =+    let l  = IM.assocs $ projection $ slevel state+        im = L.filter (\ (_i, m) -> bloc m == loc) l+    in fmap (injection . fst) im++nearbyFreeLoc :: Kind.Ops TileKind -> Point -> State -> Point+nearbyFreeLoc cotile start state =+  let lvl@Level{lxsize, lysize} = slevel state+      hs = levelHeroList state+      ms = levelMonsterList state+      locs = start : L.nub (concatMap (vicinity lxsize lysize) locs)+      good loc = Tile.hasFeature cotile F.Walkable (lvl `at` loc)+                 && loc `notElem` L.map bloc (hs ++ ms)+  in fromMaybe (assert `failure` "too crowded map") $ L.find good locs++-- Adding heroes++-- | Create a new hero on the current level, close to the given location.+addHero :: Kind.COps -> Point -> State -> State+addHero Kind.COps{coactor, cotile} ploc state =+  let config = sconfig state+      bHP = Config.get config "heroes" "baseHP"+      loc = nearbyFreeLoc cotile ploc state+      n = fst (scounter state)+      symbol = if n < 1 || n > 9 then Nothing else Just $ Char.intToDigit n+      name = findHeroName config n+      startHP = bHP `div` min 10 (n + 1)+      m = template (heroKindId coactor) symbol (Just name) startHP loc+      state' = state { scounter = (n + 1, snd (scounter state))+                     , sparty = IS.insert n (sparty state) }+  in updateLevel (updateHeroes (IM.insert n m)) state'++-- | Create a set of initial heroes on the current level, at location ploc.+initialHeroes :: Kind.COps -> Point -> State -> State+initialHeroes cops ploc state =+  let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes"+  in iterate (addHero cops ploc) state !! k++-- Adding monsters++-- | Create a new monster in the level, at a given position+-- and with a given actor kind and HP.+addMonster :: Kind.Ops TileKind -> Kind.Id ActorKind -> Int -> Point -> State+           -> State+addMonster cotile mk hp ploc state@State{scounter = (heroC, monsterC)} = do+  let loc = nearbyFreeLoc cotile ploc state+      m = template mk Nothing Nothing hp loc+      state' = state { scounter = (heroC, monsterC + 1) }+  updateLevel (updateMonsters (IM.insert monsterC m)) state'++-- | Calculate loot's worth for heroes on the current level.+calculateTotal :: Kind.Ops ItemKind -> State -> Int+calculateTotal coitem s =+  L.sum $ L.map (itemPrice coitem) $ L.concat $ IM.elems $ lheroItem $ slevel s
+ Game/LambdaHack/Area.hs view
@@ -0,0 +1,62 @@+-- | Rectangular areas of levels and their basic operations.+module Game.LambdaHack.Area+  ( Area, vicinityXY, vicinityCardinalXY, insideXY+  , normalizeArea, grid, validArea, trivialArea, expand+  ) where++import Game.LambdaHack.PointXY+import Game.LambdaHack.VectorXY++-- | The type of areas. The bottom left and the top right points.+type Area = (X, Y, X, Y)++-- | All (8 at most) closest neighbours of a point within an area.+vicinityXY :: Area       -- ^ limit the search to this area+           -> PointXY    -- ^ location to find neighbours of+           -> [PointXY]+vicinityXY area xy =+  [ res | dxy <- movesXY, let res = shiftXY xy dxy, insideXY res area ]++-- | All (4 at most) cardinal direction neighbours of a point within an area.+vicinityCardinalXY :: Area       -- ^ limit the search to this area+                   -> PointXY    -- ^ location to find neighbours of+                   -> [PointXY]+vicinityCardinalXY area xy =+  [ res+  | dxy <- movesCardinalXY, let res = shiftXY xy dxy, insideXY res area ]++-- | Checks that a point belongs to an area.+insideXY :: PointXY -> Area -> Bool+insideXY (PointXY (x, y)) (x0, y0, x1, y1) =+  x1 >= x && x >= x0 && y1 >= y && y >= y0++-- | Sort the corners of an area so that the bottom left is the first point.+normalizeArea :: Area -> Area+normalizeArea (x0, y0, x1, y1) = (min x0 x1, min y0 y1, max x0 x1, max y0 y1)++-- | Divide uniformly a larger area into the given number of smaller areas.+grid :: (X, Y) -> Area -> [(PointXY, Area)]+grid (nx, ny) (x0, y0, x1, y1) =+  let xd = x1 - x0+      yd = y1 - y0+      -- Make sure that in caves not filled with rock, there is a passage+      -- across the cave, even if a single room blocks most of the cave.+      xborder = if nx == 1 then 3 else 2+      yborder = if ny == 1 then 3 else 2+  in [ (PointXY (x, y), (x0 + (xd * x `div` nx) + xborder,+                         y0 + (yd * y `div` ny) + yborder,+                         x0 + (xd * (x + 1) `div` nx) - xborder,+                         y0 + (yd * (y + 1) `div` ny) - yborder))+     | x <- [0..nx-1], y <- [0..ny-1] ]++-- | Checks if it's an area with at least one field.+validArea :: Area -> Bool+validArea (x0, y0, x1, y1) = x0 <= x1 && y0 <= y1++-- | Checks if it's an area with exactly one field.+trivialArea :: Area -> Bool+trivialArea (x0, y0, x1, y1) = x0 == x1 && y0 == y1++-- | Enlarge (or shrink) the given area on all fours sides by the amount.+expand :: Area -> Int -> Area+expand (x0, y0, x1, y1) k = (x0 - k, y0 - k, x1 + k, y1 + k)
+ Game/LambdaHack/AreaRnd.hs view
@@ -0,0 +1,145 @@+-- | Operations on the 'Area' type that involve random numbers.+module Game.LambdaHack.AreaRnd+  ( -- * Picking points inside areas+    xyInArea, mkRoom, mkVoidRoom+    -- * Choosing connections+  , connectGrid, randomConnection+    -- * Plotting corridors+  , Corridor, connectPlaces+  ) where++import qualified Data.Set as S++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.PointXY+import Game.LambdaHack.Area+import Game.LambdaHack.Random++-- Picking random points inside areas++-- | Pick a random point within an area.+xyInArea :: Area -> Rnd PointXY+xyInArea (x0, y0, x1, y1) = do+  rx <- randomR (x0, x1)+  ry <- randomR (y0, y1)+  return $ PointXY (rx, ry)++-- | Create a random room according to given parameters.+mkRoom :: (X, Y)    -- ^ minimum size+       -> Area      -- ^ the containing area, not the room itself+       -> Rnd Area+mkRoom (xm, ym) (x0, y0, x1, y1) = do+  let area0 = (x0, y0, x1 - xm + 1, y1 - ym + 1)+  assert (validArea area0 `blame` area0) $ do+    PointXY (rx0, ry0) <- xyInArea area0+    let area1 = (rx0 + xm - 1, ry0 + ym - 1, x1, y1)+    assert (validArea area1 `blame` area1) $ do+      PointXY (rx1, ry1) <- xyInArea area1+      return (rx0, ry0, rx1, ry1)++-- | Create a void room, i.e., a single point area.+mkVoidRoom :: Area     -- ^ the area in which to pick the point+           -> Rnd Area+mkVoidRoom area = assert (validArea area `blame` area) $ do+  PointXY (ry, rx) <- xyInArea area+  return (ry, rx, ry, rx)++-- Choosing connections between areas in a grid++-- | Pick a subset of connections between adjacent areas within a grid until+-- there is only one connected component in the graph of all areas.+connectGrid :: (X, Y) -> Rnd [(PointXY, PointXY)]+connectGrid (nx, ny) = do+  let unconnected = S.fromList [ PointXY (x, y)+                               | x <- [0..nx-1], y <- [0..ny-1] ]+  -- Candidates are neighbours that are still unconnected. We start with+  -- a random choice.+  rx <- randomR (0, nx-1)+  ry <- randomR (0, ny-1)+  let candidates = S.fromList [ PointXY (rx, ry) ]+  connectGrid' (nx, ny) unconnected candidates []++connectGrid' :: (X, Y) -> S.Set PointXY -> S.Set PointXY+             -> [(PointXY, PointXY)]+             -> Rnd [(PointXY, PointXY)]+connectGrid' (nx, ny) unconnected candidates acc+  | S.null candidates = return $ map sortPointXY acc+  | otherwise = do+      c <- oneOf (S.toList candidates)+      -- potential new candidates:+      let ns = S.fromList $ vicinityCardinalXY (0, 0, nx-1, ny-1) c+          nu = S.delete c unconnected  -- new unconnected+          -- (new candidates, potential connections):+          (nc, ds) = S.partition (`S.member` nu) ns+      new <- if S.null ds+             then return id+             else do+               d <- oneOf (S.toList ds)+               return ((c, d) :)+      connectGrid' (nx, ny) nu (S.delete c (candidates `S.union` nc)) (new acc)++-- | Pick a single random connection between adjacent areas within a grid.+randomConnection :: (X, Y) -> Rnd (PointXY, PointXY)+randomConnection (nx, ny) =+  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do+  rb <- oneOf [False, True]+  if rb || ny <= 1+    then do+      rx  <- randomR (0, nx-2)+      ry  <- randomR (0, ny-1)+      return (PointXY (rx, ry), PointXY (rx+1, ry))+    else do+      rx  <- randomR (0, nx-1)+      ry  <- randomR (0, ny-2)+      return (PointXY (rx, ry), PointXY (rx, ry+1))++-- Plotting individual corridors between two areas++-- | The choice of horizontal and vertical orientation.+data HV = Horiz | Vert++-- | The coordinates of consecutive fields of a corridor.+type Corridor = [PointXY]++-- | Create a corridor, either horizontal or vertical, with+-- a possible intermediate part that is in the opposite direction.+mkCorridor :: HV            -- ^ orientation of the starting section+           -> PointXY       -- ^ starting point+           -> PointXY       -- ^ ending point+           -> Area          -- ^ the area containing the intermediate point+           -> Rnd Corridor  -- ^ straight sections of the corridor+mkCorridor hv (PointXY (x0, y0)) (PointXY (x1, y1)) b = do+  PointXY (rx, ry) <- xyInArea b+  case hv of+    Horiz -> return $ map PointXY [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]+    Vert  -> return $ map PointXY [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]++-- TODO: assert that sx1 <= tx0, etc.+-- | Try to connect two places with a corridor.+-- Choose entrances at least 4 tiles distant from the edges, if possible.+connectPlaces :: Area -> Area -> Rnd Corridor+connectPlaces sa@(_, _, sx1, sy1) ta@(tx0, ty0, _, _) = do+  let trim (x0, y0, x1, y1) =+        let trim4 (v0, v1) = if v1 - v0 < 8 then (v0, v1) else (v0 + 4, v1 - 4)+            (nx0, nx1) = trim4 (x0, x1)+            (ny0, ny1) = trim4 (y0, y1)+        in (nx0, ny0, nx1, ny1)+  PointXY (sx, sy) <- xyInArea $ trim sa+  PointXY (tx, ty) <- xyInArea $ trim ta+  let xarea = (sx1+2, min sy ty, tx0-2, max sy ty)+      yarea = (sx, sy1+2, tx, ty0-2)+      xyarea = (sx1+2, sy1+2, tx0-2, ty0-2)+  (hv, area) <- if validArea xyarea+                then fmap (\ hv -> (hv, xyarea)) (oneOf [Horiz, Vert])+                else if validArea xarea+                     then return (Horiz, xarea)+                     else return (Vert, normalizeArea yarea)  -- vertical bias+  let (p0, p1) = case hv of+        Horiz -> (PointXY (if trivialArea sa then sx else sx1 + 1, sy),+                  PointXY (if trivialArea ta then tx else tx0 - 1, ty))+        Vert  -> (PointXY (sx, if trivialArea sa then sy else sy1 + 1),+                  PointXY (tx, if trivialArea ta then ty else ty0 - 1))+  -- The condition imposed on mkCorridor are tricky: there might not always+  -- exist a good intermediate point if the places are allowed to be close+  -- together and then we let the intermediate part degenerate.+  mkCorridor hv p0 p1 area
+ Game/LambdaHack/Binding.hs view
@@ -0,0 +1,94 @@+-- | Generic binding of keys to commands, procesing macros,+-- printing command help. No operation in this module+-- involves the 'State' or 'Action' type.+module Game.LambdaHack.Binding+  ( Binding(..), macroKey, keyHelp,+  ) where++import qualified Data.Map as M+import qualified Data.List as L+import qualified Data.Set as S++import Game.LambdaHack.Utils.Assert+import qualified Game.LambdaHack.Key as K++-- | Bindings and other information about player commands.+data Binding a = Binding+  { kcmd   :: M.Map K.Key (String, a)  -- ^ binding keys to commands+  , kmacro :: M.Map K.Key K.Key        -- ^ macro map+  , kmajor :: [K.Key]  -- ^ major, most often used, commands+  , ktimed :: [K.Key]  -- ^ commands that take time, except movement+  }++-- | Produce the macro map from a macro association list+-- taken from the config file. Macros cannot depend on each other.+-- The map is fully evaluated to catch errors in macro definitions early.+macroKey :: [(String, String)] -> M.Map K.Key K.Key+macroKey section =+  let trans k = case K.keyTranslate k of+                  K.Unknown s -> assert `failure` ("unknown macro key " ++ s)+                  kt -> kt+      trMacro (from, to) = let !fromTr = trans from+                               !toTr  = trans to+                           in if fromTr == toTr+                              then assert `failure` ("degenerate alias", toTr)+                              else (fromTr, toTr)+  in M.fromList $ L.map trMacro section++coImage :: M.Map K.Key K.Key -> K.Key -> [K.Key]+coImage kmacro k =+  let domain = M.keysSet kmacro+  in if k `S.member` domain+     then []+     else k : [ from | (from, to) <- M.assocs kmacro, to == k ]++-- | Produce a set of help screens from the key bindings.+keyHelp :: Binding a -> [String]+keyHelp Binding{kcmd, kmacro, kmajor, ktimed} =+  let+    movBlurb =+      [ "Move throughout the level with numerical keypad or"+      , "the Vi text editor keys (also known as \"Rogue-like keys\"):"+      , ""+      , "               7 8 9          y k u"+      , "                \\|/            \\|/"+      , "               4-5-6          h-.-l"+      , "                /|\\            /|\\"+      , "               1 2 3          b j n"+      , ""+      , "Run ahead until anything disturbs you, with SHIFT and a key."+      , "Press keypad '5' or '.' to skip a turn."+      , "In targeting mode the same keys move the targeting cursor."+      , ""+      , "Search, open and attack, by bumping into walls, doors and monsters."+      , ""+      , "Press SPACE to see the next page, with the list of major commands."+      , ""+      ]+    majorBlurb =+      [ ""+      , "Commands marked with * take time and are blocked on remote levels."+      , "Press SPACE to see the next page, with the list of minor commands."+      ]+    minorBlurb =+      [ ""+      , "For more playing instructions see file PLAYING.md."+      , "Press SPACE to clear the messages and go back to the game."+      ]+    fmt k h = replicate 16 ' ' ++ k ++ replicate ((15 - length k) `max` 1) ' '+                               ++ h ++ replicate ((40 - length h) `max` 1) ' '+    fmts s  = replicate 1  ' ' ++ s ++ replicate ((70 - length s) `max` 1) ' '+    blank   = fmt "" ""+    mov     = map fmts movBlurb+    major   = map fmts majorBlurb+    minor   = map fmts minorBlurb+    keyCaption = fmt "keys" "command"+    disp k  = L.concatMap show $ coImage kmacro k+    ti k    = if k `elem` ktimed then "*" else ""+    keys l  = [ fmt (disp k) (h ++ ti k) | (k, (h, _)) <- l, h /= "" ]+    (kcMajor, kcMinor) = L.partition ((`elem` kmajor) . fst) (M.toAscList kcmd)+  in+    L.map unlines [ [blank] ++ mov+                  , [blank] ++ [keyCaption] ++ keys kcMajor ++ major+                  , [blank] ++ [keyCaption] ++ keys kcMinor ++ minor+                  ]
+ Game/LambdaHack/BindingAction.hs view
@@ -0,0 +1,94 @@+-- | Binding of keys to commands implemented with the 'Action' monad.+module Game.LambdaHack.BindingAction+  ( stdBinding+  ) where++import Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Char as Char++import Game.LambdaHack.Action+import Game.LambdaHack.State+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.Level+import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Actions+import Game.LambdaHack.Running+import Game.LambdaHack.EffectAction+import Game.LambdaHack.Binding+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Actor+import Game.LambdaHack.Command++configCmd :: Config.CP -> [(K.Key, Cmd)]+configCmd config =+  let section = Config.getItems config "commands"+      mkKey s =+        case K.keyTranslate s of+          K.Unknown _ -> assert `failure` ("unknown command key " ++ s)+          key -> key+      mkCmd s = read s :: Cmd+      mkCommand (key, def) = (mkKey key, mkCmd def)+  in L.map mkCommand section++semanticsCmd :: [(K.Key, Cmd)]+             -> (Cmd -> Action ())+             -> (Cmd -> String)+             -> [(K.Key, (String, Action ()))]+semanticsCmd cmdList cmdS cmdD =+  let mkDescribed cmd =+        let semantics = if timedCmd cmd+                        then checkCursor $ cmdS cmd+                        else cmdS cmd+        in (cmdD cmd, semantics)+      mkCommand (key, def) = (key, mkDescribed def)+  in L.map mkCommand cmdList++-- | If in targeting mode, check if the current level is the same+-- as player level and refuse performing the action otherwise.+checkCursor :: Action () -> Action ()+checkCursor h = do+  cursor <- gets scursor+  slid <- gets slid+  if creturnLn cursor == slid+    then h+    else abortWith "this command does not work on remote levels"++heroSelection :: [(K.Key, (String, Action ()))]+heroSelection =+  let heroSelect k = (K.Char (Char.intToDigit k),+                      ("", void $ selectPlayer $ AHero k))+  in fmap heroSelect [0..9]++-- | Binding of keys to movement and other standard commands,+-- as well as commands defined in the config file.+stdBinding :: Config.CP            -- ^ game config+           -> (Cmd -> Action ())   -- ^ semantics of abstract commands+           -> (Cmd -> String)      -- ^ description of abstract commands+           -> Binding (Action ())  -- ^ concrete binding+stdBinding config cmdS cmdD =+  let section = Config.getItems config "macros"+      !kmacro = macroKey section+      cmdList = configCmd config+      semList = semanticsCmd cmdList cmdS cmdD+      moveWidth f = do+        lxsize <- gets (lxsize . slevel)+        move $ f lxsize+      runWidth f = do+        lxsize <- gets (lxsize . slevel)+        run (f lxsize, 0)+  in Binding+  { kcmd   = M.fromList $+             K.moveBinding moveWidth runWidth +++             heroSelection +++             semList +++             [ -- debug commands, TODO:access them from a common menu or prefix+               (K.Char 'R', ("", modify cycleMarkVision)),+               (K.Char 'O', ("", modify toggleOmniscient)),+               (K.Char 'I', ("", gets (lmeta . slevel) >>= abortWith))+             ]+  , kmacro+  , kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList+  , ktimed = L.map fst $ L.filter (timedCmd . snd) cmdList+  }
+ Game/LambdaHack/Cave.hs view
@@ -0,0 +1,200 @@+-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.+module Game.LambdaHack.Cave+  ( TileMapXY, SecretMapXY, ItemMapXY, Cave(..), buildCave+  ) where++import Control.Monad+import qualified Data.Map as M+import qualified Data.List as L++import Game.LambdaHack.PointXY+import Game.LambdaHack.Area+import Game.LambdaHack.AreaRnd+import Game.LambdaHack.Item+import Game.LambdaHack.Random+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Feature as F+import Game.LambdaHack.Place hiding (TileMapXY)+import qualified Game.LambdaHack.Place as Place+import Game.LambdaHack.Misc++-- | The map of tile kinds in a cave.+-- The map is sparse. The default tile that eventually fills the empty spaces+-- is specified in the cave kind specification with @cdefTile@.+type TileMapXY = Place.TileMapXY++-- | The map of starting secrecy strength of tiles in a cave.+-- The map is sparse. Unspecified tiles have secrecy strength of 0.+type SecretMapXY = M.Map PointXY Tile.SecretStrength++-- | The map of starting items in tiles of a cave. The map is sparse.+-- Unspecified tiles have no starting items.+type ItemMapXY = M.Map PointXY Item++-- | The type of caves (not yet inhabited dungeon levels).+data Cave = Cave+  { dkind     :: !(Kind.Id CaveKind)  -- ^ the kind of the cave+  , dmap      :: TileMapXY            -- ^ tile kinds in the cave+  , dsecret   :: SecretMapXY          -- ^ secrecy strength of cave tiles+  , ditem     :: ItemMapXY            -- ^ starting items in the cave+  , dmeta     :: String               -- ^ debug information about the cave+  , dplaces   :: [Place]              -- ^ places generated in the cave+  }+  deriving Show++{-+Rogue cave is generated by an algorithm inspired by the original Rogue,+as follows:++  * The available area is divided into a grid, e.g, 3 by 3,+    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+    and with a random size, but larger than The minimum size,+    e.g, 2 by 2 floor tiles.++  * 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.+-}+-- TODO: fix identifier naming and split, after the code grows some more+-- | Cave generation by an algorithm inspired by the original Rogue,+buildCave :: Kind.COps         -- ^ content definitions+          -> Int               -- ^ depth of the level to generate+          -> Int               -- ^ maximum depth of the dungeon+          -> Kind.Id CaveKind  -- ^ cave kind to use for generation+          -> Rnd Cave+buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{okind=tokind, opick}+                        , cocave=Kind.Ops{okind} }+          lvl depth ci = do+  let CaveKind{..} = okind ci+  lgrid@(gx, gy) <- rollDiceXY cgrid+  lminplace <- rollDiceXY cminPlaceSize+  let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1)+  mandatory1 <- replicateM (cnonVoidMin `div` 2) $+                  xyInArea (0, 0, gx `div` 3, gy - 1)+  mandatory2 <- replicateM (cnonVoidMin `divUp` 2) $+                  xyInArea (gx - 1 - (gx `div` 3), 0, gx - 1, gy - 1)+  places0 <- mapM (\ (i, r) -> do+                     rv <- chance cvoidChance+                     r' <- if rv && i `notElem` (mandatory1 ++ mandatory2)+                           then mkVoidRoom r+                           else mkRoom lminplace r+                     return (i, r')) gs+  connects <- connectGrid lgrid+  addedConnects <-+    if gx * gy > 1+    then let caux = round $ cauxConnects * fromIntegral (gx * gy)+         in replicateM caux (randomConnection lgrid)+    else return []+  let allConnects = L.union connects addedConnects  -- no duplicates+      places = M.fromList places0+  cs <- mapM (\ (p0, p1) -> do+                 let r0 = places M.! p0+                     r1 = places M.! p1+                 connectPlaces r0 r1) allConnects+  wallId <- opick "fillerWall" (const True)+  let fenceBounds = (1, 1, cxsize - 2, cysize - 2)+      fence = buildFence wallId fenceBounds+  pickedCorTile <- opick ccorTile (const True)+  let addPl (m, pls) (_, (x0, _, x1, _)) | x0 == x1 = return (m, pls)+      addPl (m, pls) (_, r) = do+        (tmap, place) <-+          buildPlace cops wallId pickedCorTile cdarkChance lvl depth r+        return (M.union tmap m, place : pls)+  (lplaces, dplaces) <- foldM addPl (fence, []) places0+  let lcorridors = M.unions (L.map (digCorridors pickedCorTile) cs)+  hiddenMap <- mapToHidden cotile+  let lm = M.unionWith (mergeCorridor cotile hiddenMap) lcorridors lplaces+  -- Convert openings into doors, possibly.+  (dmap, secretMap) <-+    let f (l, le) (p, t) =+          if Tile.hasFeature cotile F.Hidden t+          then 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 hidden+            rd <- chance cdoorChance+            if not rd+              then return (M.insert p pickedCorTile l, le)+              else do+                doorClosedId <- trigger cotile t+                doorOpenId   <- trigger cotile doorClosedId+                ro <- chance copenChance+                if ro+                  then return (M.insert p doorOpenId l, le)+                  else do+                    rs <- chance chiddenChance+                    if not rs+                      then return (M.insert p doorClosedId l, le)+                      else do+                        secret <- rollSecret (tokind t)+                        return (l, M.insert p secret le)+          else return (l, le)+    in foldM f (lm, M.empty) (M.toList lm)+  let cave = Cave+        { dkind = ci+        , dsecret = secretMap+        , ditem = M.empty+        , dmap+        , dmeta = show allConnects+        , dplaces+        }+  return cave++rollSecret :: TileKind -> Rnd Tile.SecretStrength+rollSecret t = do+  let getDice (F.Secret dice) _ = dice+      getDice _ acc = acc+      defaultDice = RollDice 5 2+      d = foldr getDice defaultDice (tfeature t)+  secret <- rollDice d+  return $ Tile.SecretStrength secret++trigger :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)+trigger Kind.Ops{okind, opick} t =+  let getTo (F.ChangeTo group) _ = Just group+      getTo _ acc = acc+  in case foldr getTo Nothing (tfeature (okind t)) of+       Nothing    -> return t+       Just group -> opick group (const True)++digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY+digCorridors tile (p1:p2:ps) =+  M.union corPos (digCorridors tile (p2:ps))+ where+  corXY  = fromTo p1 p2+  corPos = M.fromList $ L.zip corXY (repeat tile)+digCorridors _ _ = M.empty++passable :: [F.Feature]+passable = [F.Walkable, F.Openable, F.Hidden]++mapToHidden :: Kind.Ops TileKind+            -> Rnd (M.Map (Kind.Id TileKind) (Kind.Id TileKind))+mapToHidden cotile@Kind.Ops{ofoldrWithKey, opick} =+  let getHidden ti tk acc =+        if Tile.canBeHidden cotile tk+        then do+          ti2 <- opick "hidden" $ \ k -> Tile.kindHasFeature F.Hidden k+                                         && Tile.similar k tk+          fmap (M.insert ti ti2) acc+        else acc+  in ofoldrWithKey getHidden (return M.empty)++mergeCorridor :: Kind.Ops TileKind+              -> M.Map (Kind.Id TileKind) (Kind.Id TileKind)+              -> Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind+mergeCorridor cotile _    _ t+  | L.any (\ f -> Tile.hasFeature cotile f t) passable = t+mergeCorridor _ hiddenMap _ t = hiddenMap M.! t
+ Game/LambdaHack/Color.hs view
@@ -0,0 +1,102 @@+-- | Colours and text attributes.+module Game.LambdaHack.Color+  ( -- * Colours+    Color(..), defBG, defFG, isBright, legalBG, colorToRGB+    -- * Text attributes+  , Attr(..), defaultAttr+  ) where++import qualified Data.Binary as Binary++-- TODO: since this type may be essential to speed, consider implementing+-- it as an Int, with color numbered as they are on terminals, see+-- http://www.haskell.org/haskellwiki/Performance/Data_types#Enumerations+-- If we ever switch to 256 colours, the Int implementation or similar+-- will be more natural, anyway.+-- | Colours supported by the major frontends.+data Color =+    Black+  | Red+  | Green+  | Brown+  | 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 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) Binary.getWord8++-- | The default colours, to optimize attribute setting.+defBG, defFG :: Color+defBG = Black+defFG = White++-- | Text attributes: foreground and backgroud colors.+data Attr = Attr+  { fg :: !Color  -- ^ foreground colour+  , bg :: !Color  -- ^ backgroud color+  }+  deriving (Show, Eq, Ord)++-- | The default attribute, to optimize attribute setting.+defaultAttr :: Attr+defaultAttr = Attr defFG defBG++-- | A helper for the terminal frontends that display bright via bold.+isBright :: Color -> Bool+isBright c = c >= BrBlack++-- | Due to the limitation of the curses library used in the curses frontend,+-- only these are legal backgrounds.+legalBG :: [Color]+legalBG = [Black, White, Blue, Magenta]++-- | Translationg to heavily modified Linux console color RGB values.+colorToRGB :: Color -> String+colorToRGB Black     = "#000000"+colorToRGB Red       = "#D50000"+colorToRGB Green     = "#00AA00"+colorToRGB Brown     = "#AA5500"+colorToRGB Blue      = "#203AF0"+colorToRGB Magenta   = "#AA00AA"+colorToRGB Cyan      = "#00AAAA"+colorToRGB White     = "#C5BCB8"+colorToRGB BrBlack   = "#6F5F5F"+colorToRGB BrRed     = "#FF5555"+colorToRGB BrGreen   = "#75FF45"+colorToRGB BrYellow  = "#FFE855"+colorToRGB BrBlue    = "#4090FF"+colorToRGB BrMagenta = "#FF77FF"+colorToRGB BrCyan    = "#60FFF0"+colorToRGB BrWhite   = "#FFFFFF"++-- | For reference, the original Linux console colors.+-- Good old retro feel and more useful than xterm (e.g. brown).+_olorToRGB :: Color -> String+_olorToRGB Black     = "#000000"+_olorToRGB Red       = "#AA0000"+_olorToRGB Green     = "#00AA00"+_olorToRGB Brown     = "#AA5500"+_olorToRGB Blue      = "#0000AA"+_olorToRGB Magenta   = "#AA00AA"+_olorToRGB Cyan      = "#00AAAA"+_olorToRGB White     = "#AAAAAA"+_olorToRGB BrBlack   = "#555555"+_olorToRGB BrRed     = "#FF5555"+_olorToRGB BrGreen   = "#55FF55"+_olorToRGB BrYellow  = "#FFFF55"+_olorToRGB BrBlue    = "#5555FF"+_olorToRGB BrMagenta = "#FF55FF"+_olorToRGB BrCyan    = "#55FFFF"+_olorToRGB BrWhite   = "#FFFFFF"
+ Game/LambdaHack/Command.hs view
@@ -0,0 +1,124 @@+-- | Abstract syntax of player commands and their semantics.+module Game.LambdaHack.Command+  ( Cmd, majorCmd, timedCmd, cmdSemantics, cmdDescription+  ) where++import Game.LambdaHack.Action+import Game.LambdaHack.Actions+import Game.LambdaHack.ItemAction+import Game.LambdaHack.Grammar+import Game.LambdaHack.EffectAction+import Game.LambdaHack.State+import qualified Game.LambdaHack.Feature as F++-- | Abstract syntax of player commands. The type is abstract, but the values+-- are created outside this module via the Read class (from config file) .+data Cmd =+    Apply       { verb :: Verb, object :: Object, syms :: [Char] }+  | Project     { verb :: Verb, object :: Object, syms :: [Char] }+  | TriggerDir  { verb :: Verb, object :: Object, feature :: F.Feature }+  | TriggerTile { verb :: Verb, object :: Object, feature :: F.Feature }+  | Pickup+  | Drop+  | Inventory+  | TgtFloor+  | TgtEnemy+  | TgtAscend Int+  | GameSave+  | GameQuit+  | Cancel+  | Accept+  | History+  | CfgDump+  | HeroCycle+  | Version+  | Help+  | Wait+  | Redraw+  deriving (Show, Read)++-- | Major commands land on the first page of command help.+majorCmd :: Cmd -> Bool+majorCmd cmd = case cmd of+  Apply{}       -> True+  Project{}     -> True+  TriggerDir{}  -> True+  TriggerTile{} -> True+  Pickup        -> True+  Drop          -> True+  Inventory     -> True+  GameSave      -> True+  GameQuit      -> True+  Help          -> True+  _             -> False++-- TODO: Advance time automatically for these, but somehow advance+-- time for monsters, too. Perhaps wait until monsters use commands, too+-- (or rather the micro-commands to be added in the future).+-- | Time cosuming commands are marked as such in help and cannot be+-- invoked in targeting mode on a remote level (level different than+-- the level of the selected hero).+timedCmd :: Cmd -> Bool+timedCmd cmd = case cmd of+  Apply{}       -> True+  Project{}     -> True+  TriggerDir{}  -> True+  TriggerTile{} -> True+  Pickup        -> True+  Drop          -> True+  Wait          -> True+  _             -> False++-- | The semantics of player commands in terms of the @Action@ monad.+cmdSemantics :: Cmd -> Action ()+cmdSemantics cmd = case cmd of+  Apply{..}       -> playerApplyGroupItem verb object syms+  Project{..}     -> playerProjectGroupItem verb object syms+  TriggerDir{..}  -> playerTriggerDir feature+  TriggerTile{..} -> playerTriggerTile feature+  Pickup ->    pickupItem+  Drop ->      dropItem+  Inventory -> inventory+  TgtFloor ->  targetFloor   TgtExplicit+  TgtEnemy ->  targetMonster TgtExplicit+  TgtAscend k -> tgtAscend k+  GameSave ->  saveGame+  GameQuit ->  quitGame+  Cancel ->    cancelCurrent+  Accept ->    acceptCurrent displayHelp+  History ->   displayHistory+  CfgDump ->   dumpConfig+  HeroCycle -> cycleHero+  Version ->   gameVersion+  Help ->      displayHelp+  Wait ->      playerAdvanceTime+  Redraw ->    return ()++-- | Description of player commands.+cmdDescription :: Cmd -> String+cmdDescription cmd = case cmd of+  Apply{..}       -> verb ++ " " ++ addIndefinite object+  Project{..}     -> verb ++ " " ++ addIndefinite object+  TriggerDir{..}  -> verb ++ " " ++ addIndefinite object+  TriggerTile{..} -> verb ++ " " ++ addIndefinite object+  Pickup ->    "get an object"+  Drop ->      "drop an object"+  Inventory -> "display inventory"+  TgtFloor ->  "target location"+  TgtEnemy ->  "target monster"+  TgtAscend k | k == 1  -> "target next shallower level"+  TgtAscend k | k >= 2  -> "target " ++ show k    ++ " levels shallower"+  TgtAscend k | k == -1 -> "target next deeper level"+  TgtAscend k | k <= -2 -> "target " ++ show (-k) ++ " levels deeper"+  TgtAscend _ -> error "void level change in targeting mode in config file"+  GameSave ->  "save and exit the game"+  GameQuit ->  "quit without saving"+  Cancel ->    "cancel action"+  Accept ->    "accept choice"+  History ->   "display previous messages"+  CfgDump ->   "dump current configuration"+  HeroCycle -> "cycle among heroes on level"+  Version ->   "display game version"+  Help ->      "display help"+  Wait ->      ""+  Redraw ->    "clear messages"
+ Game/LambdaHack/Config.hs view
@@ -0,0 +1,146 @@+-- | Personal game configuration file support.+module Game.LambdaHack.Config+  ( CP, mkConfig, appDataDir+  , getOption, get, getItems, getFile, dump, getSetGen+  ) where++import System.Directory+import System.FilePath+import System.Environment+import qualified Data.ConfigFile as CF+import qualified Data.Binary as Binary+import qualified Data.Char as Char+import qualified Data.List as L+import qualified System.Random as R++-- | The content of the configuration file. It's parsed+-- in a case sensitive way (unlike by default in ConfigFile).+newtype CP = CP CF.ConfigParser++instance Binary.Binary CP where+  put (CP conf) = Binary.put $ CF.to_string conf+  get = do+    string <- Binary.get+    let c = CF.readstring CF.emptyCP string+    return $ toCP $ forceEither c++instance Show CP where+  show (CP conf) = show $ CF.to_string conf++-- | In case of corruption, just fail.+forceEither :: Show a => Either a b -> b+forceEither (Left a)  = error (show a)+forceEither (Right b) = b++-- | Switches all names to case sensitive (unlike by default in+-- the "ConfigFile" library) and wraps in the constructor.+toCP :: CF.ConfigParser -> CP+toCP cf = CP $ cf {CF.optionxform = id}++overrideCP :: CP -> FilePath -> IO CP+overrideCP (CP defCF) cfile = do+  c <- CF.readfile defCF cfile+  return $ toCP $ forceEither c++-- | Read the player configuration file and use it to override+-- any default config options. Currently we can't unset options, only override.+--+-- The default config, passed in argument @configDefault@,+-- is expected to come from the default configuration file included via CPP+-- in file @ConfigDefault.hs@.+mkConfig :: String -> IO CP+mkConfig configDefault = do+  let delFileMarker = L.init $ L.drop 3 $ lines configDefault+      delComment = L.map (L.drop 2) delFileMarker+      unConfig = unlines delComment+      -- Evaluate, to catch config errors ASAP.+      !defCF = forceEither $ CF.readstring CF.emptyCP unConfig+      !defConfig = toCP defCF+  cfile <- configFile+  b <- doesFileExist cfile+  if not b+    then return defConfig+    else overrideCP defConfig cfile++-- | Personal data directory for the game. Depends on the OS and the game,+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.+appDataDir :: IO FilePath+appDataDir = do+  progName <- getProgName+  let name = L.takeWhile Char.isAlphaNum progName+  getAppUserDataDirectory name++-- | Path to the user configuration file in the personal data directory.+configFile :: IO FilePath+configFile = do+  appData <- appDataDir+  return $ combine appData "config"++-- | A simplified access to an option in a given section,+-- with simple error reporting (no internal errors are caught nor hidden).+-- If there is no such option, gives Nothing.+getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a+getOption (CP conf) s o =+  if CF.has_option conf s o+  then Just $ forceEither $ CF.get conf s o+  else Nothing++-- | Simplified access to an option in a given section.+-- Fails if the option is not present.+get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a+get (CP conf) s o =+  if CF.has_option conf s o+  then forceEither $ CF.get conf s o+  else error $ "Unknown config option: " ++ s ++ "." ++ o++-- | An association list corresponding to a section. Fails if no such section.+getItems :: CP -> CF.SectionSpec -> [(String, String)]+getItems (CP conf) s =+  if CF.has_section conf s+  then forceEither $ CF.items conf s+  else error $ "Unknown config section: " ++ s++-- | Looks up a file path in the config file and makes it absolute.+-- If the game's configuration directory exists,+-- the file path is appended to it; otherwise, it's appended+-- to the current directory.+getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath+getFile conf s o = do+  current <- getCurrentDirectory+  appData <- appDataDir+  let path    = get conf s o+      appPath = combine appData path+      curPath = combine current path+  b <- doesDirectoryExist appData+  return $ if b then appPath else curPath++-- | Dumps the current configuration to a file.+dump :: FilePath -> CP -> IO ()+dump fn (CP conf) = do+  current <- getCurrentDirectory+  let path  = combine current fn+      sdump = CF.to_string conf+  writeFile path sdump++-- | Simplified setting of an option in a given section. Overwriting forbidden.+set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP+set (CP conf) s o v =+  if CF.has_option conf s o+  then error $ "Overwritten config option: " ++ s ++ "." ++ o+  else CP $ forceEither $ CF.set conf s o v++-- | Gets a random generator from the config or,+-- if not present, generates one and updates the config with it.+getSetGen :: CP  -- ^ config+          -> String     -- ^ name of the generator+          -> IO (R.StdGen, CP)+getSetGen config option =+  case getOption config "engine" option of+    Just sg -> return (read sg, config)+    Nothing -> do+      -- Pick the randomly chosen generator from the IO monad+      -- and record it in the config for debugging (can be 'D'umped).+      g <- R.newStdGen+      let gs = show g+          c = set config "engine" option gs+      return (g, c)
+ Game/LambdaHack/Content.hs view
@@ -0,0 +1,21 @@+-- | A game requires the engine provided by the library, perhaps customized,+-- and game content, defined completely afresh for the particular game.+-- The general type of the content is @CDefs@ and it has instances+-- for all content kinds, such as items kinds+-- (@Game.LambdaHack.Content.ItemKind@).+-- The possible kinds are fixed in the library and all defined in the same+-- directory. On the other hand, game content, that is all elements+-- of @CDefs@ instances, are defined in a directory+-- of the game code proper, with names corresponding to their kinds.+module Game.LambdaHack.Content (CDefs(..)) where++import Game.LambdaHack.Misc++-- | The general type of a particular game content, e.g., item kinds.+data CDefs a = CDefs+  { getSymbol :: a -> Char    -- ^ symbol, e.g., to print on the map+  , getName   :: a -> String  -- ^ name, e.g., to show to the player+  , getFreq   :: a -> Freqs   -- ^ frequency within groups+  , validate  :: [a] -> [a]   -- ^ validate and catch some offenders, if any+  , content   :: [a]          -- ^ all the defined content of this type+  }
+ Game/LambdaHack/Content/ActorKind.hs view
@@ -0,0 +1,37 @@+-- | The type of kinds of monsters and heroes.+module Game.LambdaHack.Content.ActorKind+  ( ActorKind(..), avalidate+  ) where++import qualified Data.List as L+import qualified Data.Ord as Ord++import Game.LambdaHack.Color+import qualified Game.LambdaHack.Random as Random+import Game.LambdaHack.Misc++-- | Actor properties that are fixed for a given kind of actors.+data ActorKind = ActorKind+  { asymbol :: !Char             -- ^ map symbol+  , aname   :: !String           -- ^ short description+  , afreq   :: !Freqs            -- ^ frequency within groups+  , acolor  :: !Color            -- ^ map color+  , aspeed  :: !Time             -- ^ natural speed+  , ahp     :: !Random.RollDice  -- ^ encodes initial and maximal hp+  , asight  :: !Bool             -- ^ can it see?+  , asmell  :: !Bool             -- ^ can it smell?+  , aiq     :: !Int              -- ^ intelligence+  , aregen  :: !Int              -- ^ regeneration interval+  }+  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53++-- | Filter a list of kinds, passing through only the incorrect ones, if any.+--+-- Make sure actor kinds can be told apart on the level map.+avalidate :: [ActorKind] -> [ActorKind]+avalidate l =+  let cmp = Ord.comparing (\ ka -> (asymbol ka, acolor ka))+      eq ka1 ka2 = cmp ka1 ka2 == Ord.EQ+      sorted = L.sortBy cmp l+      nubbed = L.nubBy eq sorted+  in L.deleteFirstsBy eq sorted nubbed
+ Game/LambdaHack/Content/CaveKind.hs view
@@ -0,0 +1,50 @@+-- | The type of cave layout kinds.+module Game.LambdaHack.Content.CaveKind+  ( CaveKind(..), cvalidate+  ) where++import qualified Data.List as L++import Game.LambdaHack.PointXY+import Game.LambdaHack.Random+import Game.LambdaHack.Misc++-- | Parameters for the generation of dungeon levels.+data CaveKind = CaveKind+  { csymbol       :: Char        -- ^ a symbol+  , cname         :: String      -- ^ short description+  , cfreq         :: Freqs       -- ^ frequency within groups+  , cxsize        :: X           -- ^ X size of the whole cave+  , cysize        :: Y           -- ^ Y size of the whole cave+  , cgrid         :: RollDiceXY  -- ^ the dimensions of the grid of places+  , cminPlaceSize :: RollDiceXY  -- ^ minimal size of places+  , cdarkChance   :: RollDeep    -- ^ the chance a place is dark+  , cauxConnects  :: Rational    -- ^ a proportion of extra connections+  , cvoidChance   :: Chance      -- ^ the chance of not creating a place+  , cnonVoidMin   :: Int         -- ^ extra places, may overlap except two+  , cminStairDist :: Int         -- ^ minimal distance between stairs+  , cdoorChance   :: Chance      -- ^ the chance of a door in an opening+  , copenChance   :: Chance      -- ^ if there's a door, is it open?+  , chiddenChance :: Chance      -- ^ if not open, is it hidden?+  , citemNum      :: RollDice    -- ^ the number of items in the cave+  , cdefTile      :: String      -- ^ the default cave tile group name+  , ccorTile      :: String      -- ^ the cave corridor tile group name+  }+  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53++-- | Filter a list of kinds, passing through only the incorrect ones, if any.+--+-- Catch caves with not enough space for all the places. Check the size+-- of the cave descriptions to make sure they fit on screen.+cvalidate :: [CaveKind] -> [CaveKind]+cvalidate = L.filter (\ CaveKind{ cgrid = RollDiceXY (gx, gy)+                                , cminPlaceSize = RollDiceXY (mx, my)+                                , ..+                                } ->+  let (maxGridX, maxGridY) = (maxDice gx, maxDice gy)+      (maxPlaceSizeX, maxPlaceSizeY) = (maxDice mx,  maxDice my)+      xborder = if maxGridX == 1 then 5 else 3+      yborder = if maxGridX == 1 then 5 else 3+  in length cname <= 25+     && (maxGridX * (xborder + maxPlaceSizeX) + 1 > cxsize ||+         maxGridY * (yborder + maxPlaceSizeY) + 1 > cysize))
+ Game/LambdaHack/Content/ItemKind.hs view
@@ -0,0 +1,36 @@+-- | The type of kinds of weapons and treasure.+module Game.LambdaHack.Content.ItemKind+  ( ItemKind(..), ivalidate+  ) where++import Game.LambdaHack.Effect+import Game.LambdaHack.Flavour+import Game.LambdaHack.Random+import Game.LambdaHack.Misc++-- TODO: ipower is out of place here. It doesn't make sense for all items,+-- and will mean different things for different items. Perhaps it should+-- be part of the Effect, but then we have to be careful to distinguish+-- parts of the Effect that are rolled on item creation and those rolled+-- at each use (e.g., sword magical +damage vs. sword damage dice).+-- Another thing to keep in minds is that ipower will heavily determine+-- the value of the item for shops, treasure chests, artifact set rebalancing,+-- etc., so if we make ipower complex, the value computation gets complex too.+-- | Item properties that are fixed for a given kind of items.+data ItemKind = ItemKind+  { isymbol  :: !Char        -- ^ map symbol+  , iname    :: !String      -- ^ generic name+  , ifreq    :: !Freqs       -- ^ frequency within groups+  , iflavour :: ![Flavour]   -- ^ possible flavours+  , ieffect  :: !Effect      -- ^ the effect when activated+  , icount   :: !RollDeep    -- ^ created in that quantify+  , ipower   :: !RollDeep    -- ^ created with that power+  , iverbApply   :: !String  -- ^ the verb for applying and possibly combat+  , iverbProject :: !String  -- ^ the verb for projecting+  }+  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53++-- | No specific possible problems for the content of this kind, so far,+-- so the validation function always returns the empty list of offending kinds.+ivalidate :: [ItemKind] -> [ItemKind]+ivalidate _ = []
+ Game/LambdaHack/Content/PlaceKind.hs view
@@ -0,0 +1,46 @@+-- | The type of kinds of rooms, halls and passages.+module Game.LambdaHack.Content.PlaceKind+  ( PlaceKind(..), Cover(..), Fence(..), pvalidate+  ) where++import qualified Data.List as L+import Game.LambdaHack.Misc++-- | Parameters for the generation of small areas within a dungeon level.+data PlaceKind = PlaceKind+  { psymbol  :: Char      -- ^ a symbol+  , pname    :: String    -- ^ short description+  , pfreq    :: Freqs     -- ^ frequency within groups+  , pcover   :: Cover     -- ^ how to fill whole place based on the corner+  , pfence   :: Fence     -- ^ whether to fence the place with solid border+  , ptopLeft :: [String]  -- ^ plan of the top-left corner of the place+  }+  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53++-- | A method of filling the whole area by transforming a given corner.+data Cover =+    CAlternate   -- ^ reflect every other corner, overlapping 1 row and column+  | CStretch     -- ^ fill symmetrically 4 corners and stretch their borders+  | CReflect     -- ^ tile separately and symmetrically quarters of the place+  deriving (Show, Eq)++-- | The choice of a fence type for the place.+data Fence =+    FWall   -- ^ put a solid wall fence around the place+  | FFloor  -- ^ leave an empty floor space around the place+  | FNone   -- ^ skip the fence and fill all with the place proper+  deriving (Show, Eq)++-- TODO: Verify that places are fully accessible from any entrace on the fence+-- that is at least 4 tiles distant from the edges, if the place is big enough,+-- (unless the place has FNone fence, in which case the entrance is+-- at the outer tiles of the place).+-- TODO: Check that all symbols in place plans are present in the legend.+-- TODO: Add a field with tile group to be used as the legend.+-- | Filter a list of kinds, passing through only the incorrect ones, if any.+--+-- Verify that the top-left corner map is rectangular and not empty.+pvalidate :: [PlaceKind] -> [PlaceKind]+pvalidate = L.filter (\ PlaceKind{..} ->+  let dxcorner = case ptopLeft of [] -> 0 ; l : _ -> L.length l+  in dxcorner /= 0 && L.any (/= dxcorner) (L.map L.length ptopLeft))
+ Game/LambdaHack/Content/RuleKind.hs view
@@ -0,0 +1,47 @@+-- | The type of game rule sets and assorted game data.+module Game.LambdaHack.Content.RuleKind+  ( RuleKind(..), ruvalidate+  ) where++import Data.Version++import Game.LambdaHack.PointXY+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Point+import Game.LambdaHack.Misc++-- TODO: very few rules are configurable yet, extend as needed.++-- | The type of game rule sets and assorted game data.+--+-- For now the rules are immutable througout the game, so there is+-- no type @Rule@ to hold any changing parameters, just @RuleKind@+-- for the fixed set.+-- However, in the future, if the rules can get changed during gameplay+-- based on data mining of player behaviour, we may add such a type+-- and then @RuleKind@ will become just a starting template, analogously+-- as for the other content.+--+-- The @raccessible@ field holds a predicate that tells+-- whether one location is accessible from another.+-- Precondition: the two locations are next to each other.+data RuleKind = RuleKind+  { rsymbol           :: Char     -- ^ a symbol+  , rname             :: String   -- ^ short description+  , rfreq             :: Freqs    -- ^ frequency within groups+  , raccessible       :: X -> Point -> TileKind -> Point -> TileKind -> Bool+  , rtitle            :: String   -- ^ the title of the game+  , rpathsDataFile    :: FilePath -> IO FilePath  -- ^ the path to data files+  , rpathsVersion     :: Version  -- ^ the version of the game+  }++-- | A dummy instance of the 'Show' class, to satisfy general requirments+-- about content. We won't have many rule sets and they contain functions,+-- so defining a proper instance is not practical.+instance Show RuleKind where+  show _ = "The game ruleset specification."++-- | No specific possible problems for the content of this kind, so far,+-- so the validation function always returns the empty list of offending kinds.+ruvalidate :: [RuleKind] -> [RuleKind]+ruvalidate _ = []
+ Game/LambdaHack/Content/TileKind.hs view
@@ -0,0 +1,45 @@+-- | The type of kinds of terrain tiles.+module Game.LambdaHack.Content.TileKind+  ( TileKind(..), tvalidate+  ) where++import qualified Data.List as L+import qualified Data.Map as M++import Game.LambdaHack.Color+import Game.LambdaHack.Feature+import Game.LambdaHack.Misc++-- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation+-- of the absence of a corresponding type @Tile@ that would hold+-- particular concrete tiles in the dungeon.+data TileKind = TileKind+  { tsymbol  :: !Char       -- ^ map symbol+  , tname    :: !String     -- ^ short description+  , tfreq    :: !Freqs      -- ^ frequency within groups+  , tcolor   :: !Color      -- ^ map color+  , tcolor2  :: !Color      -- ^ map color when not in FOV+  , tfeature :: ![Feature]  -- ^ properties+  }+  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53++-- TODO: check that all posible solid place fences have hidden counterparts.+-- | Filter a list of kinds, passing through only the incorrect ones, if any.+--+-- If tiles look the same on the map, the description should be the same, too.+-- Otherwise, the player has to inspect manually all the tiles of that kind+-- to see if any is special. This is a part of a stronger+-- but less precise property that tiles that look the same can't be+-- distinguished by player actions (but may behave differently+-- wrt dungeon generation, AI preferences, etc.).+tvalidate :: [TileKind] -> [TileKind]+tvalidate lt =+  let listFov f = L.map (\ kt -> ((tsymbol kt, f kt), [kt])) lt+      mapFov :: (TileKind -> Color) -> M.Map (Char, Color) [TileKind]+      mapFov f = M.fromListWith (++) $ listFov f+      namesUnequal l = let name = tname (L.head l)+                       in L.any (/= name) (L.map tname l)+      confusions f = L.filter namesUnequal $ M.elems $ mapFov f+  in case confusions tcolor ++ confusions tcolor2 of+    [] -> []+    l : _ -> l
+ Game/LambdaHack/Display.hs view
@@ -0,0 +1,218 @@+-- | Display game data on the screen using one of the available frontends+-- (determined at compile time with cabal flags).+{-# LANGUAGE CPP #-}+module Game.LambdaHack.Display+  ( -- * Re-exported frontend+    FrontendSession, startup, shutdown, frontendName, nextEvent+    -- * Derived operations+  , ColorMode(..), displayLevel, getConfirmD+  ) where++-- Wrapper for selected Display frontend.++#ifdef CURSES+import Game.LambdaHack.Display.Curses as D+#elif VTY+import Game.LambdaHack.Display.Vty as D+#elif STD+import Game.LambdaHack.Display.Std as D+#else+import Game.LambdaHack.Display.Gtk as D+#endif++import qualified Data.Char as Char+import qualified Data.IntSet as IS+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Misc+import Game.LambdaHack.Msg+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.State+import Game.LambdaHack.PointXY+import Game.LambdaHack.Point+import Game.LambdaHack.Level+import Game.LambdaHack.Effect+import Game.LambdaHack.Perception+import Game.LambdaHack.Tile+import Game.LambdaHack.Actor as Actor+import Game.LambdaHack.ActorState+import qualified Game.LambdaHack.Dungeon as Dungeon+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Item as Item+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Random+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.FOV++-- | Waits for a SPACE or ESC.+getConfirmD :: FrontendSession -> IO Bool+getConfirmD fs = do+  e <- nextEvent fs+  case e of+    K.Space    -> return True+    K.Esc      -> return False+    _          -> getConfirmD fs++splitOverlay :: Int -> String -> [[String]]+splitOverlay s xs = splitOverlay' (lines xs)+ where+  splitOverlay' ls+    | length ls <= s = [ls]  -- everything fits on one screen+    | otherwise      = let (pre, post) = splitAt (s - 1) ls+                       in (pre ++ [more]) : splitOverlay' post++-- | Returns a function that looks up the characters in the+-- string by location. Takes the height of the display plus+-- the string. Returns also the number of screens required+-- to display all of the string.+stringByLocation :: Y -> String -> (Int, (X, Y) -> Maybe Char)+stringByLocation lysize xs =+  let ls = splitOverlay lysize xs+      m  = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))+      k  = length ls+  in (k, \ (x, y) -> M.lookup y m >>= \ n -> M.lookup x n)++-- | Color mode for the display.+data ColorMode =+    ColorFull  -- ^ normal, with full colours+  | ColorBW    -- ^ black+white only++-- TODO: split up and generally rewrite.+-- | Display the whole screen: level map, messages and status area+-- and multi-page overlaid information, if any.+displayLevel :: ColorMode -> FrontendSession -> Kind.COps+             -> Perception -> State+             -> Msg -> Maybe String -> IO Bool+displayLevel dm fs cops per+             s@State{scursor, stime, sflavour, slid, splayer, sdebug}+             msg moverlay =+  let Kind.COps{ coactor=Kind.Ops{okind}+               , coitem=coitem@Kind.Ops{okind=iokind}+               , cotile=Kind.Ops{okind=tokind} } = cops+      DebugMode{smarkVision, somniscient} = sdebug+      lvl@Level{lxsize, lysize, lsmell, ldesc} = slevel s+      (_, Actor{bkind, bhp, bloc}, bitems) = findActorAnyLevel splayer s+      ActorKind{ahp, asmell} = okind bkind+      reachable = debugTotalReachable per+      visible   = totalVisible per+      (msgs, (ns, over)) =+        case moverlay of+          Just overlay ->+            ( splitMsg (fst normalLevelBound + 1) msg (length more)+            , -- ns overlay screens needed+              stringByLocation lysize overlay+            )+          Nothing ->+            case splitMsg (fst normalLevelBound + 1) msg 0 of+              msgTop : mss ->+                ( [msgTop]+                , stringByLocation lysize $ unlines $+                    L.map (padMsg (fst normalLevelBound + 1)) mss+                )+              [] -> assert `failure` msg+      (sSml, sVis) = case smarkVision of+        Just Blind -> (True, True)+        Just _  -> (False, True)+        Nothing | asmell -> (True, False)+        Nothing -> (False, False)+      lAt    = if somniscient then at else rememberAt+      liAt   = if somniscient then atI else rememberAtI+      sVisBG = if sVis+               then \ vis rea -> if vis+                                 then Color.Blue+                                 else if rea+                                      then Color.Magenta+                                      else Color.defBG+               else \ _vis _rea -> Color.defBG+      wealth  = calculateTotal coitem s+      damage  = case Item.strongestSword coitem bitems of+                  Just sw -> case ieffect $ iokind $ Item.jkind sw of+                    Wound dice -> show dice ++ "+" ++ show (Item.jpower sw)+                    _ -> show (Item.jpower sw)+                  Nothing -> "3d1"  -- TODO; use the item 'fist'+      hs      = levelHeroList s+      ms      = levelMonsterList s+      dis offset p@(PointXY (x0, y0)) =+        let loc0 = toPoint lxsize p+            tile = lvl `lAt` loc0+            items = lvl `liAt` loc0+            sm = smelltime $ IM.findWithDefault (SmellTime 0) loc0 lsmell+            sml = (sm - stime) `div` 100+            viewActor loc Actor{bkind = bkind2, bsymbol}+              | loc == bloc && slid == creturnLn scursor =+                  (symbol, Color.defBG)  -- highlight player+              | otherwise = (symbol, acolor)+             where+              ActorKind{asymbol, acolor} = okind bkind2+              symbol = fromMaybe asymbol bsymbol+            viewSmell :: Int -> Char+            viewSmell k+              | k > 9     = '*'+              | k < 0     = '-'+              | otherwise = Char.intToDigit k+            rainbow loc = toEnum $ loc `rem` 14 + 1+            (char, fg0) =+              case L.find (\ m -> loc0 == Actor.bloc m) (hs ++ ms) of+                Just m | somniscient || vis -> viewActor loc0 m+                _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc0)+                  | otherwise ->+                  case items of+                    [] -> let u = tokind tile+                          in (tsymbol u, if vis then tcolor u else tcolor2 u)+                    i : _ -> Item.viewItem coitem (Item.jkind i) sflavour+            vis = IS.member loc0 visible+            rea = IS.member loc0 reachable+            bg0 = if ctargeting scursor /= TgtOff && loc0 == clocation scursor+                  then Color.defFG     -- highlight target cursor+                  else sVisBG vis rea  -- FOV debug+            reverseVideo = Color.Attr{ fg = Color.bg Color.defaultAttr+                                     , bg = Color.fg Color.defaultAttr+                                     }+            optVisually attr@Color.Attr{fg, bg} =+              if (fg == Color.defBG) || (bg == Color.defFG && fg == Color.defFG)+              then reverseVideo+              else attr+            a = case dm of+                  ColorBW   -> Color.defaultAttr+                  ColorFull -> optVisually Color.Attr{fg = fg0, bg = bg0}+        in case over (x0, y0 + offset) of+             Just c -> (Color.defaultAttr, c)+             _      -> (a, char)+      status =+        take 27 (ldesc ++ repeat ' ') +++        take 7 ("L: " ++ show (Dungeon.levelNumber slid) ++ repeat ' ') +++        take 10 ("T: " ++ show (stime `div` 10) ++ repeat ' ') +++        take 9 ("$: " ++ show wealth ++ repeat ' ') +++        take 12 ("Dmg: " ++ damage ++ repeat ' ') +++        take 30 ("HP: " ++ show bhp +++                 " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ')+      width = fst normalLevelBound + 1+      toWidth :: Int -> String -> String+      toWidth n x = take n (x ++ repeat ' ')+      disp n mesg = display (0, 0, lxsize-1, lysize-1) fs (dis (lysize * n))+                      (toWidth width mesg) (toWidth width status)+      -- Perform messages slideshow.+      perf []     = perfOverlay 0 ""+      perf [xs]   = perfOverlay 0 xs+      perf (x:xs) = do+        disp ns (x ++ more)+        b <- getConfirmD fs+        if b then perf xs else return False+      -- Perform overlay pages slideshow.+      perfOverlay k xs = do+        disp k xs+        if k < ns - 1+          then do+            b <- getConfirmD fs+            if b+              then perfOverlay (k + 1) xs+              else return False+          else+            return True+  in perf msgs
+ Game/LambdaHack/Display/Curses.hs view
@@ -0,0 +1,146 @@+-- | Text frontend based on HSCurses.+module Game.LambdaHack.Display.Curses+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent+    -- * Frontend administration tools+  , frontendName, startup, shutdown+  ) where++import qualified UI.HSCurses.Curses as C+import qualified UI.HSCurses.CursesHelper as C+import qualified Data.List as L+import qualified Data.Map as M+import Control.Monad++import Game.LambdaHack.Area+import Game.LambdaHack.PointXY+import qualified Game.LambdaHack.Key as K (Key(..))+import qualified Game.LambdaHack.Color as Color++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { swin    :: C.Window  -- ^ the window to draw to+  , sstyles :: M.Map Color.Attr C.CursesStyle+      -- ^ map from fore/back colour pairs to defined curses styles+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "curses"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = do+  C.start+  C.cursSet C.CursorInvisible+  let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg))+          | fg <- [minBound..maxBound],+            -- No more color combinations possible: 16*4, 64 is max.+            bg <- Color.legalBG ]+  nr <- C.colorPairs+  when (nr < L.length s) $+    C.end >>+    error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")+  let (ks, vs) = unzip s+  ws <- C.convertStyles vs+  let styleMap = M.fromList (zip ks ws)+  k (FrontendSession C.stdScr styleMap)++-- | Shuts down the frontend cleanly.+shutdown :: FrontendSession -> IO ()+shutdown _ = C.end++-- | Output to the screen via the frontend.+display :: Area             -- ^ the size of the drawn area+        -> FrontendSession  -- ^ current session data+        -> (PointXY -> (Color.Attr, Char))+                            -- ^ the content of the screen+        -> String           -- ^ an extra line to show at the top+        -> String           -- ^ an extra line to show at the bottom+        -> IO ()+display (x0, y0, x1, y1) FrontendSession{..} f msg status = do+  -- let defaultStyle = C.defaultCursesStyle+  -- Terminals with white background require this:+  let defaultStyle = sstyles M.! Color.defaultAttr+  C.erase+  C.setStyle defaultStyle+  C.mvWAddStr swin 0 0 msg+  C.mvWAddStr swin (y1 + 2) 0 (L.init status)+  -- TODO: we need to remove the last character from the status line,+  -- because otherwise it would overflow a standard size xterm window,+  -- due to the curses historical limitations.+  sequence_ [ C.setStyle (M.findWithDefault defaultStyle a sstyles)+              >> C.mvWAddStr swin (y + 1) x [c]+            | x <- [x0..x1], y <- [y0..y1],+              let (a, c) = f (PointXY (x, y)) ]+  C.refresh++-- | Input key via the frontend.+nextEvent :: FrontendSession -> IO K.Key+nextEvent _sess = do+  e <- C.getKey C.refresh+  return (keyTranslate e)+--  case keyTranslate e of+--    Unknown _ -> nextEvent sess+--    k -> return k++keyTranslate :: C.Key -> K.Key+keyTranslate e =+  case e of+    C.KeyChar '\ESC' -> K.Esc+    C.KeyExit        -> K.Esc+    C.KeyChar '\n'   -> K.Return+    C.KeyChar '\r'   -> K.Return+    C.KeyEnter       -> K.Return+    C.KeyChar ' '    -> K.Space+    C.KeyChar '\t'   -> K.Tab+    C.KeyUp          -> K.Up+    C.KeyDown        -> K.Down+    C.KeyLeft        -> K.Left+    C.KeySLeft       -> K.Left+    C.KeyRight       -> K.Right+    C.KeySRight      -> K.Right+    C.KeyHome        -> K.Home+    C.KeyPPage       -> K.PgUp+    C.KeyEnd         -> K.End+    C.KeyNPage       -> K.PgDn+    C.KeyBeg         -> K.Begin+    C.KeyB2          -> K.Begin+    C.KeyClear       -> K.Begin+    -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10+    -- Movement keys are more important than hero selection, so preferring them:+    C.KeyChar c+      | c `elem` ['1'..'9'] -> K.KP c+      | otherwise           -> K.Char c+    _                       -> K.Unknown (show e)++toFColor :: Color.Color -> C.ForegroundColor+toFColor Color.Black     = C.BlackF+toFColor Color.Red       = C.DarkRedF+toFColor Color.Green     = C.DarkGreenF+toFColor Color.Brown     = C.BrownF+toFColor Color.Blue      = C.DarkBlueF+toFColor Color.Magenta   = C.PurpleF+toFColor Color.Cyan      = C.DarkCyanF+toFColor Color.White     = C.WhiteF+toFColor Color.BrBlack   = C.GreyF+toFColor Color.BrRed     = C.RedF+toFColor Color.BrGreen   = C.GreenF+toFColor Color.BrYellow  = C.YellowF+toFColor Color.BrBlue    = C.BlueF+toFColor Color.BrMagenta = C.MagentaF+toFColor Color.BrCyan    = C.CyanF+toFColor Color.BrWhite   = C.BrightWhiteF++toBColor :: Color.Color -> C.BackgroundColor+toBColor Color.Black     = C.BlackB+toBColor Color.Red       = C.DarkRedB+toBColor Color.Green     = C.DarkGreenB+toBColor Color.Brown     = C.BrownB+toBColor Color.Blue      = C.DarkBlueB+toBColor Color.Magenta   = C.PurpleB+toBColor Color.Cyan      = C.DarkCyanB+toBColor Color.White     = C.WhiteB+toBColor _               = C.BlackB  -- a limitation of curses
+ Game/LambdaHack/Display/Gtk.hs view
@@ -0,0 +1,187 @@+-- | Text frontend based on Gtk.+module Game.LambdaHack.Display.Gtk+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent+    -- * Frontend administration tools+  , frontendName, startup, shutdown+  ) where++import Control.Monad+import Control.Concurrent+import Graphics.UI.Gtk.Gdk.Events  -- TODO: replace, deprecated+import Graphics.UI.Gtk hiding (Point)+import qualified Data.List as L+import Data.IORef+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as BS++import Game.LambdaHack.Area+import Game.LambdaHack.PointXY+import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate)+import qualified Game.LambdaHack.Color as Color++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { sview :: TextView                  -- ^ the widget to draw to+  , stags :: M.Map Color.Attr TextTag  -- ^ text tags for fore/back colour pairs+  , schan :: Chan String               -- ^ the channel that carries input+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "gtk"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup configFont k = do+  -- initGUI+  unsafeInitGUIForThreadedRTS+  w <- windowNew+  ttt <- textTagTableNew+  -- text attributes+  stags <- fmap M.fromList $+             mapM (\ ak -> do+                      tt <- textTagNew Nothing+                      textTagTableAdd ttt tt+                      doAttr tt ak+                      return (ak, tt))+               [ Color.Attr{fg, bg}+               | fg <- [minBound..maxBound], bg <- Color.legalBG ]+  -- text buffer+  tb <- textBufferNew (Just ttt)+  textBufferSetText tb (unlines (replicate 25 (replicate 80 ' ')))+  -- create text view, TODO: use GtkLayout or DrawingArea instead of TextView?+  sview <- textViewNewWithBuffer tb+  containerAdd w sview+  textViewSetEditable sview False+  textViewSetCursorVisible sview False+  -- font+  f <- fontDescriptionFromString configFont+  widgetModifyFont sview (Just f)+  currentfont <- newIORef f+  let buttonPressHandler e = case e of+        Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } -> do+          fsd <- fontSelectionDialogNew "Choose font"+          cf  <- readIORef currentfont  -- TODO: "Terminus,Monospace" fails+          fds <- fontDescriptionToString cf+          fontSelectionDialogSetFontName fsd fds+          fontSelectionDialogSetPreviewText fsd "eee...@.##+##"+          resp <- dialogRun fsd+          when (resp == ResponseOk) $ do+            fn <- fontSelectionDialogGetFontName fsd+            case fn of+              Just fn' -> do+                fd <- fontDescriptionFromString fn'+                writeIORef currentfont fd+                widgetModifyFont sview (Just fd)+              Nothing  -> return ()+          widgetDestroy fsd+          return True+        _ -> return False+  onButtonPress sview buttonPressHandler+  -- modify default colours+  let black = Color minBound minBound minBound  -- Color.defBG == Color.Black+      white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White+  widgetModifyBase sview StateNormal black+  widgetModifyText sview StateNormal white+  -- set up the channel for communication+  schan <- newChan+  forkIO $ k FrontendSession{..}+  -- fill the channel+  onKeyPress sview+    (\ e -> do+        writeChan schan (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)+        return True)+  -- set quit handler+  onDestroy w mainQuit+  -- start it up+  widgetShowAll w+  yield+  mainGUI++-- | Shuts down the frontend cleanly.+shutdown :: FrontendSession -> IO ()+shutdown _ = mainQuit++-- | Output to the screen via the frontend.+display :: Area             -- ^ the size of the drawn area+        -> FrontendSession  -- ^ current session data+        -> (PointXY -> (Color.Attr, Char))+                            -- ^ the content of the screen+        -> String           -- ^ an extra line to show at the top+        -> String           -- ^ an extra line to show at the bottom+        -> IO ()+display (x0, y0, x1, y1) FrontendSession{sview, stags} f msg status =+  postGUIAsync $ do+    tb <- textViewGetBuffer sview+    let fLine y = let (as, cs) = unzip [ f (PointXY (x, y))+                                       | x <- [x0..x1] ]+                  in ((y, as), BS.pack cs)+        memo  = L.map fLine [y0..y1]+        attrs = L.map fst memo+        chars = L.map snd memo+        bs    = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status]+    textBufferSetByteString tb (BS.concat bs)+    mapM_ (setTo tb stags x0) attrs++setTo :: TextBuffer -> M.Map Color.Attr TextTag -> X -> (Y, [Color.Attr])+      -> IO ()+setTo _  _   _  (_,  [])         = return ()+setTo tb tts lx (ly, attr:attrs) = do+  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx+  ie <- textIterCopy ib+  let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO ()+      setIter previous repetitions [] = do+        textIterForwardChars ie repetitions+        when (previous /= Color.defaultAttr) $+          textBufferApplyTag tb (tts M.! previous) ib ie+      setIter previous repetitions (a:as)+        | a == previous =+            setIter a (repetitions + 1) as+        | otherwise = do+            textIterForwardChars ie repetitions+            when (previous /= Color.defaultAttr) $+              textBufferApplyTag tb (tts M.! previous) ib ie+            textIterForwardChars ib repetitions+            setIter a 1 as+  setIter attr 1 attrs++-- | Input key via the frontend.+nextEvent :: FrontendSession -> IO K.Key+nextEvent sess = do+  e <- readUndeadChan (schan sess)+  return (K.keyTranslate e)++-- | 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++doAttr :: TextTag -> Color.Attr -> IO ()+doAttr tt attr@Color.Attr{fg, bg}+  | attr == Color.defaultAttr = return ()+  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]+  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]+  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,+                                textTagBackground := Color.colorToRGB bg]
+ Game/LambdaHack/Display/Std.hs view
@@ -0,0 +1,110 @@+-- | Text frontend based on stdin/stdout, intended for bots.+module Game.LambdaHack.Display.Std+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent+    -- * Frontend administration tools+  , frontendName, startup, shutdown+  ) where++import qualified Data.List as L+import qualified Data.ByteString.Char8 as BS+import qualified System.IO as SIO++import Game.LambdaHack.Area+import Game.LambdaHack.PointXY+import qualified Game.LambdaHack.Key as K (Key(..))+import qualified Game.LambdaHack.Color as Color++-- | No session data needs to be maintained by this frontend.+type FrontendSession = ()++-- | The name of the frontend.+frontendName :: String+frontendName = "std"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = k ()++-- | Shuts down the frontend cleanly. Nothing to be done in this case.+shutdown :: FrontendSession -> IO ()+shutdown _ = return ()++-- | Output to the screen via the frontend.+display :: Area             -- ^ the size of the drawn area+        -> FrontendSession  -- ^ current session data+        -> (PointXY -> (Color.Attr, Char))+                            -- ^ the content of the screen+        -> String           -- ^ an extra line to show at the top+        -> String           -- ^ an extra line to show at the bottom+        -> IO ()+display (x0, y0, x1, y1) _sess f msg status =+  let xsize  = x1 - x0 + 1+      g y x  = if x > x1+               then Nothing+               else Just (snd (f (PointXY (x, y))), x + 1)+      fl y   = fst $ BS.unfoldrN xsize (g y) x0+      level  = L.map fl [y0..y1]+      screen = [BS.pack msg] ++ level ++ [BS.pack status, BS.empty]+  in mapM_ BS.putStrLn screen++-- | Input key via the frontend.+nextEvent :: FrontendSession -> IO K.Key+nextEvent sess = do+  e <- BS.hGet SIO.stdin 1+  let c = BS.head e+  if c == '\n'  -- let \n mark the end of input, for human players+    then nextEvent sess+    else return $ keyTranslate c++-- HACK: Special translation that block commands the bots should not use+-- and multiplies some other commands.+keyTranslate :: Char -> K.Key+keyTranslate e =+  case e of+    -- Translate some special keys (use vi keys to move).+    '\ESC' -> K.Esc+    '\n'   -> K.Return+    '\r'   -> K.Return+    '\t'   -> K.Tab+    --  For bots: disable purely UI commands.+    'P'    -> K.Char 'U'+    'V'    -> K.Char 'Y'+    'O'    -> K.Char 'J'+    'I'    -> K.Char 'L'+    'R'    -> K.Char 'K'+    '?'    -> K.Char 'N'+    -- For bots: don't let them give up, write files, procrastinate.+    'Q'    -> K.Char 'H'+    'X'    -> K.Char 'B'+    'D'    -> K.Return+    '.'    -> K.Return+    -- For bots (assuming they go from '0' to 'z'): major commands.+    '<'    -> K.Char 'q'  -- ban ascending to speed up descending+    '>'    -> K.Char '>'+    'c'    -> K.Char 'c'+    'd'    -> K.Char 'r'  -- don't let bots drop stuff+    'g'    -> K.Char 'g'+    'i'    -> K.Char 'i'+    'o'    -> K.Char 'o'+    'q'    -> K.Char 'q'+    'r'    -> K.Char 'r'+    't'    -> K.Char 'g'  -- tagetting is too hard, so don't throw+    'z'    -> K.Char 'g'  -- and don't zap+    'p'    -> K.Char 'g'  -- and don't project+    'a'    -> K.Esc       -- and don't apply+    -- For bots: minor commands. Targeting is too hard, so don't do it.+    '*'    -> K.Char 'c'+    '/'    -> K.Char 'c'+    '['    -> K.Char 'g'+    ']'    -> K.Char 'g'+    '{'    -> K.Char 'g'+    '}'    -> K.Char 'g'+    -- Hack for bots: dump config at the start.+    ' '    -> K.Char 'D'+    -- Movement and hero selection.+    c | c `elem` "kjhlyubnKJHLYUBN" -> K.Char c+    c | c `elem` ['0'..'9'] -> K.Char c+    _      -> K.Char '>'  -- try hard to descend
+ Game/LambdaHack/Display/Vty.hs view
@@ -0,0 +1,117 @@+-- | Text frontend based on Vty.+module Game.LambdaHack.Display.Vty+  ( -- * Session data type for the frontend+    FrontendSession+    -- * The output and input operations+  , display, nextEvent+    -- * Frontend administration tools+  , frontendName, startup, shutdown+  ) where++import Graphics.Vty hiding (shutdown)+import qualified Graphics.Vty as Vty+import qualified Data.List as L+import qualified Data.ByteString.Char8 as BS++import Game.LambdaHack.Area+import Game.LambdaHack.PointXY+import qualified Game.LambdaHack.Key as K (Key(..))+import qualified Game.LambdaHack.Color as Color++-- | Session data maintained by the frontend.+type FrontendSession = Vty++-- | The name of the frontend.+frontendName :: String+frontendName = "vty"++-- | Starts the main program loop using the frontend input and output.+startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup _ k = mkVty >>= k++-- | Shuts down the frontend cleanly.+shutdown :: FrontendSession -> IO ()+shutdown = Vty.shutdown++-- | Output to the screen via the frontend.+display :: Area             -- ^ the size of the drawn area+        -> FrontendSession  -- ^ current session data+        -> (PointXY -> (Color.Attr, Char))+                            -- ^ the content of the screen+        -> String           -- ^ an extra line to show at the top+        -> String           -- ^ an extra line to show at bottom+        -> IO ()+display (x0, y0, x1, y1) vty f msg status =+  let img = (foldr (<->) empty_image .+             L.map (foldr (<|>) empty_image .+                    L.map (\ (x, y) -> let (a, c) = f (PointXY (x, y))+                                       in char (setAttr a) c)))+            [ [ (x, y) | x <- [x0..x1] ] | y <- [y0..y1] ]+      pic = pic_for_image $+              utf8_bytestring (setAttr Color.defaultAttr) (BS.pack msg)+              <-> img <->+              utf8_bytestring (setAttr Color.defaultAttr) (BS.pack status)+  in update vty pic++-- | Input key via the frontend.+nextEvent :: FrontendSession -> IO K.Key+nextEvent sess = do+  e <- next_event sess+  return (keyTranslate e)++keyTranslate :: Event -> K.Key+keyTranslate e =+  case e of+    EvKey KEsc []          -> K.Esc+    EvKey KEnter []        -> K.Return+    EvKey (KASCII ' ') []  -> K.Space+    EvKey (KASCII '\t') [] -> K.Tab+    EvKey KUp []           -> K.Up+    EvKey KDown []         -> K.Down+    EvKey KLeft []         -> K.Left+    EvKey KRight []        -> K.Right+    EvKey KHome []         -> K.Home+    EvKey KPageUp []       -> K.PgUp+    EvKey KEnd []          -> K.End+    EvKey KPageDown []     -> K.PgDn+    EvKey KBegin []        -> K.Begin+    -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8+    -- For now, movement keys are more important than hero selection:+    EvKey (KASCII c) []+      | c `elem` ['1'..'9']  -> K.KP c+      | otherwise            -> K.Char c+    _                        -> K.Unknown (show e)++-- A hack to get bright colors via the bold attribute. Depending on terminal+-- settings this is needed or not and the characters really get bold or not.+-- HSCurses does this by default, but in Vty you have to request the hack.+hack :: Color.Color -> Attr -> Attr+hack c a = if Color.isBright c then with_style a bold else a++setAttr :: Color.Attr -> Attr+setAttr Color.Attr{fg, bg} =+-- This optimization breaks display for white background terminals:+--  if (fg, bg) == Color.defaultAttr+--  then def_attr+--  else+  hack fg $ hack bg $+    def_attr { attr_fore_color = SetTo (aToc fg)+             , attr_back_color = SetTo (aToc bg) }++aToc :: Color.Color -> Color+aToc Color.Black     = black+aToc Color.Red       = red+aToc Color.Green     = green+aToc Color.Brown     = yellow+aToc Color.Blue      = blue+aToc Color.Magenta   = magenta+aToc Color.Cyan      = cyan+aToc Color.White     = white+aToc Color.BrBlack   = bright_black+aToc Color.BrRed     = bright_red+aToc Color.BrGreen   = bright_green+aToc Color.BrYellow  = bright_yellow+aToc Color.BrBlue    = bright_blue+aToc Color.BrMagenta = bright_magenta+aToc Color.BrCyan    = bright_cyan+aToc Color.BrWhite   = bright_white
+ Game/LambdaHack/Dungeon.hs view
@@ -0,0 +1,81 @@+-- | The game arena comprised of levels. No operation in this module+-- involves the 'State', 'COps', 'Config' or 'Action' type.+module Game.LambdaHack.Dungeon+  ( -- * Level identifier+    LevelId, levelNumber, levelDefault+    -- * Dungeon+  , Dungeon, fromList, currentFirst, adjust, (!), lookup, depth+  ) where++import Prelude hiding (lookup)+import Data.Binary+import qualified Data.Map as M+import qualified Data.List as L++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Level++-- | Level ids are, for now, ordered linearly by depth.+newtype LevelId = LambdaCave Int+  deriving (Show, Eq, Ord)++instance Binary LevelId where+  put (LambdaCave n) = put n+  get = fmap LambdaCave get++-- | Depth of a level.+levelNumber :: LevelId -> Int+levelNumber (LambdaCave n) = n++-- | Default level for a given depth.+levelDefault :: Int -> LevelId+levelDefault = LambdaCave++-- | The complete dungeon is a map from level names to levels.+data Dungeon = Dungeon+  { dungeonLevelMap :: M.Map LevelId Level+  , dungeonDepth :: Int  -- can be different than the number of levels+  }+  deriving Show++instance Binary Dungeon where+  put Dungeon{..} = do+    put (M.toAscList dungeonLevelMap)+    put dungeonDepth+  get = do+    lvls <- get+    let dungeonLevelMap = M.fromDistinctAscList lvls+    dungeonDepth <- get+    return Dungeon{..}++-- | Create a dungeon from a list of levels and maximum depth.+-- The depth is only a danger indicator;+-- there may potentially be multiple levels+-- with the same depth.+fromList :: [(LevelId, Level)] -> Int -> Dungeon+fromList lvls d = assert (d <= L.length lvls `blame` (d, L.length lvls)) $+  Dungeon (M.fromList lvls) d++-- | Association list corresponding to the dungeon.+-- Starts at the supplied level id (usually the current level)+-- to try to speed up the searches and keep the dungeon lazy.+currentFirst :: LevelId -> Dungeon -> [(LevelId, Level)]+currentFirst lid (Dungeon m _) =+  (lid, m M.! lid)+  : L.filter ((/= lid) . fst) (M.assocs m)++-- | Adjust the level at a given id.+adjust :: (Level -> Level) -> LevelId -> Dungeon -> Dungeon+adjust f lid (Dungeon m d) = Dungeon (M.adjust f lid m) d++-- | Find a level with the given id.+(!) :: Dungeon -> LevelId -> Level+(!) (Dungeon m _) lid = m M.! lid++-- | Try to look up a level with the given id.+lookup :: LevelId -> Dungeon -> Maybe Level+lookup lid (Dungeon m _) = M.lookup lid m++-- | Maximum depth of the dungeon.+depth :: Dungeon -> Int+depth = dungeonDepth
+ Game/LambdaHack/DungeonState.hs view
@@ -0,0 +1,174 @@+-- | Dungeon operations that require 'State', 'Kind.COps'+-- or 'Config.Config' type.+module Game.LambdaHack.DungeonState+  ( -- * Dungeon generation+    FreshDungeon(..), generate+    -- * Dungeon travel+  , whereTo+  ) where++import qualified System.Random as R+import qualified Data.List as L+import qualified Control.Monad.State as MState+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Point+import Game.LambdaHack.Level+import qualified Game.LambdaHack.Dungeon as Dungeon+import Game.LambdaHack.Random+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.State+import qualified Game.LambdaHack.Feature as F+import qualified Game.LambdaHack.Tile as Tile+import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Cave hiding (TileMapXY)+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Item+import Game.LambdaHack.PointXY+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Place+import qualified Game.LambdaHack.Effect as Effect+import Game.LambdaHack.Content.ItemKind++convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY+                -> Rnd TileMap+convertTileMaps cdefTile cxsize cysize lmap = do+  let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1))+      assocs = map (\ (xy, t) -> (toPoint cxsize xy, t)) (M.assocs lmap)+  pickedTiles <- replicateM (cxsize * cysize) cdefTile+  return $ Kind.listArray bounds pickedTiles Kind.// assocs++unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap+unknownTileMap unknownId cxsize cysize =+  let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1))+  in Kind.listArray bounds (repeat unknownId)++mapToIMap :: X -> M.Map PointXY a -> IM.IntMap a+mapToIMap cxsize m =+  IM.fromList $ map (\ (xy, a) -> (toPoint cxsize xy, a)) (M.assocs m)++rollItems :: Kind.COps -> Int -> Int -> CaveKind -> TileMap -> Point+          -> Rnd [(Point, Item)]+rollItems Kind.COps{cotile, coitem=coitem@Kind.Ops{okind}}+          lvl depth CaveKind{cxsize, citemNum, cminStairDist} lmap ploc = do+  nri <- rollDice citemNum+  replicateM nri $ do+    item <- newItem coitem lvl depth+    let ik = okind (jkind item)+    l <- case ieffect ik of+           Effect.Wound dice | maxDice dice > 0  -- a weapon+                               && maxDice dice + maxDeep (ipower ik) > 3 ->+             -- Powerful weapons generated close to monsters, MUAHAHAHA.+             findLocTry 20 lmap  -- 20 only, for unpredictability+               [ \ l _ -> chessDist cxsize ploc l > cminStairDist+               , \ l _ -> chessDist cxsize ploc l > 2 * cminStairDist `div` 3+               , \ l _ -> chessDist cxsize ploc l > cminStairDist `div` 2+               , \ l _ -> chessDist cxsize ploc l > cminStairDist `div` 3+               , const (Tile.hasFeature cotile F.Boring)+               ]+           _ -> findLoc lmap (const (Tile.hasFeature cotile F.Boring))+    return (l, item)++placeStairs :: Kind.Ops TileKind -> TileMap -> X -> Int -> [Place]+            -> Rnd (Point, Kind.Id TileKind, Point, Kind.Id TileKind)+placeStairs cotile@Kind.Ops{opick} cmap cxsize cminStairDist dplaces = do+  su <- findLoc cmap (const (Tile.hasFeature cotile F.Boring))+  sd <- findLocTry 1000 cmap+          [ \ l _ -> chessDist cxsize su l >= cminStairDist+          , \ l _ -> chessDist cxsize su l >= cminStairDist `div` 2+          , \ l t -> l /= su && Tile.hasFeature cotile F.Boring t+          ]+  let fitArea loc = inside cxsize loc . qarea+      findLegend loc = maybe "litLegend" qlegend $ L.find (fitArea loc) dplaces+  upId   <- opick (findLegend su) $ Tile.kindHasFeature F.Ascendable+  downId <- opick (findLegend sd) $ Tile.kindHasFeature F.Descendable+  return (su, upId, sd, downId)++-- | Create a level from a cave, from a cave kind.+buildLevel :: Kind.COps -> Cave -> Int -> Int -> Rnd Level+buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, ouniqGroup}+                         , cocave=Kind.Ops{okind} }+           Cave{..} lvl depth = do+  let cfg@CaveKind{..} = okind dkind+  cmap <- convertTileMaps (opick cdefTile (const True)) cxsize cysize dmap+  (su, upId, sd, downId) <-+    placeStairs cotile cmap cxsize cminStairDist dplaces+  let stairs = (su, upId) : if lvl == depth then [] else [(sd, downId)]+      lmap = cmap Kind.// stairs+  is <- rollItems cops lvl depth cfg lmap su+  -- TODO: split this into Level.defaultLevel+  let itemMap = mapToIMap cxsize ditem `IM.union` IM.fromList is+      litem = IM.map (\ i -> ([i], [])) itemMap+      unknownId = ouniqGroup "unknown space"+      level = Level+        { lheroes = IM.empty+        , lheroItem = IM.empty+        , lxsize = cxsize+        , lysize = cysize+        , lmonsters = IM.empty+        , lmonItem = IM.empty+        , lsmell = IM.empty+        , lsecret = mapToIMap cxsize dsecret+        , litem+        , lmap+        , lrmap = unknownTileMap unknownId cxsize cysize+        , ldesc = cname+        , lmeta = dmeta+        , lstairs = (su, sd)+        }+  return level++matchGenerator :: Kind.Ops CaveKind -> Maybe String -> Rnd (Kind.Id CaveKind)+matchGenerator Kind.Ops{opick} mname =+  opick (fromMaybe "dng" mname) (const True)++findGenerator :: Kind.COps -> Config.CP -> Int -> Int -> Rnd Level+findGenerator cops config k depth = do+  let ln = "LambdaCave_" ++ show k+      genName = Config.getOption config "dungeon" ln+  ci <- matchGenerator (Kind.cocave cops) genName+  cave <- buildCave cops k depth ci+  buildLevel cops cave k depth++-- | Freshly generated and not yet populated dungeon.+data FreshDungeon = FreshDungeon+  { entryLevel   :: Dungeon.LevelId  -- ^ starting level for the party+  , entryLoc     :: Point            -- ^ starting location for the party+  , freshDungeon :: Dungeon.Dungeon  -- ^ level maps+  }++-- | Generate the dungeon for a new game.+generate :: Kind.COps -> Config.CP -> Rnd FreshDungeon+generate cops config =+  let depth = Config.get config "dungeon" "depth"+      gen :: R.StdGen -> Int -> (R.StdGen, (Dungeon.LevelId, Level))+      gen g k =+        let (g1, g2) = R.split g+            res = MState.evalState (findGenerator cops config k depth) g1+        in (g2, (Dungeon.levelDefault k, res))+      con :: R.StdGen -> (FreshDungeon, R.StdGen)+      con g =+        let (gd, levels) = L.mapAccumL gen g [1..depth]+            entryLevel = Dungeon.levelDefault 1+            entryLoc = fst (lstairs (snd (head levels)))+            freshDungeon = Dungeon.fromList levels depth+        in (FreshDungeon{..}, gd)+  in MState.state con++-- | Compute the level identifier and starting location on the level,+-- after a level change.+whereTo :: State  -- ^ game state+        -> Int    -- ^ jump this many levels+        -> Maybe (Dungeon.LevelId, Point)+             -- ^ target level and the location of its receiving stairs+whereTo State{slid, sdungeon} k = assert (k /= 0) $+  let n = Dungeon.levelNumber slid+      nln = n - k+      ln = Dungeon.levelDefault nln+  in case Dungeon.lookup ln sdungeon of+    Nothing     -> Nothing+    Just lvlTrg -> Just (ln, (if k < 0 then fst else snd) (lstairs lvlTrg))
+ Game/LambdaHack/Effect.hs view
@@ -0,0 +1,57 @@+-- | Effects of content on other content. No operation in this module+-- involves the 'State' or 'Action' type.+module Game.LambdaHack.Effect+  ( Effect(..), effectToSuffix, effectToBenefit+  ) where++import Game.LambdaHack.Random++-- TODO: document each constructor+-- | All possible effects, some of them parameterized or dependent+-- on outside coefficients, e.g., item power.+data Effect =+    NoEffect+  | Heal             -- healing strength in ipower+  | Wound !RollDice  -- base damage, to-dam bonus in ipower+  | Dominate+  | SummonFriend+  | SummonEnemy+  | ApplyPerfume+  | Regeneration+  | Searching+  | Ascend+  | Descend+  deriving (Show, Read, Eq, Ord)++-- | Suffix to append to a basic content name, if the content causes the effect.+effectToSuffix :: Effect -> String+effectToSuffix NoEffect = ""+effectToSuffix Heal = "of healing"+effectToSuffix (Wound dice@(RollDice a b)) =+  if a == 0 && b == 0+  then "of wounding"+  else "(" ++ show dice ++ ")"+effectToSuffix Dominate = "of domination"+effectToSuffix SummonFriend = "of aid calling"+effectToSuffix SummonEnemy = "of summoning"+effectToSuffix ApplyPerfume = "of rose water"+effectToSuffix Regeneration = "of regeneration"+effectToSuffix Searching = "of searching"+effectToSuffix Ascend = "of ascending"+effectToSuffix Descend = "of descending"++-- | How much AI benefits from applying the effect. Multipllied by item power.+-- Negative means harm to the enemy when thrown at him. Effects with zero+-- benefit won't ever be used, neither actively nor passively.+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 Regeneration = 0    -- much more benefit from carrying around+effectToBenefit Searching = 0       -- AI does not need to search+effectToBenefit Ascend = 0          -- AI can't change levels+effectToBenefit Descend = 0
+ Game/LambdaHack/EffectAction.hs view
@@ -0,0 +1,507 @@+-- | The effectToAction function and all it depends on.+-- This file should not depend on Actions.hs nor ItemAction.hs.+-- TODO: Add an export list and document after it's rewritten according to #17.+module Game.LambdaHack.EffectAction where++-- Cabal+import qualified Paths_LambdaHack as Self (version)++import Control.Monad+import Control.Monad.State hiding (State, state)+import Data.Function+import Data.Version+import Data.Maybe+import qualified Data.List as L+import qualified Data.IntMap as IM+import qualified Data.Set as S+import qualified Data.IntSet as IS+import System.Time++import Game.LambdaHack.Misc+import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Action+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Display+import Game.LambdaHack.Grammar+import Game.LambdaHack.Point+import qualified Game.LambdaHack.HighScore as H+import Game.LambdaHack.Item+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Level+import Game.LambdaHack.Msg+import Game.LambdaHack.Perception+import Game.LambdaHack.Random+import Game.LambdaHack.State+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Effect as Effect+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.DungeonState+import qualified Game.LambdaHack.Save as Save++-- TODO: instead of verbosity return msg components and tailor them outside?+-- TODO: separately define messages for the case when source == target+-- and for the other case; then use the messages outside of effectToAction,+-- depending on the returned bool, perception and identity of the actors.++-- | The source actor affects the target actor, with a given effect and power.+-- The second argument is verbosity of the resulting message.+-- Both actors are on the current level and can be the same actor.+-- The bool result indicates if the actors identify the effect.+effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int+               -> Action (Bool, String)+effectToAction Effect.NoEffect _ _ _ _ = nullEffect+effectToAction Effect.Heal _ _source target power = do+  coactor@Kind.Ops{okind} <- contentf Kind.coactor+  let bhpMax m = maxDice (ahp $ okind $ bkind m)+  tm <- gets (getActor target)+  if bhp tm >= bhpMax tm || power <= 0+    then nullEffect+    else do+      focusIfAHero target+      updateAnyActor target (addHp coactor power)  -- TODO: duplicate code in  bhpMax and addHp+      return (True, actorVerbExtra coactor tm "feel" "better")+effectToAction (Effect.Wound nDm) verbosity source target power = do+  coactor <- contentf Kind.coactor+  pl <- gets splayer+  n  <- rndToAction $ rollDice nDm+  if n + power <= 0 then nullEffect else do+    focusIfAHero target+    tm <- gets (getActor target)+    let newHP  = bhp tm - n - power+        killed = newHP <= 0+        msg+          | killed =+            if isAHero target || target == pl+            then ""  -- handled later on in checkPartyDeath+            else actorVerb coactor tm "die"+          | source == target =  -- a potion of wounding, etc.+            actorVerbExtra coactor tm "feel" "wounded"+          | verbosity <= 0 = ""+          | isAHero target || target == pl =+            actorVerbExtra coactor tm "lose" $+              show (n + power) ++ "HP"+          | otherwise = actorVerbExtra coactor tm "hiss" "in pain"+    updateAnyActor target $ \ m -> m { bhp = newHP }  -- Damage the target.+    when killed $ do+      -- Place the actor's possessions on the map.+      bitems <- gets (getActorItem target)+      modify (updateLevel (dropItemsAt bitems (bloc tm)))+      -- Clean bodies up.+      if target == pl+        then checkPartyDeath  -- kills the player and checks game over+        else modify (deleteActor target)  -- kills the enemy+    return (True, msg)+effectToAction Effect.Dominate _ source target _power+  | isAMonster target = do  -- Monsters have weaker will than heroes.+    selectPlayer target+      >>= assert `trueM` (source, target, "player dominates himself")+    -- Prevent AI from getting a few free moves until new player ready.+    updatePlayerBody (\ m -> m { btime = 0})+    displayAll+    return (True, "")+  | source == target = do+    lm <- gets (lmonsters . slevel)+    lxsize <- gets (lxsize . slevel)+    lysize <- gets (lysize . slevel)+    let cross m = bloc m : vicinityCardinal lxsize lysize (bloc m)+        vis = L.concatMap cross $ IM.elems lm+    rememberList vis+    return (True, "A dozen voices yells in anger.")+  | otherwise = nullEffect+effectToAction Effect.SummonFriend _ source target power = do+  tm <- gets (getActor target)+  if isAHero source+    then summonHeroes (1 + power) (bloc tm)+    else summonMonsters (1 + power) (bloc 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) (bloc tm)+    else summonMonsters (1 + power) (bloc 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 = IM.empty }+    modify (updateLevel upd)+    return (True, "The fragrance quells all scents in the vicinity.")+effectToAction Effect.Regeneration verbosity source target power =+  effectToAction Effect.Heal verbosity source target power+effectToAction Effect.Searching _ _source _target _power =+  return (True, "It gets lost and you search in vain.")+effectToAction Effect.Ascend _ source target power = do+  coactor <- contentf Kind.coactor+  tm <- gets (getActor target)+  if isAMonster target+    then squashActor source target+    else effLvlGoUp (power + 1)+  -- TODO: The following message too late if a monster squashed:+  return (True, actorVerbExtra coactor tm "find" "a shortcut upstrairs")+effectToAction Effect.Descend _ source target power = do+  coactor <- contentf Kind.coactor+  tm <- gets (getActor target)+  if isAMonster target+    then squashActor source target+    else effLvlGoUp (- (power + 1))+  -- TODO: The following message too late if a monster squashed:+  return (True, actorVerbExtra coactor tm "find" "a shortcut downstairs")++nullEffect :: Action (Bool, String)+nullEffect = return (False, "Nothing happens.")++-- TODO: refactor with actorAttackActor.+squashActor :: ActorId -> ActorId -> Action ()+squashActor source target = do+  Kind.COps{coactor, coitem=Kind.Ops{okind, ouniqGroup}} <- contentOps+  sm <- gets (getActor source)+  tm <- gets (getActor target)+  let h2hKind = ouniqGroup "weight"+      power = maxDeep $ ipower $ okind h2hKind+      h2h = Item h2hKind power Nothing 1+      verb = iverbApply $ okind h2hKind+      msg = actorVerbActorExtra coactor sm verb tm " in a staircase accident"+  msgAdd msg+  itemEffectAction 0 source target h2h+    >>= assert `trueM` (source, target, "affected")++effLvlGoUp :: Int -> Action ()+effLvlGoUp k = do+  targeting <- gets (ctargeting . scursor)+  pbody     <- gets getPlayerBody+  pl        <- gets splayer+  slid      <- gets slid+  st        <- get+  case whereTo st k of+    Nothing -> do -- we are at the "end" of the dungeon+      b <- msgYesNo "Really escape the dungeon?"+      if b+        then fleeDungeon+        else abortWith "Game resumed."+    Just (nln, nloc) ->+      assert (nln /= slid `blame` (nln, "stairs looped")) $+      tryWith (abortWith "somebody blocks the staircase") $ do+        bitems <- gets getPlayerItem+        -- Remember the level (e.g., for a teleport via scroll on the floor).+        remember+        -- Remove the player from the old level.+        modify (deleteActor pl)+        hs <- gets levelHeroList+        -- Monsters hear that players not on the level. Cancel smell.+        -- Reduces memory load and savefile size.+        when (L.null hs) $+          modify (updateLevel (updateSmell (const IM.empty)))+        -- At this place the invariant that the player exists fails.+        -- Change to the new level (invariant not needed).+        modify (\ s -> s {slid = nln})+        -- Add the player to the new level.+        modify (insertActor pl pbody)+        modify (updateAnyActorItem pl (const bitems))+        -- At this place the invariant is restored again.+        inhabitants <- gets (locToActor nloc)+        case inhabitants of+          Nothing -> return ()+          Just h | isAHero h ->+            -- Bail out if a party member blocks the staircase.+            abort+          Just m ->+            -- Somewhat of a workaround: squash monster blocking the staircase.+            squashActor pl m+        -- Verify the monster on the staircase died.+        inhabitants2 <- gets (locToActor nloc)+        when (isJust inhabitants2) $ assert `failure` inhabitants2+        -- Land the player at the other end of the stairs.+        updatePlayerBody (\ p -> p { bloc = nloc })+        -- Change the level of the player recorded in cursor.+        modify (updateCursor (\ c -> c { creturnLn = nln }))+        -- The invariant "at most one actor on a tile" restored.+        -- Create a backup of the savegame.+        state <- get+        diary <- currentDiary+        liftIO $ Save.saveGameBkp state diary+        when (targeting /= TgtOff) doLook  -- TODO: lags behind perception++-- | The player leaves the dungeon.+fleeDungeon :: Action ()+fleeDungeon = do+  coitem <- contentf Kind.coitem+  state <- get+  let total = calculateTotal coitem state+      items = L.concat $ IM.elems $ lheroItem $ slevel state+  if total == 0+    then do+      go <- msgClear >> msgMoreConfirm ColorFull "Coward!"+      when go $+        msgMore "Next time try to grab some loot before escape!"+      end+    else do+      let winMsg = "Congratulations, you won! Your loot, worth " +++                   show total ++ " gold, is:"  -- TODO: use the name of the '$' item instead+      displayItems winMsg True items+      go <- session getConfirm+      when go $ do+        go2 <- handleScores True H.Victor total+        when go2 $ msgMore "Can it be done better, though?"+      end++-- | The source actor affects the target actor, with a given item.+-- If the event is seen, the item may get identified.+itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool+itemEffectAction verbosity source target item = do+  Kind.Ops{okind} <- contentf Kind.coitem+  sm  <- gets (getActor source)+  tm  <- gets (getActor target)+  per <- currentPerception+  pl  <- gets splayer+  let effect = ieffect $ okind $ jkind item+  -- The msg describes the target part of the action.+  (b, msg) <- effectToAction effect verbosity source target (jpower item)+  if isAHero source || isAHero target || pl == source || pl == target ||+     (bloc tm `IS.member` totalVisible per &&+      bloc sm `IS.member` totalVisible per)+    then do+      -- Party sees or affected, so reported.+      msgAdd msg+      -- Party sees or affected, so if interesting, the item gets identified.+      when b $ discover item+    else+      -- Hidden, but if interesting then heard.+      when b $ msgAdd "You hear some noises."+  return b++-- | Make the item known to the player.+discover :: Item -> Action ()+discover i = do+  cops@Kind.Ops{okind} <- contentf Kind.coitem+  state <- get+  let ik = jkind i+      obj = unwords $ tail $ words $ objectItem cops state i+      msg = "The " ++ obj ++ " turns out to be "+      kind = okind ik+      alreadyIdentified = L.length (iflavour kind) == 1+                          || ik `S.member` sdisco state+  unless alreadyIdentified $ do+    modify (updateDiscoveries (S.insert ik))+    state2 <- get+    msgAdd $ msg ++ objectItem cops state2 i ++ "."++-- | Make the actor controlled by the player.+-- Focus on the actor if level changes. False, if nothing to do.+selectPlayer :: ActorId -> Action Bool+selectPlayer actor = do+  coactor <- contentf Kind.coactor+  pl <- gets splayer+  targeting <- gets (ctargeting . scursor)+  if actor == pl+    then return False -- already selected+    else do+      state <- get+      when (absentHero actor state) $ abortWith "No such member of the party."+      let (nln, pbody, _) = findActorAnyLevel actor state+      -- Make the new actor the player-controlled actor.+      modify (\ s -> s { splayer = actor })+      -- Record the original level of the new player.+      modify (updateCursor (\ c -> c { creturnLn = nln }))+      -- Don't continue an old run, if any.+      stopRunning+      -- Switch to the level.+      modify (\ s -> s{slid = nln})+      -- Announce.+      msgAdd $ capActor coactor pbody ++ " selected."+      when (targeting /= TgtOff) doLook+      return True++focusIfAHero :: ActorId -> Action ()+focusIfAHero target =+  when (isAHero target) $ do+    -- Focus on the hero being wounded/displaced/etc.+    b <- selectPlayer target+    -- Display status line for the new hero.+    when b $ void displayAll++summonHeroes :: Int -> Point -> Action ()+summonHeroes n loc =+  assert (n > 0) $ do+  cops <- contentOps+  newHeroId <- gets (fst . scounter)+  modify (\ state -> iterate (addHero cops loc) state !! n)+  selectPlayer (AHero newHeroId)+    >>= assert `trueM` (newHeroId, "player summons himself")+  -- Display status line for the new hero.+  void displayAll++summonMonsters :: Int -> Point -> Action ()+summonMonsters n loc = do+  Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} <- contentOps+  mk <- rndToAction $ opick "summon" (const True)+  hp <- rndToAction $ rollDice $ ahp $ okind mk+  modify (\ state ->+           iterate (addMonster cotile mk hp loc) state !! n)++-- | Update player memory.+remember :: Action ()+remember = do+  per <- currentPerception+  let vis = IS.toList (totalVisible per)+  rememberList vis++rememberList :: [Point] -> Action ()+rememberList vis = do+  lvl <- gets slevel+  let rememberTile = [(loc, lvl `at` loc) | loc <- vis]+  modify (updateLevel (updateLRMap (Kind.// rememberTile)))+  let alt Nothing      = Nothing+      alt (Just ([], _)) = Nothing+      alt (Just (t, _))  = Just (t, t)+      rememberItem = IM.alter alt+  modify (updateLevel (updateIMap (\ m -> L.foldr rememberItem m vis)))++-- | Remove dead heroes (or dead dominated monsters). Check if game is over.+-- For now we only check the selected hero and at current level,+-- but if poison, etc. is implemented, we'd need to check all heroes+-- on any level.+checkPartyDeath :: Action ()+checkPartyDeath = do+  cops   <- contentf Kind.coactor+  ahs    <- gets allHeroesAnyLevel+  pl     <- gets splayer+  pbody  <- gets getPlayerBody+  config <- gets sconfig+  when (bhp pbody <= 0) $ do  -- TODO: change to guard? define mzero as abort? Why are the writes to the files performed when I call abort later? That probably breaks the laws of MonadPlus. Or is the tryWith abort handler placed after the write to files?+    go <- msgMoreConfirm ColorBW $ actorVerb cops pbody "die"+    history  -- Prevent the msgs from being repeated.+    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+               msgAdd "The survivors carry on."+               -- One last look at the beautiful world.+               remember+               -- Remove the dead player.+               modify deletePlayer+               -- At this place the invariant that the player exists fails.+               -- Focus on the new hero (invariant not needed).+               selectPlayer actor+                 >>= assert `trueM` (pl, actor, "player resurrects")+               -- 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+    cops  <- contentf Kind.coitem+    state <- get+    slid  <- gets slid+    let total = calculateTotal cops state+        status = H.Killed slid+    handleScores True status total+    msgMore "Let's hope another party can save the day!"+  end++-- | Handle current score and display it with the high scores.+-- False if display of the scores was void or interrupted by the user.+--+-- Warning: scores are shown during the game,+-- so we should be careful not to leak secret information through them+-- (e.g., the nature of the items through the total worth of inventory).+handleScores :: Bool -> H.Status -> Int -> Action Bool+handleScores write status total =+  if total == 0+  then return False+  else do+    config  <- gets sconfig+    time    <- gets stime+    curDate <- liftIO getClockTime+    let points = case status of+                   H.Killed _ -> (total + 1) `div` 2+                   _ -> total+    let score = H.ScoreRecord points (-time) curDate status+    (placeMsg, slideshow) <- liftIO $ H.register config write score+    msgOverlaysConfirm placeMsg slideshow+    session getConfirm++-- effectToAction does not depend on this function right now, but it might,+-- and I know no better place to put it.+displayItems :: Msg -> Bool -> [Item] -> Action Bool+displayItems msg sorted is = do+  cops  <- contentf Kind.coitem+  state <- get+  let inv = unlines $+            L.map (\ i -> letterLabel (jletter i)+                          ++ objectItem cops state i ++ " ")+              ((if sorted+                then L.sortBy (cmpLetterMaybe `on` jletter)+                else id) is)+  let ovl = inv ++ msgEnd+  msgReset msg+  overlay ovl++stopRunning :: Action ()+stopRunning = updatePlayerBody (\ p -> p { bdir = Nothing })++-- | Store current msg in the history and reset current msg.+history :: Action ()+history = do+  msg <- currentMsg+  msgClear+  config <- gets sconfig+  let historyMax = Config.get config "ui" "historyMax"+      -- TODO: not ideal, continuations of sentences are atop beginnings.+      splitS = splitMsg (fst normalLevelBound + 1) msg 0+      takeMax diary =+        take historyMax $+          L.map (padMsg (fst normalLevelBound + 1)) splitS ++ shistory diary+  unless (L.null msg) $ do+    diary <- currentDiary+    diaryReset $ diary {shistory = takeMax diary}++-- TODO: depending on tgt, show extra info about tile or monster or both+-- | Perform look around in the current location of the cursor.+doLook :: Action ()+doLook = do+  cops@Kind.COps{coactor} <- contentOps+  loc    <- gets (clocation . scursor)+  state  <- get+  lvl    <- gets slevel+  per    <- currentPerception+  target <- gets (btarget . getPlayerBody)+  pl     <- gets splayer+  let canSee = IS.member loc (totalVisible per)+      monsterMsg =+        if canSee+        then case L.find (\ m -> bloc m == loc) (levelMonsterList state) of+               Just m  -> actorVerbExtra coactor m "be" "here" ++ " "+               Nothing -> ""+        else ""+      vis | not $ loc `IS.member` totalVisible per =+              " (not visible)"  -- by party+          | actorReachesLoc pl loc per (Just pl) = ""+          | otherwise = " (not reachable)"  -- by hero+      mode = case target of+               TEnemy _ _ -> "[targeting monster" ++ vis ++ "] "+               TLoc _     -> "[targeting location" ++ vis ++ "] "+               TCursor    -> "[targeting current" ++ vis ++ "] "+      -- general info about current loc+      lookMsg = mode ++ lookAt cops True canSee state lvl loc monsterMsg+      -- check if there's something lying around at current loc+      is = lvl `rememberAtI` loc+  if length is <= 2+    then msgAdd lookMsg+    else do+      displayItems lookMsg False is+      session getConfirm >> msgAdd ""  -- TODO: a hack; instead keep current overlay in the state to keep it from being overwritten on the screen in Turn.hs, just as msg is kept, and reset each turn++gameVersion :: Action ()+gameVersion = do+  Kind.COps{corule} <- contentOps+  let pathsVersion = rpathsVersion $ stdRuleset corule+      msg = "Version " ++ showVersion pathsVersion+            ++ " (frontend: " ++ frontendName+            ++ ", engine: LambdaHack " ++ showVersion Self.version ++ ")"+  abortWith msg
+ Game/LambdaHack/FOV.hs view
@@ -0,0 +1,77 @@+-- | Field Of View scanning with a variety of algorithms.+-- See <https://github.com/kosmikus/LambdaHack/wiki/Fov-and-los>+-- for discussion.+module Game.LambdaHack.FOV+  ( FovMode(..), fullscan+  ) where++import qualified Data.List as L++import Game.LambdaHack.FOV.Common+import qualified Game.LambdaHack.FOV.Digital as Digital+import qualified Game.LambdaHack.FOV.Permissive as Permissive+import qualified Game.LambdaHack.FOV.Shadow as Shadow+import Game.LambdaHack.Point+import Game.LambdaHack.VectorXY+import Game.LambdaHack.Vector+import Game.LambdaHack.Level+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Tile as Tile++-- TODO: should Blind really be a FovMode, or a modifier? Let's decide+-- when other similar modifiers are added.+-- | Field Of View scanning mode.+data FovMode =+    Shadow       -- ^ restrictive shadow casting+  | Permissive   -- ^ permissive FOV+  | Digital Int  -- ^ digital FOV with the given radius+  | Blind        -- ^ only feeling out adjacent tiles by touch+  deriving Show++-- | Perform a full scan for a given location. Returns the locations+-- that are currently in the field of view. The Field of View+-- algorithm to use, passed in the second argument, is set in the config file.+fullscan :: Kind.Ops TileKind  -- ^ tile content, determines clear tiles+         -> FovMode            -- ^ scanning mode+         -> Point              -- ^ location of the spectacor+         -> Level              -- ^ the map that is scanned+         -> [Point]+fullscan cotile fovMode loc Level{lxsize, lmap} =+  case fovMode of+    Shadow ->+      L.concatMap (\ tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8+    Permissive ->+      L.concatMap (\ tr -> map tr (Permissive.scan (isCl . tr))) tr4+    Digital r ->+      L.concatMap (\ tr -> map tr (Digital.scan r (isCl . tr))) tr4+    Blind ->+      let radiusOne = 1+      in L.concatMap (\ tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4+ where+  isCl :: Point -> Bool+  isCl = Tile.isClear cotile . (lmap Kind.!)++  trV xy = shift loc $ toVector lxsize $ VectorXY xy++  -- | The translation, rotation and symmetry functions for octants.+  tr8 :: [(Distance, Progress) -> Point]+  tr8 =+    [ \ (p, d) -> trV (  p,   d)+    , \ (p, d) -> trV (- p,   d)+    , \ (p, d) -> trV (  p, - d)+    , \ (p, d) -> trV (- p, - d)+    , \ (p, d) -> trV (  d,   p)+    , \ (p, d) -> trV (- d,   p)+    , \ (p, d) -> trV (  d, - p)+    , \ (p, d) -> trV (- d, - p)+    ]++  -- | The translation and rotation functions for quadrants.+  tr4 :: [Bump -> Point]+  tr4 =+    [ \ (B(x, y)) -> trV (  x, - y)  -- quadrant I+    , \ (B(x, y)) -> trV (  y,   x)  -- II (we rotate counter-clockwise)+    , \ (B(x, y)) -> trV (- x,   y)  -- III+    , \ (B(x, y)) -> trV (- y, - x)  -- IV+    ]
+ Game/LambdaHack/FOV/Common.hs view
@@ -0,0 +1,67 @@+-- | Common definitions for the Field of View algorithms.+-- See <https://github.com/kosmikus/LambdaHack/wiki/Fov-and-los>+-- for some more context and references.+module Game.LambdaHack.FOV.Common+  ( -- * Current scan parameters+    Distance, Progress+    -- * Scanning coordinate system+  , Bump(..)+    -- * Geometry in system @Bump@+  , Line, ConvexHull, Edge, EdgeInterval+    -- * Assorted minor operations+  , maximal, steeper, addHull+  ) where++import qualified Data.List as L++import Game.LambdaHack.PointXY++-- | Distance from the (0, 0) point where FOV originates.+type Distance = Int+-- | Progress along an arc with a constant distance from (0, 0).+type Progress = Int++-- | Rotated and translated coordinates of 2D points, so that the points fit+-- in a single quadrant area (e, g., quadrant I for Permissive FOV, hence both+-- coordinates positive; adjacent diagonal halves of quadrant I and II+-- for Digital FOV, hence y positive).+-- The special coordinates are written using the standard mathematical+-- coordinate setup, where quadrant I, with x and y positive,+-- is on the upper right.+newtype Bump = B (X, Y)+  deriving (Show)++-- | Straight line between points.+type Line         = (Bump, Bump)+-- | Convex hull represented as a list of points.+type ConvexHull   = [Bump]+-- | An edge (comprising of a line and a convex hull)+-- of the area to be scanned.+type Edge         = (Line, ConvexHull)+-- | The area left to be scanned, delimited by edges.+type EdgeInterval = (Edge, Edge)++-- | 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 e -> if gte e acc then e else acc)++-- | Check if the line from the second point to the first is more steep+-- than the line from the third point to the first. This is related+-- to the formal notion of gradient (or angle), but hacked wrt signs+-- to work fast in this particular setup. Returns True for ill-defined lines.+steeper :: Bump -> Bump -> Bump -> Bool+steeper (B(xf, yf)) (B(x1, y1)) (B(x2, y2)) =+  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)++-- | Extends a convex hull of bumps with a new bump. Nothing needs to be done+-- if the new bump already lies within the hull. The first argument is+-- typically `steeper`, optionally negated, applied to the second argument.+addHull :: (Bump -> Bump -> Bool)  -- ^ a comparison function+        -> Bump                    -- ^ a new bump to consider+        -> ConvexHull  -- ^ a convex hull of bumps represented as a list+        -> ConvexHull+addHull gte new = (new :) . go+ where+  go (a:b:cs) | gte a b = go (b:cs)+  go l = l
+ Game/LambdaHack/FOV/Digital.hs view
@@ -0,0 +1,142 @@+-- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>.+-- This fast version of the algorithm, based on "PFOV", has AFAIK+-- never been described nor implemented before.+module Game.LambdaHack.FOV.Digital (scan) where++import Game.LambdaHack.Misc+import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.FOV.Common++-- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0),+-- within the given sight range.+scan :: Distance        -- ^ visiblity radius+     -> (Bump -> Bool)  -- ^ clear tile predicate+     -> [Bump]+scan r isClear =+  -- The scanned area is a square, which is a sphere in the chessboard metric.+  dscan 1 (((B(1, 0), B(-r, r)), [B(0, 0)]), ((B(0, 0), B(r+1, r)), [B(1, 0)]))+ where+  dscan :: Distance -> EdgeInterval -> [Bump]+  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+    let ps0 = let (n, k) = intersect sl d  -- minimal progress to consider+              in n `div` k+        pe = let (n, k) = intersect el d   -- maximal progress to consider+               -- Corners obstruct view, so the steep line, constructed+               -- from corners, is itself not a part of the view,+               -- so if its intersection with the line of diagonals is only+               -- at a corner, choose the diamond leading to a smaller view.+             in -1 + n `divUp` k+        inside = [B(p, d) | p <- [ps0..pe]]+        outside+          | d >= r = []+          | isClear (B(ps0, d)) = mscan (Just s0) (ps0+1) pe  -- start in light+          | otherwise = mscan Nothing (ps0+1) pe              -- start in shadow+    in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $+       inside ++ outside+   where+    -- The current state of a scan is kept in @Maybe Edge@.+    -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,+    -- we're in a shadowed interval.+    mscan :: Maybe Edge -> Progress -> Progress -> [Bump]+    mscan (Just s@(_, sBumps)) ps pe+      | ps > pe = dscan (d+1) (s, e)          -- reached end, scan next+      | not $ isClear steepBump =             -- entering shadow+          mscan Nothing (ps+1) pe+          ++ dscan (d+1) (s, (dline nep steepBump, neBumps))+      | otherwise = mscan (Just s) (ps+1) pe  -- continue in light+     where+      steepBump = B(ps, d)+      gte = dsteeper steepBump+      nep = maximal gte sBumps+      neBumps = addHull gte steepBump eBumps++    mscan Nothing ps pe+      | ps > pe = []                          -- reached end while in shadow+      | isClear shallowBump =                 -- moving out of shadow+          mscan (Just (dline nsp shallowBump, nsBumps)) (ps+1) pe+      | otherwise = mscan Nothing (ps+1) pe   -- continue in shadow+     where+      shallowBump = B(ps, d)+      gte = flip $ dsteeper shallowBump+      nsp = maximal gte eBumps+      nsBumps = addHull gte shallowBump sBumps0++-- | Create a line from two points. Debug: check if well-defined.+dline :: Bump -> Bump -> Line+dline p1 p2 =+  assert (uncurry blame $ debugLine (p1, p2)) $+  (p1, p2)++-- | Compare steepness of @(p1, f)@ and @(p2, f)@.+-- Debug: Verify that the results of 2 independent checks are equal.+dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper f p1 p2 =+  assert (res == debugSteeper f p1 p2) $+  res+   where res = steeper f p1 p2++-- | The X coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of diamonds at distance+-- @d@ from (0, 0).+intersect :: Line -> Distance -> (Int, Int)+intersect (B(x, y), B(xf, yf)) d =+  assert (allB (>= 0) [y, yf]) $+  ((d - y)*(xf - x) + x*(yf - y), yf - y)+{-+Derivation of the formula:+The intersection point (xt, yt) 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 restrictive shadow casting algorithm and reversed wrt PFOV.+The line in the curent state of mscan is called the shallow line,+but it's the one that delimits the view from the left, while the steep+line is on the right, opposite to PFOV. We start scanning from the left.++The Point 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 (rotated 45 degrees) quadrant. The (Progress, Distance)+cordinates coincide with the Bump coordinates, unlike in PFOV.+-}++-- | Debug functions for DFOV:++-- | Debug: calculate steeper for DFOV in another way and compare results.+debugSteeper :: Bump -> Bump -> Bump -> Bool+debugSteeper f@(B(_xf, yf)) p1@(B(_x1, y1)) p2@(B(_x2, y2)) =+  assert (allB (>= 0) [yf, y1, y2]) $+  let (n1, k1) = intersect (p1, f) 0+      (n2, k2) = intersect (p2, f) 0+  in n1 * k2 >= k1 * n2++-- | Debug: check is a view border line for DFOV is legal.+debugLine :: Line -> (Bool, String)+debugLine line@(B(x1, y1), B(x2, y2))+  | not (allB (>= 0) [y1, y2]) =+      (False, "negative coordinates: " ++ show line)+  | y1 == y2 && x1 == x2 =+      (False, "ill-defined line: " ++ show line)+  | y1 == y2 =+      (False, "horizontal line: " ++ show line)+  | crossL0 =+      (False, "crosses the X axis below 0: " ++ show line)+  | crossG1 =+      (False, "crosses the X axis above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = intersect line 0+  (q, r)  = if k == 0 then (0, 0) else n `divMod` k+  crossL0 = q < 0  -- q truncated toward negative infinity+  crossG1 = q >= 1 && (q > 1 || r /= 0)
+ Game/LambdaHack/FOV/Permissive.hs view
@@ -0,0 +1,152 @@+-- | PFOV (Permissive Field of View) 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.+module Game.LambdaHack.FOV.Permissive (scan) where++import Game.LambdaHack.Misc+import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.FOV.Common++-- 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.++-- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0).+scan :: (Bump -> Bool)  -- ^ clear tile predicate+     -> [Bump]+scan isClear =+  dscan 1 (((B(0, 1), B(999, 0)), [B(1, 0)]), ((B(1, 0), B(0, 999)), [B(0, 1)]))+ where+  dscan :: Distance -> EdgeInterval -> [Bump]+  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+    assert (d >= 0 && pe + 1 >= ps0 && ps0 >= 0+            `blame` (d,s0,e,ps0,pe)) $+    if illegal then [] else inside ++ outside+   where+    (ns, ks) = intersect sl d+    (ne, ke) = intersect el d+    -- Corners are translucent, so they are invisible, so if intersection+    -- is at a corner, choose pe that creates the smaller view.+    (ps0, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check+    -- A single ray from an extremity produces non-permissive digital lines.+    illegal  = let (n, k) = intersect sl 0+               in ns*ke == ne*ks && (n `elem` [0, k])+    pd2bump     (p, di) = B(di - p    , p)+    bottomRight (p, di) = B(di - p + 1, p)++    inside = [pd2bump (p, d) | p <- [ps0..pe]]+    outside+      | isClear (pd2bump (ps0, d)) = mscan (Just s0) ps0  -- start in light+      | ps0 == ns `divUp` ks = mscan (Just s0) ps0        -- start in a corner+      | otherwise = mscan Nothing (ps0+1)                 -- start in mid-wall++    -- The current state of a scan is kept in @Maybe Edge@.+    -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,+    -- we're in a shadowed interval.+    mscan :: Maybe Edge -> Progress -> [Bump]+    mscan (Just s@(_, sBumps)) ps+      | ps > pe = dscan (d+1) (s, e)           -- reached end, scan next+      | not $ isClear (pd2bump (ps, d)) =      -- enter shadow, steep bump+          let steepBump = bottomRight (ps, d)+              gte = flip $ dsteeper steepBump+              -- sBumps may contain steepBump, but maximal will ignore it+              nep = maximal gte sBumps+              neBumps = addHull gte steepBump eBumps+          in mscan Nothing (ps+1)+             ++ dscan (d+1) (s, (dline nep steepBump, neBumps))+      | otherwise = mscan (Just s) (ps+1)      -- continue in light++    mscan Nothing ps+      | ps > ne `div` ke = []                  -- reached absolute end+      | otherwise =                            -- out of shadow, shallow bump+          -- the light can be just through a corner of diagonal walls+          -- and the recursive call verifies that at the same ps coordinate+          let shallowBump = bottomRight (ps, d)+              gte = dsteeper shallowBump+              nsp = maximal gte eBumps+              nsBumps = addHull gte shallowBump sBumps0+          in mscan (Just (dline nsp shallowBump, nsBumps)) ps++-- | Create a line from two points. Debug: check if well-defined.+dline :: Bump -> Bump -> Line+dline p1 p2 =+  assert (uncurry blame $ debugLine (p1, p2)) $+  (p1, p2)++-- | Compare steepness of @(p1, f)@ and @(p2, f)@.+-- Debug: Verify that the results of 2 independent checks are equal.+dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper f p1 p2 =+  assert (res == debugSteeper f p1 p2) $+  res+   where res = steeper f p1 p2++-- | The Y coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of squares at distance+-- @d@ from (0, 0).+intersect :: Line -> Distance -> (Int, Int)+intersect (B(x, y), B(xf, yf)) d =+  assert (allB (>= 0) [x, y, xf, yf]) $+  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))+{-+Derivation of the formula:+The intersection point (xt, yt) 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 restrictive shadow casting algorithm. The line in the curent state+of mscan is not the steep line, but the shallow line,+and we start scanning from the bottom right.++The Point 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 (Progress, Distance) cordinates+are mangled and not used for geometry.+-}++-- | Debug functions for PFOV:++-- | Debug: calculate steeper for PFOV in another way and compare results.+debugSteeper :: Bump -> Bump -> Bump -> Bool+debugSteeper f@(B(xf, yf)) p1@(B(x1, y1)) p2@(B(x2, y2)) =+  assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $+  let (n1, k1) = intersect (p1, f) 0+      (n2, k2) = intersect (p2, f) 0+  in n1 * k2 <= k1 * n2++-- | Debug: checks postconditions of borderLine.+debugLine :: Line -> (Bool, String)+debugLine line@(B(x1, y1), B(x2, y2))+  | not (allB (>= 0) [x1, y1, x2, y2]) =+      (False, "negative coordinates: " ++ show line)+  | y1 == y2 && x1 == x2 =+      (False, "ill-defined line: " ++ show line)+  | x2 - x1 == - (y2 - y1) =+      (False, "diagonal line: " ++ show line)+  | crossL0 =+      (False, "crosses diagonal below 0: " ++ show line)+  | crossG1 =+      (False, "crosses diagonal above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = intersect line 0+  (q, r)  = if k == 0 then (0, 0) else n `divMod` k+  crossL0 = q < 0  -- q truncated toward negative infinity+  crossG1 = q >= 1 && (q > 1 || r /= 0)
+ Game/LambdaHack/FOV/Shadow.hs view
@@ -0,0 +1,111 @@+-- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.+-- It's not designed for dungeons with diagonal walls and so here+-- they block visibility, though they don't block movement.+-- The main advantage of the algorithm is that it's very simple and fast.+module Game.LambdaHack.FOV.Shadow (SBump, Interval, scan) where++import Data.Ratio++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.FOV.Common++{-+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.+-}++-- | Rotated and translated coordinates of 2D points, so that they fit+-- in the same single octant area.+type SBump = (Progress, Distance)++-- | The area left to be scanned, delimited by fractions of the original arc.+-- Interval @(0, 1)@ means the whole 45 degrees arc of the processed octant+-- is to be scanned.+type Interval = (Rational, Rational)++-- TODO: if every used, apply static argument transformation to isClear.+-- | Calculates the list of tiles, in @SBump@ coordinates, visible from (0, 0).+scan :: (SBump -> Bool)  -- ^ clear tile predicate+     -> Distance         -- ^ the current distance from (0, 0)+     -> Interval         -- ^ the current interval to scan+     -> [SBump]+scan isClear d (s0, e) =+  let ps = downBias (s0 * fromIntegral d)   -- minimal progress to consider+      pe = upBias (e * fromIntegral d)      -- maximal progress to consider+      inside = [(p, d) | p <- [ps..pe]]+      outside+        | isClear (ps, d) = mscan (Just s0) ps pe  -- start in light+        | otherwise = mscan Nothing ps pe          -- start in shadow+  in assert (d >= 0 && e >= 0 && s0 >= 0 && pe >= ps && ps >= 0+             `blame` (d,s0,e,ps,pe)) $+     inside ++ outside+ where+  -- The current state of a scan is kept in @Maybe Rational@.+  -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,+  -- we're in a shadowed interval.+  mscan :: Maybe Rational -> Progress -> Progress -> [SBump]+  mscan (Just s) ps pe+    | s >= e = []                           -- empty interval+    | ps > pe  = scan isClear (d+1) (s, e)  -- reached end, scan next+    | not $ isClear (ps, d) =               -- entering shadow+        let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))+        in mscan Nothing (ps+1) pe ++ scan isClear (d+1) (s, ne)+    | otherwise = mscan (Just s) (ps+1) pe  -- continue in light++  mscan Nothing ps pe+    | ps > pe = []                          -- reached end while in shadow+    | isClear (ps, d) =                     -- moving out of shadow+        let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))+        in mscan (Just ns) (ps+1) pe+    | otherwise = mscan 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))
+ Game/LambdaHack/Feature.hs view
@@ -0,0 +1,30 @@+-- | Terrain tile features.+module Game.LambdaHack.Feature+  ( Feature(..)+  ) where++import Game.LambdaHack.Effect+import Game.LambdaHack.Random++-- | All possible terrain tile features, some of them parameterized or dependent+-- on outside coefficients, e.g., on the tile secrecy value.+data Feature =+    Ascendable         -- ^ triggered by ascending+  | Descendable        -- ^ triggered by descending+  | Openable           -- ^ triggered by opening+  | Closable           -- ^ triggered by closing+  | Hidden             -- ^ triggered when the tile's secrecy becomes zero++  | Cause !Effect      -- ^ causes the effect when triggered+  | ChangeTo !String   -- ^ transitions to any tile of the group when triggered++  | Walkable           -- ^ actors can walk through+  | Clear              -- ^ actors can see through+  | Lit                -- ^ is lit with an ambient shine+  | Aura !Effect       -- ^ sustains the effect continuously, TODO++  | Boring             -- ^ items and stairs can be generated there+  | Exit               -- ^ is a (not hidden) door, stair, etc.+  | Path               -- ^ used for distinct paths throughout the level+  | Secret !RollDice   -- ^ tile is generated with this high secrecy value+  deriving (Show, Read, Eq, Ord)
+ Game/LambdaHack/Flavour.hs view
@@ -0,0 +1,93 @@+-- | The appearance of in-game items, as communicated to the player.+module Game.LambdaHack.Flavour+  ( -- * The @Flavour@ type+    Flavour+  , -- * Constructors+    zipPlain, zipFancy, darkCol, brightCol, stdCol, stdFlav+  , -- * Accessors+    flavourToColor, flavourToName+  ) where++import qualified Data.List as L+import Data.Binary++import Game.LambdaHack.Color++-- TODO: add more variety, as the number of items increases+-- | The type of item flavours.+data Flavour = Flavour+  { fancyName :: Bool   -- ^ should the colour description be fancy or plain+  , baseColor :: Color  -- ^ the colour of the flavour+  }+  deriving (Show, Eq, Ord)++instance Binary Flavour where+  put Flavour{..} = do+    put fancyName+    put baseColor+  get = do+    fancyName <- get+    baseColor <- get+    return Flavour{..}++-- | Turn a colour set into a flavour set.+zipPlain, zipFancy :: [Color] -> [Flavour]+zipPlain = L.map (Flavour False)+zipFancy = L.map (Flavour True)++-- | Colour sets.+darkCol, brightCol, stdCol :: [Color]+darkCol   = [Red .. Cyan]+brightCol = [BrRed .. BrCyan]  -- BrBlack is not really that bright+stdCol    = darkCol ++ brightCol++-- | The standard full set of flavours.+stdFlav :: [Flavour]+stdFlav = zipPlain stdCol ++ zipFancy stdCol++-- | Get the underlying base colour of a flavour.+flavourToColor :: Flavour -> Color+flavourToColor Flavour{baseColor} = baseColor++-- | Construct the full name of a flavour.+flavourToName :: Flavour -> String+flavourToName Flavour{..} | fancyName = colorToFancyName baseColor+flavourToName Flavour{..}             = colorToPlainName baseColor++-- | Human-readable names, for item colors. The simple set.+colorToPlainName :: Color -> String+colorToPlainName Black     = "black"+colorToPlainName Red       = "red"+colorToPlainName Green     = "green"+colorToPlainName Brown     = "brown"+colorToPlainName Blue      = "blue"+colorToPlainName Magenta   = "purple"+colorToPlainName Cyan      = "cyan"+colorToPlainName White     = "ivory"+colorToPlainName BrBlack   = "gray"+colorToPlainName BrRed     = "coral"+colorToPlainName BrGreen   = "lime"+colorToPlainName BrYellow  = "yellow"+colorToPlainName BrBlue    = "azure"+colorToPlainName BrMagenta = "pink"+colorToPlainName BrCyan    = "aquamarine"+colorToPlainName BrWhite   = "white"++-- | Human-readable names, for item colors. The fancy set.+colorToFancyName :: Color -> String+colorToFancyName Black     = "smoky black"+colorToFancyName Red       = "apple red"+colorToFancyName Green     = "forest green"+colorToFancyName Brown     = "mahogany"+colorToFancyName Blue      = "royal blue"+colorToFancyName Magenta   = "indigo"+colorToFancyName Cyan      = "teal"+colorToFancyName White     = "silver gray"+colorToFancyName BrBlack   = "charcoal"+colorToFancyName BrRed     = "salmon"+colorToFancyName BrGreen   = "emerald"+colorToFancyName BrYellow  = "amber"+colorToFancyName BrBlue    = "sky blue"+colorToFancyName BrMagenta = "magenta"+colorToFancyName BrCyan    = "turquoise"+colorToFancyName BrWhite   = "ghost white"
+ Game/LambdaHack/Grammar.hs view
@@ -0,0 +1,169 @@+-- | Construct English sentences from content.+module Game.LambdaHack.Grammar+  ( -- * Grammar types+    Verb, Object+    -- * General operations+  , capitalize, suffixS, addIndefinite+    -- * Objects from content+  , objectItem, objectActor, capActor+    -- * Sentences+  , actorVerb, actorVerbExtra, actorVerbItemExtra+  , actorVerbActorExtra, actorVerbExtraItemExtra+    -- * Scenery description+  , lookAt+  ) where++import Data.Char+import qualified Data.Set as S+import qualified Data.List as L+import Data.Maybe++import Game.LambdaHack.Point+import Game.LambdaHack.Item+import Game.LambdaHack.Actor+import Game.LambdaHack.Level+import Game.LambdaHack.State+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Effect+import Game.LambdaHack.Flavour+import qualified Game.LambdaHack.Kind as Kind++-- | The type of verbs.+type Verb = String++-- | The grammatical object type.+type Object = String++-- | Tests if a character is a vowel (@u@ is too hard, so is @eu@).+vowel :: Char -> Bool+vowel l = l `elem` "aeio"++-- | Adds the plural (@s@, @es@, @ies@) suffix to a word.+-- See http://en.wikipedia.org/wiki/English_plural.+suffixS :: String -> String+suffixS word = case L.reverse word of+                'h' : 'c' : _ -> word ++ "es"+                'h' : 's' : _ -> word ++ "es"+                'i' : 's' : _ -> word ++ "es"+                's' : _ -> word ++ "es"+                'z' : _ -> word ++ "es"+                'x' : _ -> word ++ "es"+                'j' : _ -> word ++ "es"+                'o' : l : _ | not (vowel l) -> init word ++ "es"+                'y' : l : _ | not (vowel l) -> init word ++ "ies"+                _ -> word ++ "s"++conjugate :: String -> Verb -> Verb+conjugate "you" "be" = "are"+conjugate "You" "be" = "are"+conjugate _     "be" = "is"+conjugate "you" verb = verb+conjugate "You" verb = verb+conjugate _     verb = suffixS verb++-- | Capitalize a string.+capitalize :: Object -> Object+capitalize [] = []+capitalize (c : cs) = toUpper c : cs++-- | Add the indefinite article (@a@, @an@) to a word (@h@ is too hard).+addIndefinite :: Object -> Object+addIndefinite b = case b of+                    c : _ | vowel c -> "an " ++ b+                    _               -> "a "  ++ b++-- | Transform an object, adding a count and a plural suffix.+makeObject :: Int -> (Object -> Object) -> Object -> Object+makeObject 1 f obj = addIndefinite $ f obj+makeObject n f obj = show n ++ " " ++ f (suffixS obj)++-- TODO: when there's more of the above, split and move to Utils/++-- | How to refer to an item in object position of a sentence.+objectItem :: Kind.Ops ItemKind -> State -> Item -> Object+objectItem coitem@Kind.Ops{okind} state i =+  let ik = jkind i+      kind = okind ik+      identified = L.length (iflavour kind) == 1 ||+                   ik `S.member` sdisco state+      addSpace s = if s == "" then "" else " " ++ s+      eff = effectToSuffix (ieffect kind)+      pwr = if jpower i == 0 then "" else "(+" ++ show (jpower i) ++ ")"+      adj name = if identified+                 then name ++ addSpace eff ++ addSpace pwr+                 else let flavour = getFlavour coitem (sflavour state) ik+                      in flavourToName flavour ++ " " ++ name+  in makeObject (jcount i) adj (iname kind)++-- | How to refer to an actor in object position of a sentence.+objectActor :: Kind.Ops ActorKind -> Actor -> Object+objectActor Kind.Ops{oname} a =+  fromMaybe (oname $ bkind a) (bname a)++-- | Capitalized actor object.+capActor :: Kind.Ops ActorKind -> Actor -> Object+capActor coactor x = capitalize $ objectActor coactor x++-- | Sentences such as \"Dog barks.\"+actorVerb :: Kind.Ops ActorKind -> Actor -> Verb -> String+actorVerb coactor a v =+  let cactor = capActor coactor a+      verb = conjugate cactor v+  in cactor ++ " " ++ verb ++ "."++-- | Sentences such as \"Dog barks loudly.\"+actorVerbExtra :: Kind.Ops ActorKind -> Actor -> Verb  -> String-> String+actorVerbExtra coactor a v extra =+  L.init (actorVerb coactor a v) ++ " " ++ extra ++ "."++-- | Sentences such as \"Dog quaffs a red potion fast.\"+actorVerbItemExtra :: Kind.COps -> State -> Actor -> Verb -> Item -> String+                   -> String+actorVerbItemExtra Kind.COps{coactor, coitem} state a v i extra =+  actorVerbExtra coactor a v $+    objectItem coitem state i ++ extra++-- | Sentences such as \"Dog bites goblin furiously.\"+actorVerbActorExtra :: Kind.Ops ActorKind -> Actor -> Verb -> Actor -> String+                    -> String+actorVerbActorExtra coactor a v b extra =+  actorVerbExtra coactor a v $+    objectActor coactor b ++ extra++-- | Sentences such as \"Dog gulps down a red potion fast.\"+actorVerbExtraItemExtra :: Kind.COps -> State -> Actor -> Verb -> String+                        -> Item -> String -> String+actorVerbExtraItemExtra Kind.COps{coactor, coitem} state a v extra1 i extra2 =+  actorVerbExtra coactor a v $+    extra1 ++ " " ++ objectItem coitem state i ++ extra2++-- | 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 :: Kind.COps  -- ^ game content+       -> Bool       -- ^ detailed?+       -> Bool       -- ^ can be seen right now?+       -> State      -- ^ game state+       -> Level      -- ^ current level+       -> Point      -- ^ location to describe+       -> String     -- ^ an extra sentence to print+       -> String+lookAt Kind.COps{coitem, cotile=Kind.Ops{oname}} detailed canSee s lvl loc msg+  | detailed  =+    let tile = lvl `rememberAt` loc+        name = capitalize $ oname tile+    in name ++ ". " ++ msg ++ isd+  | otherwise = msg ++ isd+ where+  is  = lvl `rememberAtI` loc+  prefixSee = if canSee then "You see " else "You remember "+  prefixThere = if canSee+                then "There are several objects here"+                else "You remember several objects here"+  isd = case is of+          []    -> ""+          [i]   -> prefixSee ++ objectItem coitem s i ++ "."+          [i,j] -> prefixSee ++ objectItem coitem s i ++ " and "+                             ++ objectItem coitem s j ++ "."+          _     -> prefixThere ++ if detailed then ":" else "."
+ Game/LambdaHack/HighScore.hs view
@@ -0,0 +1,150 @@+-- | High score table operations.+module Game.LambdaHack.HighScore+  ( Status(..), ScoreRecord(..), ScoreTable, restore, register, slideshow+  ) where++import System.Directory+import Control.Monad+import Text.Printf+import System.Time+import Data.Binary+import qualified Data.List as L++import Game.LambdaHack.Utils.File+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.Dungeon+import Game.LambdaHack.Misc++-- TODO: add heroes' names, exp and level, cause of death, user number/name.+-- Note: I tried using Date.Time, but got all kinds of problems,+-- including build problems and opaque types that make serialization difficult,+-- and I couldn't use Datetime because it needs old base (and is under GPL).+-- TODO: When we finally move to Date.Time, let's take timezone into account,+-- at least while displaying.+-- | A single score record. Records are ordered in the highscore table,+-- from the best to the worst, in lexicographic ordering wrt the fields below.+data ScoreRecord = ScoreRecord+  { points  :: !Int        -- ^ the score+  , negTurn :: !Int        -- ^ number of turns (negated, so less better)+  , date    :: !ClockTime  -- ^ date of the last game interruption+  , status  :: !Status     -- ^ reason of the game interruption+  }+  deriving (Eq, Ord)++-- | Current result of the game.+data Status =+    Killed !LevelId  -- ^ the player lost the game on the given level+  | Camping          -- ^ game is supended+  | Victor           -- ^ the player won+  deriving (Eq, Ord)++instance Binary Status where+  put (Killed ln) = putWord8 0 >> put ln+  put Camping     = putWord8 1+  put Victor      = putWord8 2+  get = do+    tag <- getWord8+    case tag of+      0 -> liftM Killed  get+      1 -> return Camping+      2 -> return Victor+      _ -> fail "no parse (Status)"++instance Binary ScoreRecord where+  put (ScoreRecord p n (TOD cs cp) s) = do+    put p+    put n+    put cs+    put cp+    put s+  get = do+    p <- get+    n <- get+    cs <- get+    cp <- get+    s <- get+    return (ScoreRecord p n (TOD cs cp) s)++-- | Show a single high score, from the given ranking in the high score table.+showScore :: (Int, ScoreRecord) -> String+showScore (pos, score) =+  let died = case status score of+        Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ ","+        Camping -> "is camping somewhere,"+        Victor -> "emerged victorious"+      time  = calendarTimeToString . toUTCTime . date $ score+      big   = "                                                 "+      lil   = "              "+      steps = negTurn score `div` (-10)+  in printf+       "%s\n%4d. %6d  This adventuring party %s after %d steps  \n%son %s.  \n"+       big pos (points score) died steps lil time++-- | The list of scores, in decreasing order.+type ScoreTable = [ScoreRecord]++-- | Empty score table+empty :: ScoreTable+empty = []++-- | Name of the high scores file.+scoresFile :: Config.CP -> IO String+scoresFile config = Config.getFile config "files" "scoresFile"++-- | Save a simple serialized version of the high scores table.+save :: Config.CP -> ScoreTable -> IO ()+save config scores = do+  f <- scoresFile config+  encodeEOF f scores++-- | Read the high scores table. Return the empty table if no file.+restore :: Config.CP -> IO ScoreTable+restore config = do+  f <- scoresFile config+  b <- doesFileExist f+  if not b+    then return empty+    else strictDecodeEOF f++-- | Insert a new score into the table, Return new table and the ranking.+insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)+insertPos s h =+  let (prefix, suffix) = L.span (> s) h+  in (prefix ++ [s] ++ suffix, L.length prefix + 1)++-- | Show a screenful of the high scores table.+-- Parameter height is the number of (3-line) scores to be shown.+showTable :: ScoreTable -> Int -> Int -> String+showTable h start height =+  let zipped    = zip [1..] h+      screenful = take height . drop (start - 1) $ zipped+  in L.concatMap showScore screenful++-- | Produce 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 saving a new score to the table+-- and return a list of messages to display.+register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String])+register config write s = do+  h <- restore config+  let (h', pos) = insertPos s h+      (_, nlines) = normalLevelBound  -- TODO: query terminal size instead+      height = nlines `div` 3+      (msgCurrent, msgUnless) =+        case status s of+          Killed _ -> (" short-lived", " (score halved)")+          Camping  -> (" current", " (unless you are slain)")+          Victor   -> (" glorious",+                        if pos <= height+                        then " among the greatest heroes"+                        else "")+      msg = printf "Your%s exploits award you place >> %d <<%s."+              msgCurrent pos msgUnless+  when write $ save config h'+  return (msg, slideshow pos h' height)
+ Game/LambdaHack/Item.hs view
@@ -0,0 +1,248 @@+-- | Weapons, treasure and all the other items in the game.+-- No operation in this module+-- involves the 'State' or 'Action' type.+-- TODO: Document after it's rethought and rewritten wrt separating+-- inventory manangement and items proper.+module Game.LambdaHack.Item+  ( -- * Teh @Item@ type+    Item(..), newItem, viewItem, itemPrice+    -- * Inventory search+  , strongestSearch, strongestSword, strongestRegen+    -- * Inventory management+  , joinItem, removeItemByLetter, equalItemIdentity, removeItemByIdentity+  , assignLetter+    -- * Inventory symbol operations+  , letterLabel, cmpLetterMaybe, maxLetter, letterRange+    -- * The @FlavourMap@ type+  , FlavourMap, getFlavour, dungeonFlavourMap+    -- * The @Discoveries@ type+  , Discoveries+  ) where++import Data.Binary+import qualified Data.Set as S+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import Data.Char+import Data.Function+import Data.Ord+import Control.Monad++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Random+import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Color as Color+import Game.LambdaHack.Flavour+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Effect++-- TODO: see the TODO about ipower in ItemKind.+-- TODO: define type InvSymbol = Char and move all ops to another file.+-- TODO: perhaps remove jletter and jcount? Should inventory semantics+-- be separate from item semantics?+-- TODO: the list resulting from joinItem can contain items+-- with the same letter.+-- TODO: name [Item] Inventory and have some invariants, e.g. no equal letters.+-- | Game items in inventories or strewn around the dungeon.+data Item = Item+  { jkind   :: !(Kind.Id ItemKind)  -- ^ kind of the item+  , jpower  :: !Int                 -- ^ power of the item+  , jletter :: Maybe Char           -- ^ inventory symbol+  , jcount  :: !Int                 -- ^ inventory count+  }+  deriving Show++instance Binary Item where+  put (Item ik ip il ic ) =+    put ik >> put ip >> put il >> put ic+  get = liftM4 Item get get get get++-- | Generate an item.+newItem :: Kind.Ops ItemKind -> Int -> Int -> Rnd Item+newItem cops@Kind.Ops{opick, okind} lvl depth = do+  ikChosen <- opick "dng" (const True)+  let kind = okind ikChosen+  count <- rollDeep lvl depth (icount kind)+  if count == 0+    then newItem cops lvl depth  -- Rare item; beware of inifite loops.+    else do+      power <- rollDeep lvl depth (ipower kind)+      return $ Item ikChosen power (itemLetter kind) count++-- | Represent an item on the map.+viewItem :: Kind.Ops ItemKind -> Kind.Id ItemKind -> FlavourMap+         -> (Char, Color.Color)+viewItem cops@Kind.Ops{osymbol} ik assocs =+  (osymbol ik, flavourToColor $ getFlavour cops assocs ik)++-- | Price an item, taking count into consideration.+itemPrice :: Kind.Ops ItemKind -> Item -> Int+itemPrice Kind.Ops{osymbol} i =+  case osymbol (jkind i) of+    '$' -> jcount i+    '*' -> jcount i * 100+    _   -> 0++-- | The type of already discovered items.+type Discoveries = S.Set (Kind.Id ItemKind)++-- Could be optimized to IntMap and IntSet, but won't ever be a bottleneck,+-- unless we have thousands of item kinds.+-- TODO: rewrite and move elsewhere+-- | Flavours assigned to items in this game.+type FlavourMap = M.Map (Kind.Id ItemKind) Flavour++-- | Assigns flavours to item kinds. Assures no flavor is repeated,+-- except for items with only one permitted flavour.+rollFlavourMap :: Kind.Id ItemKind -> ItemKind+               -> Rnd (FlavourMap, S.Set Flavour)+               -> Rnd (FlavourMap, S.Set Flavour)+rollFlavourMap key ik rnd =+  let flavours = iflavour ik+  in if L.length flavours == 1+     then rnd+     else do+       (assocs, available) <- rnd+       let proper = S.fromList flavours `S.intersection` available+       flavour <- oneOf (S.toList proper)+       return (M.insert key flavour assocs, S.delete flavour available)++-- | Randomly chooses flavour for all item kinds for this game.+dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap+dungeonFlavourMap Kind.Ops{ofoldrWithKey} =+  liftM fst $+    ofoldrWithKey rollFlavourMap (return (M.empty, S.fromList stdFlav))++getFlavour :: Kind.Ops ItemKind -> FlavourMap -> Kind.Id ItemKind -> Flavour+getFlavour Kind.Ops{okind} assocs ik =+  let kind = okind ik+  in case iflavour kind of+    []  -> assert `failure` (assocs, ik, kind)+    [f] -> f+    _:_ -> assocs M.! ik++itemLetter :: ItemKind -> Maybe Char+itemLetter ik = if isymbol ik == '$' then Just '$' else Nothing++-- | 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 `elem` allowed -> Just l+    _ -> listToMaybe free+ where+  current    = S.fromList (mapMaybe jletter 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)++cmpLetterMaybe :: Maybe Char -> Maybe Char -> Ordering+cmpLetterMaybe Nothing  Nothing   = EQ+cmpLetterMaybe Nothing  (Just _)  = GT+cmpLetterMaybe (Just _) Nothing   = LT+cmpLetterMaybe (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 :: Char -> Char -> Char+maxLetter = maxBy cmpLetter++mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char+mergeLetter = mplus++letterRange :: [Char] -> String+letterRange ls =+  sectionBy (L.sortBy cmpLetter ls) 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.+joinItem :: Item -> [Item] -> (Item, [Item])+joinItem i is =+  case findItem (equalItemIdentity i) is of+    Nothing     -> (i, i : is)+    Just (j,js) -> let n = i { jcount = jcount i + jcount j,+                               jletter = mergeLetter (jletter j) (jletter i) }+                   in (n, n : js)++-- | Removes an item from a list of items.+-- 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 = jcount x - jcount i+       in if remaining > 0+          then [x { jcount = remaining }]+          else []+  else [x]++equalItemIdentity :: Item -> Item -> Bool+equalItemIdentity i1 i2 = jpower i1 == jpower i2 && jkind i1 == jkind i2++removeItemByIdentity :: Item -> [Item] -> [Item]+removeItemByIdentity = removeItemBy equalItemIdentity++equalItemLetter :: Item -> Item -> Bool+equalItemLetter = (==) `on` jletter++removeItemByLetter :: Item -> [Item] -> [Item]+removeItemByLetter = removeItemBy equalItemLetter++-- | Finds an item in a list of items.+findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])+findItem p =+  findItem' []+ where+  findItem' _   []     = Nothing+  findItem' acc (i:is)+    | p i              = Just (i, reverse acc ++ is)+    | otherwise        = findItem' (i:acc) is++strongestItem :: [Item] -> (Item -> Bool) -> Maybe Item+strongestItem is p =+  let cmp = comparing jpower+      igs = L.filter p is+  in case igs of+    [] -> Nothing+    _  -> Just $ L.maximumBy cmp igs++strongestSearch :: Kind.Ops ItemKind -> [Item] -> Maybe Item+strongestSearch Kind.Ops{okind} bitems =+  strongestItem bitems $ \ i -> (ieffect $ okind $ jkind i) == Searching++-- TODO: generalise, in particular take base damage into account+strongestSword :: Kind.Ops ItemKind -> [Item] -> Maybe Item+strongestSword Kind.Ops{osymbol} bitems =+  strongestItem bitems $ \ i -> (osymbol $ jkind i) == ')'++strongestRegen :: Kind.Ops ItemKind -> [Item] -> Maybe Item+strongestRegen Kind.Ops{okind} bitems =+  strongestItem bitems $ \ i -> (ieffect $ okind $ jkind i) == Regeneration
+ Game/LambdaHack/ItemAction.hs view
@@ -0,0 +1,460 @@+-- | 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 Actions.hs.+-- TODO: Add an export list and document after it's rewritten according to #17.+module Game.LambdaHack.ItemAction where++import Control.Monad+import Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import qualified Data.IntSet as IS++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Action+import Game.LambdaHack.Point+import Game.LambdaHack.Grammar+import Game.LambdaHack.Item+import qualified Game.LambdaHack.Key as K+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Perception+import Game.LambdaHack.State+import Game.LambdaHack.EffectAction+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Feature as F+import qualified Game.LambdaHack.Tile as Tile++-- | Display inventory+inventory :: Action ()+inventory = do+  items <- gets getPlayerItem+  if L.null items+    then abortWith "Not carrying anything."+    else do+      displayItems "Carrying:" True items+      abort++-- | Let the player choose any item with a given group name.+-- Note that this does not guarantee the chosen item belongs to the group,+-- as the player can override the choice.+getGroupItem :: [Item]  -- ^ all objects in question+             -> Object  -- ^ name of the group+             -> [Char]  -- ^ accepted item symbols+             -> String  -- ^ prompt+             -> String  -- ^ how to refer to the collection of objects+             -> Action (Maybe Item)+getGroupItem is object syms prompt packName = do+  Kind.Ops{osymbol} <- contentf Kind.coitem+  let choice i = osymbol (jkind i) `elem` syms+      header = capitalize $ suffixS object+  getItem prompt choice header is packName++applyGroupItem :: ActorId  -- ^ actor applying the item (is on current level)+               -> Verb     -- ^ how the applying is called+               -> Item     -- ^ the item to be applied+               -> Action ()+applyGroupItem actor verb item = do+  cops  <- contentOps+  state <- get+  body  <- gets (getActor actor)+  per   <- currentPerception+  -- only one item consumed, even if several in inventory+  let consumed = item { jcount = 1 }+      msg = actorVerbItemExtra cops state body verb consumed ""+      loc = bloc body+  removeFromInventory actor consumed loc+  when (loc `IS.member` totalVisible per) $ msgAdd msg+  itemEffectAction 5 actor actor consumed+  advanceTime actor++playerApplyGroupItem :: Verb -> Object -> [Char] -> Action ()+playerApplyGroupItem verb object syms = do+  Kind.Ops{okind} <- contentf Kind.coitem+  is   <- gets getPlayerItem+  iOpt <- getGroupItem is object syms+            ("What to " ++ verb ++ "?") "in inventory"+  pl   <- gets splayer+  case iOpt of+    Just i  -> applyGroupItem pl (iverbApply $ okind $ jkind i) i+    Nothing -> neverMind True++projectGroupItem :: ActorId  -- ^ actor projecting the item (is on current lvl)+                 -> Point    -- ^ target location for the projecting+                 -> Verb     -- ^ how the projecting is called+                 -> Item     -- ^ the item to be projected+                 -> Action ()+projectGroupItem source loc verb item = do+  cops@Kind.COps{coactor, cotile} <- contentOps+  state <- get+  sm    <- gets (getActor source)+  per   <- currentPerception+  lvl   <- gets slevel+  let -- TODO: refine for, e.g., wands of digging that are aimed into walls.+      locWalkable = Tile.hasFeature cotile F.Walkable (lvl `at` loc)+      consumed = item { jcount = 1 }+      sloc = bloc sm+      subject =+        if sloc `IS.member` totalVisible per+        then sm+        else template (heroKindId coactor)+               Nothing (Just "somebody") 99 sloc+      msg = actorVerbItemExtra cops state subject verb consumed ""+  removeFromInventory source consumed sloc+  case locToActor loc state of+    Just ta -> do+      -- The msg describes the source part of the action.+      when (sloc `IS.member` totalVisible per || isAHero ta) $ msgAdd msg+      -- Msgs inside itemEffectAction describe the target part.+      b <- itemEffectAction 10 source ta consumed+      unless b $ modify (updateLevel (dropItemsAt [consumed] loc))+    Nothing | locWalkable -> do+      when (sloc `IS.member` totalVisible per) $ msgAdd msg+      modify (updateLevel (dropItemsAt [consumed] loc))+    _ -> abortWith "blocked"+  advanceTime source++playerProjectGroupItem :: Verb -> Object -> [Char] -> Action ()+playerProjectGroupItem verb object syms = do+  ms     <- gets (lmonsters . slevel)+  lxsize <- gets (lxsize . slevel)+  ploc   <- gets (bloc . getPlayerBody)+  if L.any (adjacent lxsize ploc) (L.map bloc $ IM.elems ms)+    then abortWith "You can't aim in melee."+    else playerProjectGI verb object syms++playerProjectGI :: Verb -> Object -> [Char] -> Action ()+playerProjectGI verb object syms = do+  state <- get+  pl    <- gets splayer+  ploc  <- gets (bloc . getPlayerBody)+  per   <- currentPerception+  let retarget msg = do+        msgAdd msg+        updatePlayerBody (\ p -> p { btarget = TCursor })+        let upd cursor = cursor {clocation=ploc}+        modify (updateCursor upd)+        targetMonster TgtAuto+  -- TODO: draw digital line and see if obstacles prevent firing+  -- TODO: don't tell the player if the tiles he can't see are reachable,+  -- but let him throw there and let them land closer, if not reachable+  -- TODO: similarly let him throw at walls and land in front (digital line)+  case targetToLoc (totalVisible per) state of+    Just loc | actorReachesLoc pl loc per (Just pl) -> do+      Kind.Ops{okind} <- contentf Kind.coitem+      is   <- gets getPlayerItem+      iOpt <- getGroupItem is object syms+                ("What to " ++ verb ++ "?") "in inventory"+      targeting <- gets (ctargeting . scursor)+      when (targeting == TgtAuto) $ endTargeting True+      case iOpt of+        Just i -> projectGroupItem pl loc (iverbProject $ okind $ jkind i) i+        Nothing -> neverMind True+    Just _  -> retarget "Last target unreachable."+    Nothing -> retarget "Last target invalid."++-- TODO: also target a monster by moving the cursor, if in target monster mode.+-- TODO: sort monsters by distance to the player.++-- | Start the monster targeting mode. Cycle between monster targets.+targetMonster :: TgtMode -> Action ()+targetMonster tgtMode = do+  pl        <- gets splayer+  ms        <- gets (lmonsters . slevel)+  per       <- currentPerception+  target    <- gets (btarget . getPlayerBody)+  targeting <- gets (ctargeting . scursor)+  let i = case target of+            TEnemy (AMonster n) _ | targeting /= TgtOff -> n  -- next monster+            TEnemy (AMonster n) _ -> n - 1  -- try to retarget old monster+            _ -> -1  -- try to target first monster (e.g., number 0)+      dms = case pl of+              AMonster n -> IM.delete n ms  -- don't target yourself+              AHero _ -> ms+      (lt, gt) = IM.split i dms+      gtlt     = IM.assocs gt ++ IM.assocs lt+      seen (_, m) =+        let mloc = bloc m+        in mloc `IS.member` totalVisible per         -- visible by any+           && actorReachesLoc pl mloc per (Just pl)  -- reachable by player+      lf = L.filter seen gtlt+      tgt = case lf of+              [] -> target  -- no monsters in sight, stick to last target+              (na, nm) : _ -> TEnemy (AMonster na) (bloc nm)  -- pick the next+  updatePlayerBody (\ p -> p { btarget = tgt })+  setCursor tgtMode++-- | Start the floor targeting mode or reset the cursor location to the player.+targetFloor :: TgtMode -> Action ()+targetFloor tgtMode = do+  ploc      <- gets (bloc . getPlayerBody)+  target    <- gets (btarget . getPlayerBody)+  targeting <- gets (ctargeting . scursor)+  let tgt = case target of+        _ | targeting /= TgtOff -> TLoc ploc  -- double key press: reset cursor+        TEnemy _ _ -> TCursor  -- forget enemy target, keep the cursor+        t -> t  -- keep the target from previous targeting session+  updatePlayerBody (\ p -> p { btarget = tgt })+  setCursor tgtMode++-- | Set, activate and display cursor information.+setCursor :: TgtMode -> Action ()+setCursor tgtMode = assert (tgtMode /= TgtOff) $ do+  state  <- get+  per    <- currentPerception+  ploc   <- gets (bloc . getPlayerBody)+  clocLn <- gets slid+  let upd cursor@Cursor{ctargeting} =+        let clocation = fromMaybe ploc (targetToLoc (totalVisible per) state)+            newTgtMode = if ctargeting == TgtOff then tgtMode else ctargeting+        in cursor { ctargeting = newTgtMode, clocation, clocLn }+  modify (updateCursor upd)+  doLook++-- | End targeting mode, accepting the current location or not.+endTargeting :: Bool -> Action ()+endTargeting accept = do+  returnLn <- gets (creturnLn . scursor)+  target   <- gets (btarget . getPlayerBody)+  per      <- currentPerception+  cloc     <- gets (clocation . scursor)+  ms       <- gets (lmonsters . slevel)+  -- return to the original level of the player+  modify (\ state -> state {slid = returnLn})+  modify (updateCursor (\ c -> c { ctargeting = TgtOff }))+  case target of+    TEnemy _ _ -> do+      let canSee = IS.member cloc (totalVisible per)+      when (accept && canSee) $+        case L.find (\ (_im, m) -> bloc m == cloc) (IM.assocs ms) of+          Just (im, m)  ->+            let tgt = TEnemy (AMonster im) (bloc m)+            in updatePlayerBody (\ p -> p { btarget = tgt })+          Nothing -> return ()+    _ ->+      if accept+      then updatePlayerBody (\ p -> p { btarget = TLoc cloc })+      else updatePlayerBody (\ p -> p { btarget = TCursor })+  endTargetingMsg++endTargetingMsg :: Action ()+endTargetingMsg = do+  cops   <- contentf Kind.coactor+  pbody  <- gets getPlayerBody+  state  <- get+  lxsize <- gets (lxsize . slevel)+  let verb = "target"+      targetMsg = case btarget pbody of+                    TEnemy a _ll ->+                      if memActor a state+                      then objectActor cops $ getActor a state+                      else "a fear of the past"+                    TLoc loc -> "location " ++ showPoint lxsize loc+                    TCursor  -> "current cursor position continuously"+  msgAdd $ actorVerbExtra cops pbody 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 /= TgtOff+    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 /= TgtOff+    then endTargeting True+    else h  -- nothing to accept right now++-- | Drop a single item.+dropItem :: Action ()+dropItem = do+  -- TODO: allow dropping a given number of identical items.+  cops  <- contentOps+  pl    <- gets splayer+  state <- get+  pbody <- gets getPlayerBody+  ploc  <- gets (bloc . getPlayerBody)+  items <- gets getPlayerItem+  iOpt  <- getAnyItem "What to drop?" items "inventory"+  case iOpt of+    Just stack -> do+      let i = stack { jcount = 1 }+      removeOnlyFromInventory pl i (bloc pbody)+      msgAdd (actorVerbItemExtra cops state pbody "drop" i "")+      modify (updateLevel (dropItemsAt [i] ploc))+    Nothing -> neverMind True+  playerAdvanceTime++-- TODO: this is a hack for dropItem, because removeFromInventory+-- makes it impossible to drop items if the floor not empty.+removeOnlyFromInventory :: ActorId -> Item -> Point -> Action ()+removeOnlyFromInventory actor i _loc =+  modify (updateAnyActorItem actor (removeItemByLetter i))++-- | Remove given item from an actor's inventory or floor.+-- TODO: this is subtly wrong: if identical items are on the floor and in+-- inventory, the floor one will be chosen, regardless of player intention.+-- TODO: right now it ugly hacks (with the ploc) around removing items+-- of dead heros/monsters. The subtle incorrectness helps here a lot,+-- because items of dead heroes land on the floor, so we use them up+-- in inventory, but remove them after use from the floor.+removeFromInventory :: ActorId -> Item -> Point -> Action ()+removeFromInventory actor i loc = do+  b <- removeFromLoc i loc+  unless b $+    modify (updateAnyActorItem actor (removeItemByLetter i))++-- | Remove given item from the given location. Tell if successful.+removeFromLoc :: Item -> Point -> Action Bool+removeFromLoc i loc = do+  lvl <- gets slevel+  if not $ L.any (equalItemIdentity i) (lvl `atI` loc)+    then return False+    else+      modify (updateLevel (updateIMap adj)) >>+      return True+     where+      rib Nothing = assert `failure` (i, loc)+      rib (Just (is, irs)) =+        case (removeItemByIdentity i is, irs) of+          ([], []) -> Nothing+          iss -> Just iss+      adj = IM.alter rib loc++actorPickupItem :: ActorId -> Action ()+actorPickupItem actor = do+  cops@Kind.COps{coitem} <- contentOps+  state <- get+  pl    <- gets splayer+  per   <- currentPerception+  lvl   <- gets slevel+  body  <- gets (getActor actor)+  bitems <- gets (getActorItem actor)+  let loc       = bloc body+      perceived = loc `IS.member` totalVisible per+      isPlayer  = actor == pl+  -- check if something is here to pick up+  case lvl `atI` loc of+    []   -> abortIfWith isPlayer "nothing here"+    i:is -> -- pick up first item; TODO: let pl select item; not for monsters+      case assignLetter (jletter i) (bletter body) bitems of+        Just l -> do+          let (ni, nitems) = joinItem (i { jletter = Just l }) bitems+          -- msg depends on who picks up and if a hero can perceive it+          if isPlayer+            then msgAdd (letterLabel (jletter ni)+                         ++ objectItem coitem state ni)+            else when perceived $+                   msgAdd $+                   actorVerbExtraItemExtra cops state body "pick" "up" i ""+          removeFromLoc i loc+            >>= assert `trueM` (i, is, loc, "item is stuck")+          -- add item to actor's inventory:+          updateAnyActor actor $ \ m ->+            m { bletter = maxLetter l (bletter body) }+          modify (updateAnyActorItem actor (const nitems))+        Nothing -> abortIfWith isPlayer "cannot carry any more"+  advanceTime actor++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.++-- TODO: you can drop an item already the floor, which works correctly,+-- but is weird and useless.++-- | Let the player choose any item from a list of items.+getAnyItem :: String  -- ^ prompt+           -> [Item]  -- ^ all items in question+           -> String  -- ^ how to refer to the collection of items+           -> Action (Maybe Item)+getAnyItem prompt = getItem prompt (const True) "Objects"++data ItemDialogState = INone | ISuitable | IAll deriving Eq++-- | Let the player choose a single, preferably suitable,+-- item from a list of items.+getItem :: String               -- ^ prompt message+        -> (Item -> Bool)       -- ^ which items to consider suitable+        -> String               -- ^ how to describe suitable items+        -> [Item]               -- ^ all items in question+        -> String               -- ^ how to refer to the collection of items+        -> Action (Maybe Item)+getItem prompt p ptext is0 isn = do+  lvl  <- gets slevel+  body <- gets getPlayerBody+  let loc = bloc body+      tis = lvl `atI` loc+      floorMsg = if L.null tis then "" else " -,"+      is = L.filter p is0+      cmpItemLM i1 i2 = cmpLetterMaybe (jletter i1) (jletter i2)+      choice ims =+        if L.null ims+        then "[?," ++ floorMsg ++ " ESC]"+        else let mls = mapMaybe jletter ims+                 r = letterRange mls+                 ret = maybe "" (\ l -> ['(', l, ')']) $+                         jletter $ L.maximumBy cmpItemLM ims+             in "[" ++ r ++ ", ?," ++ floorMsg ++ " RET" ++ ret ++ ", ESC]"+      ask = do+        when (L.null is0 && L.null tis) $+          abortWith "Not carrying anything."+        msgReset (prompt ++ " " ++ choice is)+        displayAll+        session nextCommand >>= perform ISuitable+      perform itemDialogState command = do+        let ims = if itemDialogState == INone then is0 else is+        msgClear+        case command of+          K.Char '?' | itemDialogState == ISuitable -> do+            -- filter for suitable items+            b <- displayItems+                   (ptext ++ " " ++ isn ++ ". " ++ choice is) True is+            if b then session (getOptionalConfirm (const ask)+                                 (perform IAll))+                 else ask+          K.Char '?' | itemDialogState == IAll -> do+            -- show all items+            b <- displayItems+                   ("Objects " ++ isn ++ ". " ++ choice is0) True is0+            if b then session (getOptionalConfirm (const ask)+                                 (perform INone))+                 else ask+          K.Char '?' | itemDialogState == INone -> ask+          K.Char '-' ->+            case tis of+              []   -> return Nothing+              i:_rs -> -- use first item; TODO: let player select item+                      return $ Just i+          K.Char l ->+            return (L.find (maybe False (== l) . jletter) ims)+          K.Return ->+            if L.null ims+            then return Nothing+            else return $ Just $ L.maximumBy cmpItemLM ims+          _ -> return Nothing+  ask
+ Game/LambdaHack/Key.hs view
@@ -0,0 +1,127 @@+-- | Frontend-independent keyboard input operations.+module Game.LambdaHack.Key+  ( Key(..), handleDir, moveBinding, keyTranslate+  ) where++import Prelude hiding (Left, Right)+import qualified Data.List as L+import qualified Data.Char as Char++import Game.LambdaHack.PointXY+import Game.LambdaHack.Vector++-- TODO: if the file grows much larger, split it and move a part to Utils/++-- | Frontend-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | Space+  | 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, registered to warn the user+  deriving (Ord, Eq)++showKey :: Key -> String+showKey (Char c) = [c]+showKey Esc      = "ESC"  -- these three are common and terse abbreviations+showKey Return   = "RET"+showKey Space    = "SPACE"+showKey Tab      = "TAB"+showKey PgUp     = "<page-up>"+showKey PgDn     = "<page-down>"+showKey Left     = "<left>"+showKey Right    = "<right>"+showKey Up       = "<up>"+showKey Down     = "<down>"+showKey End      = "<end>"+showKey Begin    = "<begin>"+showKey Home     = "<home>"+showKey (KP c)   = "<KeyPad " ++ [c] ++ ">"+showKey (Unknown s) = s++instance Show Key where+  show = showKey++dirViChar :: [Char]+dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']++dirViMoveKey :: [Key]+dirViMoveKey = map Char dirViChar++dirViRunKey :: [Key]+dirViRunKey = map (Char . Char.toUpper) dirViChar++dirMoveKey :: [Key]+dirMoveKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]++dirRunKey :: [Key]+dirRunKey = map KP ['7', '8', '9', '6', '3', '2', '1', '4']++-- | Configurable event handler for the direction keys.+-- Used for directed commands such as close door.+handleDir :: X -> Key -> (Vector -> a) -> a -> a+handleDir lxsize e h k =+  let mvs = moves lxsize+      assocs = zip dirViMoveKey mvs ++ zip dirMoveKey mvs+  in maybe k h (L.lookup e assocs)++-- | Binding of both sets of movement keys.+moveBinding :: ((X -> Vector) -> a) -> ((X -> Vector) -> a)+            -> [(Key, (String, a))]+moveBinding move run =+  let assign f (key, dir) = (key, ("", f dir))+  in map (assign move) (zip dirViMoveKey movesWidth) +++     map (assign move) (zip dirMoveKey movesWidth) +++     map (assign run) (zip dirViRunKey movesWidth) +++     map (assign run) (zip dirRunKey movesWidth)++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the command bindings and macros+-- in the config file.+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "comma"         = 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 "bracketleft"   = Char '['+keyTranslate "bracketright"  = Char ']'+keyTranslate "braceleft"     = Char '{'+keyTranslate "braceright"    = Char '}'+keyTranslate "Escape"        = Esc+keyTranslate "Return"        = Return+keyTranslate "space"         = Space+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
+ Game/LambdaHack/Kind.hs view
@@ -0,0 +1,141 @@+-- | General content types and operations.+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-}+module Game.LambdaHack.Kind+  ( -- * General content types+    Id, Speedup(..), Ops(..), COps(..), createOps+    -- * Arrays of content identifiers+  , Array, (!), (//), listArray, array, bounds+  ) where++import Data.Binary+import qualified Data.List as L+import qualified Data.IntMap as IM+import qualified Data.Word as Word+import qualified Data.Array.Unboxed as A+import qualified Data.Ix as Ix+import Data.Maybe++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Utils.Frequency+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.PlaceKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content+import Game.LambdaHack.Random++-- | Content identifiers for the content type @c@.+newtype Id c = Id Word8 deriving (Show, Eq, Ord, Ix.Ix)++instance Binary (Id c) where+  put (Id i) = put i+  get = fmap Id get++-- | Type family for auxiliary data structures for speeding up+-- content operations.+data family Speedup a++data instance Speedup TileKind = TileSpeedup+  { isClearTab :: Id TileKind -> Bool+  , isLitTab   :: Id TileKind -> Bool+  }++-- | Content operations for the content of type @a@.+data Ops a = Ops+  { osymbol :: Id a -> Char       -- ^ the symbol of a content element at id+  , oname :: Id a -> String       -- ^ the name of a content element at id+  , okind :: Id a -> a            -- ^ the content element at given id+  , ouniqGroup :: String -> Id a  -- ^ the id of the unique member of+                                  -- a singleton content group+  , opick :: String -> (a -> Bool) -> Rnd (Id a)+                                  -- ^ pick a random id belonging to a group+                                  -- and satisfying a predicate+  , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b+                                  -- ^ fold over all content elements of @a@+  , obounds :: (Id a, Id a)       -- ^ bounds of identifiers of content @a@+  , ospeedup :: Speedup a         -- ^ auxiliary speedup components+  }++-- | Create content operations for type @a@ from definition of content+-- of type @a@.+createOps :: forall a. Show a => CDefs a -> Ops a+createOps CDefs{getSymbol, getName, getFreq, content, validate} =+  let kindAssocs :: [(Word.Word8, a)]+      kindAssocs = L.zip [0..] content+      kindMap :: IM.IntMap a+      kindMap = IM.fromDistinctAscList $ L.zip [0..] content+      groupFreq group k = fromMaybe 0 (L.lookup group $ getFreq k)+      kindFreq :: String -> Frequency (Id a, a)+      kindFreq group =+        toFreq [ (n, (Id i, k))+               | (i, k) <- kindAssocs, let n = groupFreq group k, n > 0 ]+      okind (Id i) = kindMap IM.! fromEnum i+      correct a = not (L.null (getName a)) && L.all ((> 0) . snd) (getFreq a)+      offenders = validate content+  in assert (allB correct content) $+     assert (L.null offenders `blame` offenders) $+     Ops+       { osymbol = getSymbol . okind+       , oname = getName . okind+       , okind = okind+       , ouniqGroup = \ group ->+           case [Id i | (i, k) <- kindAssocs, groupFreq group k > 0] of+             [i] -> i+             l -> assert `failure` l+       , opick = \ group p ->+           fmap fst $ frequency $ filterFreq (p . snd) $ kindFreq group+       , ofoldrWithKey = \ f z -> L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs+       , obounds =+         let limits = let (i1, a1) = IM.findMin kindMap+                          (i2, a2) = IM.findMax kindMap+                      in ((Id (toEnum i1), a1), (Id (toEnum i2), a2))+         in (Id 0, (fst . snd) limits)+       , ospeedup = undefined  -- define elsewhere+       }++-- | Operations for all content types, gathered together.+data COps = COps+  { coactor :: !(Ops ActorKind)+  , cocave  :: !(Ops CaveKind)+  , coitem  :: !(Ops ItemKind)+  , coplace :: !(Ops PlaceKind)+  , corule  :: !(Ops RuleKind)+  , cotile  :: !(Ops TileKind)+  }++instance Show COps where+  show _ = "Game content."++-- | Arrays, indexed by type @i@ of content identifiers pointing to+-- content type @c@, where the identifiers are represented as @Word8@+-- (and so content of type @c@ can have at most 256 elements).+newtype Array i c = Array (A.UArray i Word.Word8) deriving Show++-- TODO: save/restore is still too slow, but we are already past+-- the point of diminishing returns. A dramatic change would be+-- low-level conversion to ByteString and serializing that.+instance (Ix.Ix i, Binary i) => Binary (Array i c) where+  put (Array a) = put a+  get = fmap Array get++-- | Content identifiers array lookup.+(!) :: Ix.Ix i => Array i c -> i -> Id c+(!) (Array a) i = Id $ a A.! i++-- | Construct a content identifiers array updated with the association list.+(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c+(//) (Array a) l = Array $ a A.// [(i, e) | (i, Id e) <- l]++-- | Create a content identifiers array from a list of elements.+listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c+listArray bds l = Array $ A.listArray bds [e | Id e <- l]++-- | Create a content identifiers array from an association list.+array :: Ix.Ix i => (i, i) -> [(i, Id c)] -> Array i c+array bds l = Array $ A.array bds [(i, e) | (i, Id e) <- l]++-- | Content identifiers array bounds.+bounds :: Ix.Ix i => Array i c -> (i, i)+bounds (Array a) = A.bounds a
+ Game/LambdaHack/Level.hs view
@@ -0,0 +1,200 @@+-- | Inhabited dungeon levels and the operations to query and change them+-- as the game progresses.+module Game.LambdaHack.Level+  ( -- * The @Level@ type and its components+    Party, PartyItem, SmellMap, SecretMap, ItemMap, TileMap, Level(..)+    -- * Level update+  , updateHeroes, updateMonsters, updateHeroItem, updateMonItem+  , updateSmell, updateIMap, updateLMap, updateLRMap, dropItemsAt+    -- * Level query+  , at, rememberAt, atI, rememberAtI+  , stdRuleset, accessible, openable, findLoc, findLocTry+  ) where++import Data.Binary+import qualified Data.List as L+import qualified Data.IntMap as IM++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.PointXY+import Game.LambdaHack.Point+import Game.LambdaHack.Actor+import Game.LambdaHack.Item+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Random+import Game.LambdaHack.Tile+import qualified Game.LambdaHack.Feature as F+import qualified Game.LambdaHack.Kind as Kind++-- | All actors of a given side on the level.+type Party = IM.IntMap Actor++-- | Items carried by each party member.+type PartyItem = IM.IntMap [Item]++-- | Current smell on map tiles.+type SmellMap = IM.IntMap SmellTime++-- | Current secrecy value on map tiles.+type SecretMap = IM.IntMap SecretStrength++-- | Actual and remembered item lists on map tiles.+type ItemMap = IM.IntMap ([Item], [Item])++-- | Tile kinds on the map.+type TileMap = Kind.Array Point TileKind++-- | A single, inhabited dungeon level.+data Level = Level+  { lheroes   :: Party           -- ^ all heroes on the level+  , lheroItem :: PartyItem       -- ^ hero items+  , lxsize    :: X               -- ^ width of the level+  , lysize    :: Y               -- ^ height of the level+  , lmonsters :: Party           -- ^ all monsters on the level+  , lmonItem  :: PartyItem       -- ^ monster items+  , lsmell    :: SmellMap        -- ^ smells+  , lsecret   :: SecretMap       -- ^ secrecy values+  , litem     :: ItemMap         -- ^ items on the ground+  , lmap      :: TileMap         -- ^ map tiles+  , lrmap     :: TileMap         -- ^ remembered map tiles+  , ldesc     :: String          -- ^ level description for the player+  , lmeta     :: String          -- ^ debug information from cave generation+  , lstairs   :: (Point, Point)  -- ^ destination of the (up, down) stairs+  }+  deriving Show++-- | Update the hero and monster maps.+updateHeroes, updateMonsters :: (Party -> Party) -> Level -> Level+updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) }+updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) }++-- | Update the hero items and monster items maps.+updateHeroItem, updateMonItem :: (PartyItem -> PartyItem) -> Level -> Level+updateHeroItem f lvl = lvl { lheroItem = f (lheroItem lvl) }+updateMonItem f lvl = lvl { lmonItem = f (lmonItem lvl) }++-- | Update the smell map.+updateSmell :: (SmellMap -> SmellMap) -> Level -> Level+updateSmell f lvl = lvl { lsmell = f (lsmell lvl) }++-- | Update the items on the ground map.+updateIMap :: (ItemMap -> ItemMap) -> Level -> Level+updateIMap f lvl = lvl { litem = f (litem lvl) }++-- | Update the tile and remembered tile maps.+updateLMap, updateLRMap :: (TileMap -> TileMap) -> Level -> Level+updateLMap f lvl = lvl { lmap = f (lmap lvl) }+updateLRMap f lvl = lvl { lrmap = f (lrmap lvl) }++-- Note: do not scatter items around, it's too much work for the player.+-- | Place all items on the list at a location on the level.+dropItemsAt :: [Item] -> Point -> Level -> Level+dropItemsAt [] _loc = id+dropItemsAt items loc =+  let joinItems = L.foldl' (\ acc i -> snd (joinItem i acc))+      adj Nothing = Just (items, [])+      adj (Just (i, ri)) = Just (joinItems items i, ri)+  in  updateIMap (IM.alter adj loc)++instance Binary Level where+  put (Level hs hi sx sy ms mi ls le li lm lrm ld lme lstairs) = do+    put hs+    put hi+    put sx+    put sy+    put ms+    put mi+    put ls+    put le+    put (assert+           (IM.null (IM.filter (\ (is1, is2) ->+                                 L.null is1 && L.null is2) li)+           `blame` li) li)+    put lm+    put lrm+    put ld+    put lme+    put lstairs+  get = do+    hs <- get+    hi <- get+    sx <- get+    sy <- get+    ms <- get+    mi <- get+    ls <- get+    le <- get+    li <- get+    lm <- get+    lrm <- get+    ld <- get+    lme <- get+    lstairs <- get+    return (Level hs hi sx sy ms mi ls le li lm lrm ld lme lstairs)++-- | Query for actual and remembered tile kinds on the map.+at, rememberAt :: Level -> Point -> Kind.Id TileKind+at         Level{lmap}  p = lmap Kind.! p+rememberAt Level{lrmap} p = lrmap Kind.! p++-- Note: representations with 2 maps leads to longer code and slower 'remember'.+-- | Query for actual and remembered items on the ground.+atI, rememberAtI :: Level -> Point -> [Item]+atI         Level{litem} p = fst $ IM.findWithDefault ([], []) p litem+rememberAtI Level{litem} p = snd $ IM.findWithDefault ([], []) p litem++-- | The standard ruleset used for level operations.+stdRuleset :: Kind.Ops RuleKind -> RuleKind+stdRuleset Kind.Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"++-- | Check whether one location is accessible from another,+-- using the formula from the standard ruleset.+accessible :: Kind.COps -> Level -> Point -> Point -> Bool+accessible Kind.COps{ cotile=Kind.Ops{okind=okind}, corule}+           lvl@Level{lxsize} sloc tloc =+  let check = raccessible $ stdRuleset corule+      src = okind $ lvl `at` sloc+      tgt = okind $ lvl `at` tloc+  in check lxsize sloc src tloc tgt++-- | Check whether the location contains a door of secrecy lower than @k@+-- and that can be opened according to the standard ruleset.+openable :: Kind.Ops TileKind -> Level -> SecretStrength -> Point -> Bool+openable cops lvl@Level{lsecret} k target =+  let tgt = lvl `at` target+  in hasFeature cops F.Openable tgt ||+     (hasFeature cops F.Hidden tgt &&+      lsecret IM.! target < k)++-- | Find a random location on the map satisfying a predicate.+findLoc :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point+findLoc lmap p =+  let search = do+        loc <- randomR $ Kind.bounds lmap+        let tile = lmap Kind.! loc+        if p loc tile+          then return loc+          else search+  in search++-- | Try to find a random location on the map satisfying+-- the conjunction of the list of predicates.+-- If the premitted number of attempts is not enough,+-- try again the same number of times without the first predicate,+-- then without the first two, etc., until only one predicate remains,+-- at which point try as many times, as needed.+findLocTry :: Int                                  -- ^ the number of tries+           -> TileMap                              -- ^ look up in this map+           -> [Point -> Kind.Id TileKind -> Bool]  -- ^ predicates to satisfy+           -> Rnd Point+findLocTry _        lmap [p] = findLoc lmap p+findLocTry numTries lmap l   = assert (numTries > 0) $+  let search 0 = findLocTry numTries lmap (L.tail l)+      search k = do+        loc <- randomR $ Kind.bounds lmap+        let tile = lmap Kind.! loc+        if L.all (\ p -> p loc tile) l+          then return loc+          else search (k - 1)+  in search numTries
+ Game/LambdaHack/Misc.hs view
@@ -0,0 +1,20 @@+-- | Hacks that haven't found their home yet.+module Game.LambdaHack.Misc+  ( normalLevelBound, Time, divUp, Freqs+  ) where++-- | Level bounds. TODO: query terminal size instead and scroll view.+normalLevelBound :: (Int, Int)+normalLevelBound = (79, 21)++-- | Game time in turns. The time dimension.+type Time = Int++-- | Integer division, rounding up.+divUp :: Int -> Int -> Int+divUp n k = (n + k - 1) `div` k++-- | For each group that the kind belongs to, denoted by a @String@ name+-- in the first component of a pair, the second component of a pair shows+-- how common the kind is within the group.+type Freqs = [(String, Int)]
+ Game/LambdaHack/Msg.hs view
@@ -0,0 +1,50 @@+-- | Game messages displayed on top of the screen for the player to read.+module Game.LambdaHack.Msg+  ( Msg, more, msgEnd, yesno, addMsg, splitMsg, padMsg+  ) where++import qualified Data.List as L+import Data.Char++-- | The type of messages.+type Msg = String++-- | The \"press something to see more\" mark.+more :: Msg+more = " --more--  "++-- | The \"the end of overlays or messages\" mark.+msgEnd :: Msg+msgEnd = " --end--  "++-- | The confirmation request message.+yesno :: Msg+yesno = " [yn]"++-- | Append two messages.+addMsg :: Msg -> Msg -> Msg+addMsg [] x  = x+addMsg xs [] = xs+addMsg xs x  = xs ++ " " ++ x++-- | Split a message into chunks that fit in one line.+splitMsg :: Int -> Msg -> Int -> [String]+splitMsg w xs m+  | w <= m = [xs]   -- border case, we cannot make progress+  | w >= length xs = [xs]   -- no problem, everything fits+  | otherwise =+      let (pre, post) = splitAt (w - m) xs+          (ppre, ppost) = break (`elem` " .,:;!?") $ reverse pre+          rpost = dropWhile isSpace ppost+      in if L.null rpost+         then pre : splitMsg w post m+         else reverse rpost : splitMsg w (reverse ppre ++ post) m++-- | Add spaces at the message end, for display overlayed over the level map.+padMsg :: Int -> String -> String+padMsg w xs =+  case L.reverse xs of+    [] -> xs+    ' ' : _ -> xs+    _ | w == length xs -> xs+    reversed -> L.reverse $ ' ' : reversed
+ Game/LambdaHack/Perception.hs view
@@ -0,0 +1,182 @@+-- | Actors perceiving other actors and the dungeon level.+module Game.LambdaHack.Perception+  ( Perception, totalVisible, debugTotalReachable, perception+  , actorReachesLoc, actorReachesActor, monsterSeesHero+  ) where++import qualified Data.IntSet as IS+import qualified Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad++import Game.LambdaHack.Point+import Game.LambdaHack.State+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.FOV+import qualified Game.LambdaHack.Config as Config+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Content.TileKind++newtype PerceptionReachable = PerceptionReachable+  { preachable :: IS.IntSet+  }++newtype PerceptionVisible = PerceptionVisible+  { pvisible :: IS.IntSet+  }++-- Note: Heroes share visibility and only have separate reachability.+-- The pplayer field must be void if the player is not on the current level.+-- Right now, the field is used only for player-controlled monsters.+-- | The type representing the perception of all actors on the level.+data Perception = Perception+  { pplayer :: Maybe PerceptionReachable+  , pheroes :: IM.IntMap PerceptionReachable+  , ptotal  :: PerceptionVisible+  }++-- | The set of tiles visible by at least one hero.+totalVisible :: Perception -> IS.IntSet+totalVisible = pvisible . ptotal++-- | For debug only: the set of tiles reachable+-- (would be visible if lit) by at least one hero.+debugTotalReachable :: Perception -> IS.IntSet+debugTotalReachable per =+  let lpers = maybeToList (pplayer per) ++ IM.elems (pheroes per)+  in IS.unions (map preachable lpers)++-- | Check whether a location is within the visually reachable area+-- of the given actor (disregarding lighting).+-- Defaults to false if the actor is not player-controlled (monster or hero).+actorReachesLoc :: ActorId -> Point -> Perception -> Maybe ActorId -> Bool+actorReachesLoc actor loc per pl =+  let tryHero = case actor of+                  AMonster _ -> Nothing+                  AHero i -> do+                    hper <- IM.lookup i (pheroes per)+                    return $ loc `IS.member` preachable hper+      tryPl   = do -- the case for a monster under player control+                   guard $ Just actor == pl+                   pper <- pplayer per+                   return $ loc `IS.member` preachable pper+      tryAny  = tryHero `mplus` tryPl+  in fromMaybe False tryAny  -- assume not visible, if no perception found++-- | Check whether an actor is within the visually reachable area+-- of the given actor (disregarding lighting).+-- Not quite correct if FOV not symmetric (e.g., @Shadow@).+-- Defaults to false if neither actor is player-controlled.+actorReachesActor :: ActorId -> ActorId -> Point -> Point+                  -> Perception -> Maybe ActorId+                  -> Bool+actorReachesActor actor1 actor2 loc1 loc2 per pl =+  actorReachesLoc actor1 loc2 per pl ||+  actorReachesLoc actor2 loc1 per pl++-- TODO: When the code for throwing, digital lines and lights is complete.+-- make this a special case of ActorSeesActor.+-- | Whether a monster can see a hero (@False@ if the target is not a hero).+-- An approximation, to avoid computing FOV for the monster.+-- If the target actor has no FOV pre-computed, we assume it can't be seen.+monsterSeesHero :: Kind.Ops TileKind -> Perception -> Level+                 -> ActorId -> ActorId -> Point -> Point -> Bool+monsterSeesHero cotile per lvl _source target sloc tloc =+  let rempty = PerceptionReachable IS.empty+      reachable@PerceptionReachable{preachable} = case target of+        AMonster _ -> rempty+        -- TODO: instead of this fromMaybe clean up how Perception+        -- is regenerated when levels are switched+        AHero    i -> fromMaybe rempty $ IM.lookup i $ pheroes per+  in sloc `IS.member` preachable+     && isVisible cotile reachable lvl IS.empty tloc++-- | Calculate the perception of all actors on the level.+perception :: Kind.COps -> State -> Perception+perception cops@Kind.COps{cotile}+           state@State{ splayer+                      , sconfig+                      , sdebug = DebugMode{smarkVision}+                      } =+  let lvl@Level{lheroes = hs} = slevel state+      mode   = Config.get sconfig "engine" "fovMode"+      radius = let r = Config.get sconfig "engine" "fovRadius"+               in if r < 1+                  then error $ "FOV radius is " ++ show r ++ ", should be >= 1"+                  else r+      -- Perception for a player-controlled monster on the current level.+      mLocPer =+        if isAMonster splayer && memActor splayer state+        then let m = getPlayerBody state+             in Just (bloc m,+                      computeReachable cops radius mode smarkVision m lvl)+        else Nothing+      (mLoc, mPer) = (fmap fst mLocPer, fmap snd mLocPer)+      pers = IM.map (\ h ->+                      computeReachable cops radius mode smarkVision h lvl) hs+      locs = IM.map bloc hs+      lpers = maybeToList mPer ++ IM.elems pers+      reachable = PerceptionReachable $ IS.unions (map preachable lpers)+      -- TODO: Instead of giving the monster a light source, alter vision.+      playerControlledMonsterLight = maybeToList mLoc+      lights = IS.fromList $ playerControlledMonsterLight ++ IM.elems locs+      visible = computeVisible cotile reachable lvl lights+  in  Perception { pplayer = mPer+                 , pheroes = pers+                 , ptotal  = visible+                 }++-- | A location can be directly lit by an ambient shine or a weak, portable+-- light source, e.g,, carried by a hero. (Only lights of radius 0+-- are considered for now and it's assumed they do not reveal hero's position.+-- TODO: change this to be radius 1 noctovision and introduce stronger+-- light sources that show more but make the hero visible.)+-- A location is visible if it's reachable and either directly lit+-- or adjacent to one that is at once directly lit and reachable.+-- The last condition approximates being+-- on the same side of obstacles as the light source.+-- The approximation is not exact for multiple heroes, but the discrepancy+-- can be attributed to deduction based on combined vague visual hints,+-- e.g., if I don't see the reachable light seen by another hero,+-- there must be a wall in-between. Stray rays indicate doors,+-- moving shadows indicate monsters, etc.+computeVisible :: Kind.Ops TileKind -> PerceptionReachable+               -> Level -> IS.IntSet -> PerceptionVisible+computeVisible cops reachable@PerceptionReachable{preachable} lvl lights' =+  let lights = IS.intersection lights' preachable  -- optimization+      isV = isVisible cops reachable lvl lights+  in PerceptionVisible $ IS.filter isV preachable++isVisible :: Kind.Ops TileKind -> PerceptionReachable+          -> Level -> IS.IntSet -> Point -> Bool+isVisible cotile PerceptionReachable{preachable}+               lvl@Level{lxsize, lysize} lights loc0 =+  let litDirectly loc = Tile.isLit cotile (lvl `at` loc)+                        || loc `IS.member` lights+      l_and_R loc = litDirectly loc && loc `IS.member` preachable+  in litDirectly loc0 || L.any l_and_R (vicinity lxsize lysize loc0)++-- | Reachable are all fields on an unblocked path from the hero position.+-- The player's own position is considred reachable by him.+computeReachable :: Kind.COps -> Int -> String -> Maybe FovMode+                 -> Actor -> Level -> PerceptionReachable+computeReachable Kind.COps{cotile, coactor=Kind.Ops{okind}}+                 radius mode smarkVision actor lvl =+  let fovMode m =+        if not $ asight $ okind $ bkind m+        then Blind+        else case smarkVision of+          Just fm -> fm+          Nothing -> case mode of+            "shadow"     -> Shadow+            "permissive" -> Permissive+            "digital"    -> Digital radius+            _            -> error $ "Unknown FOV mode: " ++ show mode+      ploc = bloc actor+  in PerceptionReachable $+       IS.insert ploc $ IS.fromList $ fullscan cotile (fovMode actor) ploc lvl
+ Game/LambdaHack/Place.hs view
@@ -0,0 +1,176 @@+-- | Generation of places from place kinds.+{-# LANGUAGE RankNTypes #-}+module Game.LambdaHack.Place+  ( TileMapXY, Place(..), placeValid, buildFence, buildPlace+  ) where++import Data.Binary+import qualified Data.Map as M+import qualified Data.List as L+import qualified Data.Set as S++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Content.PlaceKind+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Area+import Game.LambdaHack.PointXY+import Game.LambdaHack.Misc+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Random++-- TODO: use more, rewrite as needed, document each field.+-- | The parameters of a place. Most are immutable and set+-- at the time when a place is generated.+data Place = Place+  { qkind        :: !(Kind.Id PlaceKind)+  , qarea        :: !Area+  , qseen        :: !Bool+  , qlegend      :: !String+  , qsolidFence  :: !(Kind.Id TileKind)+  , qhollowFence :: !(Kind.Id TileKind)+  }+  deriving Show++instance Binary Place where+  put Place{..} = do+    put qkind+    put qarea+    put qseen+    put qlegend+    put qsolidFence+    put qhollowFence+  get = do+    qkind <- get+    qarea <- get+    qseen <- get+    qlegend <- get+    qsolidFence <- get+    qhollowFence <- get+    return Place{..}++-- | The map of tile kinds in a place (and generally anywhere in a cave).+-- The map is sparse. The default tile that eventually fills the empty spaces+-- is specified in the cave kind specification with @cdefTile@.+type TileMapXY = M.Map PointXY (Kind.Id TileKind)++-- | For @CAlternate@ tiling, require the place be comprised+-- of an even number of whole corners, with exactly one square+-- overlap between consecutive coners and no trimming.+-- For other tiling methods, check that the area is large enough for tiling+-- the corner twice in each direction, with a possible one row/column overlap.+placeValid :: Area       -- ^ the area to fill+           -> PlaceKind  -- ^ the place kind to construct+           -> Bool+placeValid r PlaceKind{..} =+  let (x0, y0, x1, y1) = expandFence pfence r+      dx = x1 - x0 + 1+      dy = y1 - y0 + 1+      dxcorner = case ptopLeft of [] -> 0 ; l : _ -> L.length l+      dycorner = L.length ptopLeft+      wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&+                                  (d - 1) `mod` (2 * (dcorner - 1)) == 0+  in case pcover of+    CAlternate -> wholeOverlapped dx dxcorner &&+                  wholeOverlapped dy dycorner+    _          -> dx >= 2 * dxcorner - 1 &&+                  dy >= 2 * dycorner - 1++-- | Modify available room area according to fence type.+expandFence :: Fence -> Area -> Area+expandFence fence r = case fence of+  FWall  -> r+  FFloor -> expand r (-1)+  FNone  -> expand r 1++-- | Given a few parameters, roll and construct a 'Place' datastructure+-- and fill a cave section acccording to it.+buildPlace :: Kind.COps         -- ^ the game content+           -> Kind.Id TileKind  -- ^ fence tile, if fence solid+           -> Kind.Id TileKind  -- ^ fence tile, if fence hollow+           -> RollDeep          -- ^ the chance of a dark place+           -> Int               -- ^ current level depth+           -> Int               -- ^ maximum depth+           -> Area              -- ^ interior area of the place+           -> Rnd (TileMapXY, Place)+buildPlace Kind.COps{cotile, coplace=Kind.Ops{okind=pokind, opick=popick}}+           qsolidFence qhollowFence cdarkChance lvl depth+           r = assert (not (trivialArea r) `blame` r) $ do+  dark <- chanceDeep lvl depth cdarkChance+  qkind <- popick "rogue" (placeValid r)+  let kr = pokind qkind+      qlegend = if dark then "darkLegend" else "litLegend"+      qseen = False+      qarea = expandFence (pfence kr) r+      place = assert (validArea qarea `blame` qarea) $+              Place{..}+  legend <- olegend cotile qlegend+  let xlegend = M.insert 'X' qhollowFence legend+  return (digPlace place kr xlegend, place)++-- | Roll a legend of a place plan: a map from plan symbols to tile kinds.+olegend :: Kind.Ops TileKind -> String -> Rnd (M.Map Char (Kind.Id TileKind))+olegend Kind.Ops{ofoldrWithKey, opick} group =+  let getSymbols _ tk acc =+        maybe acc (const $ S.insert (tsymbol tk) acc)+          (L.lookup group $ tfreq tk)+      symbols = ofoldrWithKey getSymbols S.empty+      getLegend s acc = do+        m <- acc+        tk <- opick group $ (== s) . tsymbol+        return $ M.insert s tk m+      legend = S.fold getLegend (return M.empty) symbols+  in legend++-- | Construct a fence around an area, with the given tile kind.+buildFence :: Kind.Id TileKind -> Area -> TileMapXY+buildFence fenceId (x0, y0, x1, y1) =+  M.fromList $ [ (PointXY (x, y), fenceId)+               | x <- [x0-1, x1+1], y <- [y0..y1] ] +++               [ (PointXY (x, y), fenceId)+               | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]++-- | Construct a place of the given kind, with the given fence tile.+digPlace :: Place                          -- ^ the place parameters+         -> PlaceKind                      -- ^ the place kind+         -> M.Map Char (Kind.Id TileKind)  -- ^ the legend+         -> TileMapXY+digPlace Place{..} kr legend =+  let fence = case pfence kr of+        FWall  -> buildFence qsolidFence qarea+        FFloor -> buildFence qhollowFence qarea+        FNone  -> M.empty+  in M.union (M.map (legend M.!) $ tilePlace qarea kr) fence++-- | Create a place by tiling patterns.+tilePlace :: Area                           -- ^ the area to fill+          -> PlaceKind                      -- ^ the place kind to construct+          -> M.Map PointXY Char+tilePlace (x0, y0, x1, y1) PlaceKind{..} =+  let dx = x1 - x0 + 1+      dy = y1 - y0 + 1+      fromX (x, y) = L.map PointXY $ L.zip [x..] (repeat y)+      fillInterior :: (forall a. Int -> [a] -> [a]) -> [(PointXY, Char)]+      fillInterior f =+        let tileInterior (y, row) = L.zip (fromX (x0, y)) $ f dx row+            reflected = L.zip [y0..] $ f dy ptopLeft+        in L.concatMap tileInterior reflected+      tileReflect :: Int -> [a] -> [a]+      tileReflect d pat =+        let lstart = L.take (d `divUp` 2) pat+            lend   = L.take (d `div`   2) pat+        in lstart ++ L.reverse lend+      interior = case pcover of+        CAlternate ->+          let tile :: Int -> [a] -> [a]+              tile d pat =+                L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat))+          in fillInterior tile+        CStretch ->+          let stretch :: Int -> [a] -> [a]+              stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat))+          in fillInterior stretch+        CReflect ->+          let reflect :: Int -> [a] -> [a]+              reflect d pat = tileReflect d (L.cycle pat)+          in fillInterior reflect+  in M.fromList interior
+ Game/LambdaHack/Point.hs view
@@ -0,0 +1,85 @@+-- | Basic operations on 2D points represented as linear offsets.+module Game.LambdaHack.Point+  ( Point, toPoint, showPoint+  , origin, chessDist, adjacent, vicinity, vicinityCardinal+  , inside, displacement+  ) where++import Game.LambdaHack.PointXY+import Game.LambdaHack.VectorXY+import Game.LambdaHack.Area+import Game.LambdaHack.Utils.Assert++-- | The type of locations on the 2D level map, heavily optimized.+--+-- We represent the (level map on the) screen as a linear framebuffer,+-- where @Point@ is an @Int@ offset counted from the first cell.+-- We do bounds check for the X size whenever we convert between+-- representations and each subsequent+-- array access performs another check, effectively for Y size.+-- After dungeon is generated (using @PointXY@, not @Point@),+-- and converted to the @Point@ representation, points are used+-- mainly as keys and not constructed often, so the performance will improve+-- due to smaller save files, the use of @IntMap@ and cheaper array indexing,+-- including cheaper bounds checks.+-- We don't defin @Point@ as a newtype to avoid the trouble+-- with using @EnumMap@ in place of @IntMap@, etc.+type Point = Int++-- | Print a point as a tuple of cartesian coordinates.+showPoint :: X -> Point -> String+showPoint lxsize = show . fromPoint lxsize++-- | Conversion from cartesian coordinates to @Point@.+toPoint :: X -> PointXY -> Point+toPoint lxsize (PointXY (x, y)) =+  assert (lxsize > x && x >= 0 && y >= 0 `blame` (lxsize, x, y)) $+  x + y * lxsize++-- | Conversion from @Point@ to cartesian coordinates.+fromPoint :: X -> Point -> PointXY+fromPoint lxsize loc =+  assert (loc >= 0 `blame` (lxsize, loc)) $+  PointXY (loc `rem` lxsize, loc `quot` lxsize)++-- | The top-left corner location of the level.+origin :: Point+origin = 0++-- | The distance between two points in the chessboard metric.+chessDist :: X -> Point -> Point -> Int+chessDist lxsize loc0 loc1+  | PointXY (x0, y0) <- fromPoint lxsize loc0+  , PointXY (x1, y1) <- fromPoint lxsize loc1 =+  chessDistXY $ VectorXY (x1 - x0, y1 - y0)++-- | Checks whether two points are adjacent on the map+-- (horizontally, vertically or diagonally).+adjacent :: X -> Point -> Point -> Bool+adjacent lxsize s t = chessDist lxsize s t == 1++-- | Returns the 8, or less, surrounding locations of a given location.+vicinity :: X -> Y -> Point -> [Point]+vicinity lxsize lysize loc =+  map (toPoint lxsize) $+    vicinityXY (0, 0, lxsize - 1, lysize - 1) $+      fromPoint lxsize loc++-- | Returns the 4, or less, surrounding locations in cardinal directions+-- from a given location.+vicinityCardinal :: X -> Y -> Point -> [Point]+vicinityCardinal lxsize lysize loc =+  map (toPoint lxsize) $+    vicinityCardinalXY (0, 0, lxsize - 1, lysize - 1) $+      fromPoint lxsize loc++-- | Checks that a point belongs to an area.+inside :: X -> Point -> Area -> Bool+inside lxsize loc = insideXY $ fromPoint lxsize loc++-- | Calculate the displacement vector of a location wrt another location.+displacement :: X -> Point -> Point -> VectorXY+displacement lxsize loc0 loc1+  | PointXY (x0, y0) <- fromPoint lxsize loc0+  , PointXY (x1, y1) <- fromPoint lxsize loc1 =+  VectorXY (x1 - x0, y1 - y0)
+ Game/LambdaHack/PointXY.hs view
@@ -0,0 +1,41 @@+-- | Basic cartesian geometry operations on 2D points.+module Game.LambdaHack.PointXY+  ( X, Y, PointXY(..), fromTo, sortPointXY+  ) where++import qualified Data.List as L++import Game.LambdaHack.Utils.Assert++-- | Spacial dimension for points and vectors.+type X = Int++-- | Spacial dimension for points and vectors.+type Y = Int++-- | 2D points in cartesian representation.+newtype PointXY = PointXY (X, Y)+  deriving (Eq, Ord)++instance Show PointXY where+  show (PointXY (x, y)) = show (x, y)++-- | A list of all points on a straight vertical or straight horizontal line+-- between two points. Fails if no such line exists.+fromTo :: PointXY -> PointXY -> [PointXY]+fromTo (PointXY (x0, y0)) (PointXY (x1, y1)) =+ let result+       | x0 == x1 = L.map (\ y -> PointXY (x0, y)) (fromTo1 y0 y1)+       | y0 == y1 = L.map (\ x -> PointXY (x, y0)) (fromTo1 x0 x1)+       | otherwise = assert `failure` ((x0, y0), (x1, y1))+ in result++fromTo1 :: Int -> Int -> [Int]+fromTo1 x0 x1+  | x0 <= x1  = [x0..x1]+  | otherwise = [x0,x0-1..x1]++-- | Sort the sequence of two points, in the derived lexicographic order.+sortPointXY :: (PointXY, PointXY) -> (PointXY, PointXY)+sortPointXY (a, b) | a <= b    = (a, b)+                   | otherwise = (b, a)
+ Game/LambdaHack/Random.hs view
@@ -0,0 +1,143 @@+-- | Representation of probabilities and random computations.+module Game.LambdaHack.Random+  ( -- * The @Rng@ monad+    Rnd+    -- * Random operations+  , randomR, oneOf, frequency, roll+    -- * Rolling dice+  , RollDice(..), rollDice, maxDice, minDice, meanDice+    -- * Rolling 2D coordinates+  , RollDiceXY(..), rollDiceXY+    -- * Rolling dependent on depth+  , RollDeep, rollDeep, chanceDeep, intToDeep, maxDeep+    -- * Fractional chance+  , Chance, chance+  ) where++import qualified Data.Binary as Binary+import Data.Ratio+import qualified System.Random as R+import Control.Monad+import qualified Data.List as L+import qualified Control.Monad.State as MState++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Utils.Frequency++-- | The monad of computations with random generator state.+type Rnd a = MState.State R.StdGen a++-- | Get a random object within a range with a uniform distribution.+randomR :: (R.Random a) => (a, a) -> Rnd a+randomR range = MState.state $ R.randomR range++-- | Get any element of a list with equal probability.+oneOf :: [a] -> Rnd a+oneOf xs = do+  r <- randomR (0, length xs - 1)+  return (xs !! r)++-- | Gen an element according to a frequency distribution.+frequency :: Show a => Frequency a -> Rnd a+frequency fr = MState.state $ rollFreq fr++-- | Roll a single die.+roll :: Int -> Rnd Int+roll x = if x <= 0 then return 0 else randomR (1, x)++-- | Dice: 1d7, 3d3, 1d0, etc.+-- @RollDice a b@ represents @a@ rolls of @b@-sided die.+data RollDice = RollDice Binary.Word8 Binary.Word8+  deriving (Eq, Ord)++instance Show RollDice where+  show (RollDice a b) = show a ++ "d" ++ show b++instance Read RollDice where+  readsPrec d s =+    let (a, db) = L.break (== 'd') s+        av = read a+    in case db of+      'd' : b -> [ (RollDice av bv, rest) | (bv, rest) <- readsPrec d b ]+      _ -> []++-- | Roll dice and sum the results.+rollDice :: RollDice -> Rnd Int+rollDice (RollDice a' 1)  = return $ fromEnum a'  -- optimization+rollDice (RollDice a' b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in liftM sum (replicateM a (roll b))++-- | Maximal value of dice.+maxDice :: RollDice -> Int+maxDice (RollDice a' b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in a * b++-- | Minimal value of dice.+minDice :: RollDice -> Int+minDice (RollDice a' b') =+  let (a, b) = (fromEnum a', fromEnum b')+  in if b == 0 then 0 else a++-- | Mean value of dice.+meanDice :: RollDice -> Rational+meanDice (RollDice a' b') =+  let (a, b) = (fromIntegral a', fromIntegral b')+  in if b' == 0 then 0 else a * (b + 1) % 2++-- | Dice for rolling a pair of integer parameters pertaining to,+-- respectively, the X and Y cartesian 2D coordinates.+data RollDiceXY = RollDiceXY (RollDice, RollDice)+  deriving Show++-- | Roll the two sets of dice.+rollDiceXY :: RollDiceXY -> Rnd (Int, Int)+rollDiceXY (RollDiceXY (xd, yd)) = do+  x <- rollDice xd+  y <- rollDice yd+  return (x, y)++-- | Dice for parameters scaled with current level depth.+-- To the result of rolling the first set of dice we add the second,+-- scaled in proportion to current depth divided by maximal dungeon depth.+type RollDeep = (RollDice, RollDice)++-- | Roll dice scaled with current level depth.+-- Note that at the first level, the scaled dice are always ignored.+rollDeep :: Int -> Int -> RollDeep -> Rnd Int+rollDeep n depth (d1, d2) =+  assert (n > 0 && n <= depth `blame` (n, depth)) $ do+  r1 <- rollDice d1+  r2 <- rollDice d2+  return $ r1 + ((n - 1) * r2) `div` (depth - 1)++-- | Roll dice scaled with current level depth and return @True@+-- if the results if greater than 50.+chanceDeep :: Int -> Int -> RollDeep -> Rnd Bool+chanceDeep n depth deep = do+  c <- rollDeep n depth deep+  return $ c > 50++-- | Generate a @RollDeep@ that always gives a constant integer.+intToDeep :: Int -> RollDeep+intToDeep 0  = (RollDice 0 0, RollDice 0 0)+intToDeep n' = let n = toEnum n'+               in if n > maxBound || n < minBound+                  then assert `failure` n'+                  else (RollDice n 1, RollDice 0 0)++-- | Maximal value of scaled dice.+maxDeep :: RollDeep -> Int+maxDeep (d1, d2) = maxDice d1 + maxDice d2++-- | Fractional chance.+type Chance = Rational++-- | Give @True@, with probability determined by the fraction.+chance :: Chance -> Rnd Bool+chance r = do+  let n = numerator r+      d = denominator r+  k <- randomR (1, d)+  return (k <= n)
+ Game/LambdaHack/Running.hs view
@@ -0,0 +1,187 @@+-- | Running and disturbance.+module Game.LambdaHack.Running+  ( run, continueRun+  ) where++import Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS++import Game.LambdaHack.Utils.Assert+import Game.LambdaHack.Action+import Game.LambdaHack.Actions+import Game.LambdaHack.Point+import Game.LambdaHack.Vector+import Game.LambdaHack.PointXY+import Game.LambdaHack.Level+import Game.LambdaHack.Msg+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Perception+import Game.LambdaHack.State+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import qualified Game.LambdaHack.Feature as F++-- | Start running in the given direction and with the given number+-- of tiles already traversed (usually 0). The first step of running+-- succeeds much more often than subsequent steps, because most+-- of the disturbances are ignored, since the player is aware of them+-- and still explicitly requests a run.+run :: (Vector, Int) -> Action ()+run (dir, dist) = do+  cops <- contentOps+  pl <- gets splayer+  locHere <- gets (bloc . getPlayerBody)+  lvl <- gets slevel+  targeting <- gets (ctargeting . scursor)+  if targeting /= TgtOff+    then moveCursor dir 10+    else do+      let accessibleDir loc d = accessible cops lvl loc (loc `shift` d)+          -- Do not count distance if we just open a door.+          distNew = if accessibleDir locHere dir then dist + 1 else dist+      updatePlayerBody (\ p -> p { bdir = Just (dir, distNew) })+      -- attacks and opening doors disallowed while running+      moveOrAttack False pl dir++-- | Player running mode, determined from the nearby cave layout.+data RunMode =+    RunOpen                     -- ^ open space, in particular the T crossing+  | RunHub                      -- ^ a hub of separate corridors+  | RunCorridor (Vector, Bool)  -- ^ a single corridor, turning here or not+  | RunDeadEnd                  -- ^ dead end++-- | Determine the running mode. For corridors, pick the running direction+-- trying to explore all corners, by prefering cardinal to diagonal moves.+runMode :: Point -> Vector -> (Point -> Vector -> Bool) -> X -> RunMode+runMode loc dir dirEnterable lxsize =+  let dirNearby dir1 dir2 = euclidDistSq lxsize dir1 dir2 == 1+      dirBackward d = euclidDistSq lxsize (neg dir) d <= 1+      dirAhead d = euclidDistSq lxsize dir d <= 2+      findOpen =+        let f dirC open = open +++              case L.filter (dirNearby dirC) dirsEnterable of+                l | dirBackward dirC -> dirC : l  -- points backwards+                []  -> []  -- a narrow corridor, just one tile wide+                [_] -> []  -- a turning corridor, two tiles wide+                l   -> dirC : l  -- too wide+        in L.foldr f []+      dirsEnterable = L.filter (dirEnterable loc) (moves lxsize)+  in case dirsEnterable of+    [] -> assert `failure` (loc, dir)+    [negdir] -> assert (negdir == neg dir) $ RunDeadEnd+    _ ->+      let dirsOpen = findOpen dirsEnterable+          dirsCorridor = dirsEnterable L.\\ dirsOpen+      in case dirsCorridor of+        [] -> RunOpen  -- no corridors+        _ | L.any dirAhead dirsOpen -> RunOpen  -- open space ahead+        [d] -> RunCorridor (d, False)  -- corridor with no turn+        [d1, d2] | dirNearby d1 d2 ->  -- corridor with a turn+          -- Prefer cardinal to diagonal dirs, for hero safety,+          -- even if that means changing direction.+          RunCorridor (if diagonal lxsize d1 then d2 else d1, True)+        _ -> RunHub  -- a hub of many separate corridors++-- | Check for disturbances to running such newly visible items, monsters, etc.+runDisturbance :: Point -> Int -> Msg -> Party -> Party -> Perception -> Point+               -> (F.Feature -> Point -> Bool) -> (Point -> Bool) -> X -> Y+               -> (Vector, Int) -> Maybe (Vector, Int)+runDisturbance locLast distLast msg hs ms per locHere+               locHasFeature locHasItems lxsize lysize (dirNew, distNew) =+  let msgShown  = not (L.null msg)+      mslocs    = IS.delete locHere $ IS.fromList (L.map bloc (IM.elems ms))+      enemySeen = not (IS.null (mslocs `IS.intersection` totalVisible per))+      surrLast  = locLast : vicinity lxsize lysize locLast+      surrHere  = locHere : vicinity lxsize lysize locHere+      locThere  = locHere `shift` dirNew+      heroThere = locThere `elem` L.map bloc (IM.elems hs)+      -- Stop if you touch any individual tile with these propereties+      -- first time, unless you enter it next move, in which case stop then.+      touchList = [ locHasFeature F.Exit+                  , locHasItems+                  ]+      -- Here additionally ignore a tile property if you stand on such tile.+      standList = [ locHasFeature F.Path+                  , not . locHasFeature F.Lit+                  ]+      -- Here stop only if you touch any such tile for the first time.+      -- TODO: stop when running along a path and it ends (or turns).+      -- TODO: perhaps in open areas change direction to follow lit and paths.+      firstList = [ locHasFeature F.Lit+                  , not . locHasFeature F.Path+                  ]+      -- TODO: stop when walls vanish from cardinal directions or when any+      -- walls re-appear again. Actually stop one tile before that happens.+      -- Then remove some other, subsumed conditions.+      -- This will help with corridors starting in dark rooms.+      touchNew fun =+        let touchLast = L.filter fun surrLast+            touchHere = L.filter fun surrHere+        in touchHere L.\\ touchLast+      touchExplore fun = touchNew fun == [locThere]+      touchStop fun = touchNew fun /= []+      standNew fun = L.filter (\ loc -> locHasFeature F.Walkable loc ||+                                        locHasFeature F.Openable loc)+                       (touchNew fun)+      standExplore fun = not (fun locHere) && standNew fun == [locThere]+      standStop fun = not (fun locHere) && standNew fun /= []+      firstNew fun = L.all (not . fun) surrLast &&+                     L.any fun surrHere+      firstExplore fun = firstNew fun && fun locThere+      firstStop = firstNew+      tryRunMaybe+        | msgShown || enemySeen+          || heroThere || distLast >= 40  = Nothing+        | L.any touchExplore touchList    = Just (dirNew, 1000)+        | L.any standExplore standList    = Just (dirNew, 1000)+        | L.any firstExplore firstList    = Just (dirNew, 1000)+        | L.any touchStop touchList       = Nothing+        | L.any standStop standList       = Nothing+        | L.any firstStop firstList       = Nothing+        | otherwise                       = Just (dirNew, distNew)+  in tryRunMaybe++-- | This function implements the actual logic of running. It checks if we+-- have to stop running because something interesting cropped up,+-- it ajusts the direction given by the vector if we reached+-- a corridor's corner (we never change direction except in corridors)+-- and it increments the counter of traversed tiles.+continueRun :: (Vector, Int) -> Action ()+continueRun (dirLast, distLast) = do+  cops@Kind.COps{cotile} <- contentOps+  locHere <- gets (bloc . getPlayerBody)+  per <- currentPerception+  msg <- currentMsg+  ms  <- gets (lmonsters . slevel)+  hs  <- gets (lheroes . slevel)+  lvl@Level{lxsize, lysize} <- gets slevel+  let locHasFeature f loc = Tile.hasFeature cotile f (lvl `at` loc)+      locHasItems loc = not $ L.null $ lvl `atI` loc+      locLast = if distLast == 0 then locHere else locHere `shift` neg dirLast+      tryRunDist (dir, distNew)+        | accessibleDir locHere dir =+          maybe abort run $+            runDisturbance locLast distLast msg hs ms per locHere+              locHasFeature locHasItems lxsize lysize (dir, distNew)+        | otherwise = abort  -- do not open doors in the middle of a run+      tryRun dir = tryRunDist (dir, distLast)+      tryRunAndStop dir = tryRunDist (dir, 1000)+      accessibleDir loc dir = accessible cops lvl loc (loc `shift` dir)+      openableDir loc dir   = Tile.hasFeature cotile F.Openable+                                (lvl `at` (loc `shift` dir))+      dirEnterable loc d = accessibleDir loc d || openableDir loc d+  case runMode locHere dirLast dirEnterable lxsize of+    RunDeadEnd -> abort                   -- we don't run backwards+    RunOpen    -> tryRun dirLast          -- run forward into the open space+    RunHub     -> abort                   -- stop and decide where to go+    RunCorridor (dirNext, turn) ->        -- look ahead+      case runMode (locHere `shift` dirNext) dirNext dirEnterable lxsize of+        RunDeadEnd     -> tryRun dirNext  -- explore the dead end+        RunCorridor _  -> tryRun dirNext  -- follow the corridor+        RunOpen | turn -> abort           -- stop and decide when to turn+        RunHub  | turn -> abort           -- stop and decide when to turn+        RunOpen -> tryRunAndStop dirNext  -- no turn, get closer and stop+        RunHub  -> tryRunAndStop dirNext  -- no turn, get closer and stop
+ Game/LambdaHack/Save.hs view
@@ -0,0 +1,132 @@+-- | Saving and restoring games and player diaries.+module Game.LambdaHack.Save+  ( saveGame, restoreGame, rmBkpSaveDiary, saveGameBkp+  ) where++import System.Directory+import System.FilePath+import qualified Control.Exception as E hiding (handle)+import Control.Monad++import Game.LambdaHack.Utils.File+import Game.LambdaHack.State+import qualified Game.LambdaHack.Config as Config++-- | Name of the save game.+saveFile :: Config.CP -> IO FilePath+saveFile config = Config.getFile config "files" "saveFile"++-- | Name of the backup of the save game.+bkpFile :: Config.CP -> IO FilePath+bkpFile config = do+  sfile <- saveFile config+  return $ sfile ++ ".bkp"++-- | Name of the persistent player diary.+diaryFile :: Config.CP -> IO FilePath+diaryFile config = Config.getFile config "files" "diaryFile"++-- | Save a simple serialized version of the current player diary.+saveDiary :: State -> Diary -> IO ()+saveDiary state diary = do+  dfile <- diaryFile (sconfig state)+  encodeEOF dfile diary++-- | Save a simple serialized version of the current state and diary.+saveGame :: State -> Diary -> IO ()+saveGame state diary = do+  sfile <- saveFile (sconfig state)+  encodeEOF sfile state+  saveDiary state diary  -- save the diary often in case of crashes++-- | Try to create a directory. Hide errors due to,+-- e.g., insufficient permissions, because the game can run+-- in the current directory just as well.+tryCreateDir :: FilePath -> IO ()+tryCreateDir dir =+  E.catch+    (createDirectory dir)+    (\ e -> case e :: E.IOException of _ -> return ())++-- TODO: perhaps take the target "scores" file name from config.+-- TODO: perhaps source and "config", too, to be able to change all+-- in one place.+-- | Try to copy over data files. Hide errors due to,+-- e.g., insufficient permissions, because the game can run+-- without data files just as well.+tryCopyDataFiles :: (FilePath -> IO FilePath) -> FilePath -> IO ()+tryCopyDataFiles pathsDataFile dirNew = do+  configFile <- pathsDataFile "config.default"+  scoresFile <- pathsDataFile "scores"+  let configNew = combine dirNew "config"+      scoresNew = combine dirNew "scores"+  E.catch+    (copyFile configFile configNew >>+     copyFile scoresFile scoresNew)+    (\ e -> case e :: E.IOException of _ -> return ())++-- | Restore a saved game, if it exists. Initialize directory structure,+-- if needed.+restoreGame :: (FilePath -> IO FilePath) -> Config.CP -> String+            -> IO (Either (State, Diary) (String, Diary))+restoreGame pathsDataFile config title = do+  appData <- Config.appDataDir+  ab <- doesDirectoryExist appData+  -- If the directory can't be created, the current directory will be used.+  unless ab $ do+    tryCreateDir appData+    -- Possibly copy over data files. No problem if it fails.+    tryCopyDataFiles pathsDataFile appData+  -- If the diary file does not exist, create an empty diary.+  diary <-+    do dfile <- diaryFile config+       db <- doesFileExist dfile+       if db+         then strictDecodeEOF dfile+         else defaultDiary+  -- If the savefile exists but we get IO errors, we show them,+  -- back up the savefile and move it out of the way and start a new game.+  -- If the savefile was randomly corrupted or made read-only,+  -- that should solve the problem. If the problems are more serious,+  -- the other functions will most probably also throw exceptions,+  -- this time without trying to fix it up.+  sfile <- saveFile config+  sb <- doesFileExist sfile+  if sb+    then E.catch+      (do mvBkp config+          bfile <- bkpFile config+          state <- strictDecodeEOF bfile+          return $ Left (state, diary))+      (\ e -> case e :: E.SomeException of+                _ -> let msg = "Starting a new game, because restore failed. "+                               ++ "The error message was: "+                               ++ (unwords . lines) (show e)+                     in return $ Right (msg, diary))+    else+      return $ Right ("Welcome to " ++ title ++ "!", diary)++-- | Move the savegame file to a backup slot.+mvBkp :: Config.CP -> IO ()+mvBkp config = do+  sfile <- saveFile config+  bfile <- bkpFile config+  renameFile sfile bfile++-- | Save the diary and a backup of the save game file, in case of crashes.+saveGameBkp :: State -> Diary -> IO ()+saveGameBkp state diary = do+  saveGame state diary+  mvBkp (sconfig state)++-- | Remove the backup of the savegame and save the player diary.+-- Should be called before any non-error exit from the game.+-- Sometimes the backup file does not exist and it's OK.+-- We don't bother reporting any other removal exceptions, either,+-- because the backup file is relatively unimportant.+rmBkpSaveDiary :: State -> Diary -> IO ()+rmBkpSaveDiary state diary = do+  saveDiary state diary  -- save the diary often in case of crashes+  bfile <- bkpFile (sconfig state)+  bb <- doesFileExist bfile+  when bb $ removeFile bfile
+ Game/LambdaHack/Start.hs view
@@ -0,0 +1,66 @@+-- | Setting up game data and restoring or starting a game.+module Game.LambdaHack.Start ( start ) where++import qualified Control.Monad.State as MState+import qualified Data.Array.Unboxed as A++import Game.LambdaHack.Action+import Game.LambdaHack.State+import qualified Game.LambdaHack.DungeonState as DungeonState+import qualified Game.LambdaHack.Save as Save+import Game.LambdaHack.Turn+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.ActorState+import Game.LambdaHack.Item+import qualified Game.LambdaHack.Feature as F+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Tile+import Game.LambdaHack.Level+import qualified Game.LambdaHack.Kind as Kind++speedup :: Kind.Ops TileKind -> Kind.Speedup TileKind+speedup Kind.Ops{ofoldrWithKey, obounds} =+  let createTab :: (TileKind -> Bool) -> A.UArray (Kind.Id TileKind) Bool+      createTab p =+        let f _ k acc = p k : acc+            clearAssocs = ofoldrWithKey f []+        in A.listArray obounds clearAssocs+      tabulate :: (TileKind -> Bool) -> Kind.Id TileKind -> Bool+      tabulate p = (createTab p A.!)+      isClearTab = tabulate $ kindHasFeature F.Clear+      isLitTab   = tabulate $ kindHasFeature F.Lit+  in Kind.TileSpeedup {isClearTab, isLitTab}++-- | Compute and insert auxiliary optimized components into game content,+-- to be used in time-critical sections of the code.+speedupCops :: Session -> Session+speedupCops sess@Session{scops = cops@Kind.COps{cotile=tile}} =+  let ospeedup = speedup tile+      cotile = tile {Kind.ospeedup}+      scops = cops {Kind.cotile}+  in sess {scops}++-- | Either restore a saved game, or setup a new game.+-- Then call the main game loop.+start :: Config.CP -> Session -> IO ()+start config1 slowSess = do+  let sess@Session{scops = cops@Kind.COps{corule}} = speedupCops slowSess+      title = rtitle $ stdRuleset corule+      pathsDataFile = rpathsDataFile $ stdRuleset corule+  restored <- Save.restoreGame pathsDataFile config1 title+  case restored of+    Right (msg, diary) -> do  -- Starting a new game.+      (g2, config2) <- Config.getSetGen config1 "dungeonRandomGenerator"+      let (DungeonState.FreshDungeon{..}, ag) =+            MState.runState (DungeonState.generate cops config2) g2+          sflavour = MState.evalState (dungeonFlavourMap (Kind.coitem cops)) ag+      (g3, config3) <- Config.getSetGen config2 "startingRandomGenerator"+      let state = defaultState+                    config3 sflavour freshDungeon entryLevel entryLoc g3+          hstate = initialHeroes cops entryLoc state+      handlerToIO sess hstate diary{smsg = msg} handle+    Left (state, diary) ->  -- Running a restored a game.+      handlerToIO sess state+        diary{smsg = "Welcome back to " ++ title ++ "."}  -- TODO:save old msg?+        handle
+ Game/LambdaHack/State.hs view
@@ -0,0 +1,218 @@+-- | Game state and persistent player diary types and operations.+module Game.LambdaHack.State+  ( -- * Game state+    State(..), TgtMode(..), Cursor(..)+    -- * Accessor+  , slevel+    -- * Constructor+  , defaultState+    -- * State update+  , updateCursor, updateTime, updateDiscoveries, updateLevel, updateDungeon+    -- * Player diary+  , Diary(..), defaultDiary+    -- * Debug flags+  , DebugMode(..), cycleMarkVision, toggleOmniscient+  ) where++import qualified Data.Set as S+import qualified Data.IntSet as IS+import Data.Binary+import qualified Game.LambdaHack.Config as Config+import qualified System.Random as R+import System.Time++import Game.LambdaHack.Actor+import Game.LambdaHack.Misc+import Game.LambdaHack.Point+import Game.LambdaHack.Level+import qualified Game.LambdaHack.Dungeon as Dungeon+import Game.LambdaHack.Item+import Game.LambdaHack.Msg+import Game.LambdaHack.FOV++-- | The diary contains all the player data+-- that carries over from game to game.+-- That includes the last message, previous messages and otherwise recorded+-- history of past games. This can be used for calculating player+-- achievements, unlocking advanced game features and general data mining.+data Diary = Diary+  { smsg         :: Msg+  , shistory     :: [Msg]+  }++-- | The state of a single game that can be save and restored.+-- In practice, we maintain some extra state, but it's+-- temporary for a single turn or relevant only to the current session.+data State = State+  { splayer  :: ActorId      -- ^ represents the player-controlled actor+  , scursor  :: Cursor       -- ^ cursor location and level to return to+  , stime    :: Time         -- ^ current in-game time+  , sflavour :: FlavourMap   -- ^ association of flavour to items+  , sdisco   :: Discoveries  -- ^ items (kinds) that have been discovered+  , sdungeon :: Dungeon.Dungeon  -- ^ all dungeon levels+  , slid     :: Dungeon.LevelId  -- ^ identifier of the current level+  , scounter :: (Int, Int)   -- ^ stores next hero index and monster index+  , sparty   :: IS.IntSet    -- ^ heroes in the party+  , srandom  :: R.StdGen     -- ^ current random generator+  , sconfig  :: Config.CP    -- ^ game config+  , sdebug   :: DebugMode    -- ^ debugging mode+  }+  deriving Show++-- | Current targeting mode of the player.+data TgtMode =+    TgtOff       -- ^ not in targeting mode+  | TgtExplicit  -- ^ the player requested targeting mode explicitly+  | TgtAuto      -- ^ the mode was entered (and will be exited) automatically+  deriving (Show, Eq)++-- | Current targeting cursor parameters.+data Cursor = Cursor+  { ctargeting :: TgtMode          -- ^ targeting mode+  , clocLn     :: Dungeon.LevelId  -- ^ cursor level+  , clocation  :: Point            -- ^ cursor coordinates+  , creturnLn  :: Dungeon.LevelId  -- ^ the level current player resides on+  }+  deriving Show++data DebugMode = DebugMode+  { smarkVision :: Maybe FovMode+  , somniscient :: Bool+  }+  deriving Show++-- | Get current level from the dungeon data.+slevel :: State -> Level+slevel State{slid, sdungeon} = sdungeon Dungeon.! slid++-- TODO: add date.+-- | Initial player diary.+defaultDiary :: IO Diary+defaultDiary = do+  curDate <- getClockTime+  let time = calendarTimeToString $ toUTCTime curDate+  return Diary+    { smsg = ""+    , shistory = ["Player diary started on " ++ time ++ "."]+    }++-- | Initial game state.+defaultState :: Config.CP -> FlavourMap -> Dungeon.Dungeon -> Dungeon.LevelId+             -> Point -> R.StdGen -> State+defaultState config flavour dng lid ploc g =+  State+    (AHero 0)  -- hack: the hero is not yet alive+    (Cursor TgtOff lid ploc lid)+    0+    flavour+    S.empty+    dng+    lid+    (0, 0)+    IS.empty+    g+    config+    defaultDebugMode++defaultDebugMode :: DebugMode+defaultDebugMode = DebugMode+  { smarkVision = Nothing+  , somniscient = False+  }++-- | Update cursor parameters within state.+updateCursor :: (Cursor -> Cursor) -> State -> State+updateCursor f s = s { scursor = f (scursor s) }++-- | Update time within state.+updateTime :: (Time -> Time) -> State -> State+updateTime f s = s { stime = f (stime s) }++-- | Update item discoveries within state.+updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State+updateDiscoveries f s = s { sdisco = f (sdisco s) }++-- | Update level data within state.+updateLevel :: (Level -> Level) -> State -> State+updateLevel f s = updateDungeon (Dungeon.adjust f (slid s)) s++-- | Update dungeon data within state.+updateDungeon :: (Dungeon.Dungeon -> Dungeon.Dungeon) -> State -> State+updateDungeon f s = s {sdungeon = f (sdungeon s)}++cycleMarkVision :: State -> State+cycleMarkVision s@State{sdebug = sdebug@DebugMode{smarkVision}} =+  s {sdebug = sdebug {smarkVision = case smarkVision of+                        Nothing          -> Just (Digital 100)+                        Just (Digital _) -> Just Permissive+                        Just Permissive  -> Just Shadow+                        Just Shadow      -> Just Blind+                        Just Blind       -> Nothing }}++toggleOmniscient :: State -> State+toggleOmniscient s@State{sdebug = sdebug@DebugMode{somniscient}} =+  s {sdebug = sdebug {somniscient = not somniscient}}++instance Binary Diary where+  put Diary{..} = do+    put smsg+    put shistory+  get = do+    smsg     <- get+    shistory <- get+    return Diary{..}++instance Binary State where+  put (State player cursor time flav disco dng lid ct+         party g config _) = do+    put player+    put cursor+    put time+    put flav+    put disco+    put dng+    put lid+    put ct+    put party+    put (show g)+    put config+  get = do+    player <- get+    cursor <- get+    time   <- get+    flav   <- get+    disco  <- get+    dng    <- get+    lid    <- get+    ct     <- get+    party  <- get+    g      <- get+    config <- get+    return+      (State player cursor time flav disco dng lid ct+         party (read g) config defaultDebugMode)++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)++instance Binary TgtMode where+  put TgtOff      = putWord8 0+  put TgtExplicit = putWord8 1+  put TgtAuto     = putWord8 2+  get = do+    tag <- getWord8+    case tag of+      0 -> return TgtOff+      1 -> return TgtExplicit+      2 -> return TgtAuto+      _ -> fail "no parse (TgtMode)"
+ Game/LambdaHack/Strategy.hs view
@@ -0,0 +1,61 @@+-- | AI strategies to direct actors not controlled by the player.+-- No operation in this module involves the 'State' or 'Action' type.+module Game.LambdaHack.Strategy+  ( Strategy(..), liftFrequency, (.|), reject, (.=>), only+  ) where++import Control.Monad++import Game.LambdaHack.Utils.Frequency++-- | A strategy is a choice of (non-empty) frequency tables+-- of possible actions.+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 $ uniformFreq [x]+  m >>= f  = Strategy $+               filter (not . nullFreq)+               [ toFreq [ (p * q, b)+                        | (p, a) <- runFrequency x+                        , y <- runStrategy (f a)+                        , (q, b) <- runFrequency y+                        ]+               | x <- runStrategy m ]++instance MonadPlus Strategy where+  mzero = Strategy []+  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)++-- | Strategy where only the actions from the given single frequency table+-- can be picked.+liftFrequency :: Frequency a -> Strategy a+liftFrequency f =+  Strategy $ filter (not . nullFreq) $ return f++infixr 2 .|++-- | Strategy with the actions from both argument strategies,+-- with original frequencies.+(.|) :: Strategy a -> Strategy a -> Strategy a+(.|) = mplus++-- | Strategy with no actions at all.+reject :: Strategy a+reject = mzero++infix 3 .=>++-- | Conditionally accepted strategy.+(.=>) :: Bool -> Strategy a -> Strategy a+p .=> m | p          =  m+        | otherwise  =  mzero++-- | Strategy with all actions not satisfying the predicate removed.+-- The remaining action keep their original relative frequency values.+only :: (a -> Bool) -> Strategy a -> Strategy a+only p s = do+  x <- s+  p x .=> return x
+ Game/LambdaHack/StrategyAction.hs view
@@ -0,0 +1,227 @@+-- | AI strategy operations implemented with the 'Action' monad.+module Game.LambdaHack.StrategyAction+  ( strategy, wait+  ) where++import qualified Data.List as L+import qualified Data.IntMap as IM+import Data.Maybe+import Control.Monad+import Control.Arrow++import Game.LambdaHack.Point+import Game.LambdaHack.Vector+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Utils.Frequency+import Game.LambdaHack.Perception+import Game.LambdaHack.Strategy+import Game.LambdaHack.State+import Game.LambdaHack.Action+import Game.LambdaHack.Actions+import Game.LambdaHack.ItemAction+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Item+import qualified Game.LambdaHack.Effect as Effect+import qualified Game.LambdaHack.Tile as Tile+import qualified Game.LambdaHack.Kind as Kind+import qualified Game.LambdaHack.Feature as F++{-+Monster movement+----------------++Not all monsters use the same algorithm to find the hero.+Some implemented and unimplemented methods are listed below:++* Random+The simplest way to have a monster move is at random.++* Sight+If a monster can see the hero (as an approximation,+we assume it is the case when the hero can see the monster,+unless either of the locations is dark),+the monster should move toward the hero.++* Smell+The hero leaves a trail when moving toward the dungeon.+For a certain timespan (100--200 moves), it is possible+for certain monsters to detect that a hero has been at a certain field.+Once a monster is following a trail, it should move to the+neighboring field where the hero has most recently visited.++* Noise+The hero makes noise. If the distance between the hero+and the monster is small enough, the monster can hear the hero+and moves into the approximate direction of the hero.+-}++-- TODO: improve, split up, etc.+-- | Monster AI strategy based on monster sight, smell, intelligence, etc.+strategy :: Kind.COps -> ActorId -> State -> Perception -> Strategy (Action ())+strategy cops actor oldState@State{splayer = pl, stime = time} per =+  strat+ where+  Kind.COps{ cotile+           , coactor=Kind.Ops{okind}+           , coitem=coitem@Kind.Ops{okind=iokind}+           } = cops+  lvl@Level{lsmell = nsmap, lxsize, lysize} = slevel oldState+  Actor { bkind = ak, bloc = me, bdir = ad, btarget = tgt } =+    getActor actor oldState+  items = getActorItem actor oldState+  mk = okind ak+  delState = deleteActor actor oldState+  enemyVisible a l =+    asight mk && monsterSeesHero cotile per lvl actor a me l ||+    -- Any enemy can be flet if adjacent (e. g., a monster player).+    -- TODO: can this be replaced by setting 'lights' to [me]?+    adjacent lxsize me l+  -- If no heroes on the level, monsters go at each other. TODO: let them+  -- earn XP by killing each other to make this dangerous to the player.+  -- TODO: with some commands blocked, this can't happen now. Find a way+  -- to test it, nevertheless. Have a scroll of monster fury?+  hs = L.map (AHero *** bloc) $+         IM.assocs $ lheroes $ slevel delState+  ms = L.map (AMonster *** bloc) $+         IM.assocs $ lmonsters $ slevel delState+  -- Below, "foe" is the hero (or a monster, or loc) chased by the actor.+  (newTgt, floc, foeVisible) =+    case tgt of+      TEnemy a ll | focusedMonster ->+        if memActor a delState+        then let l = bloc $ getActor a delState+             in if enemyVisible a l+                then (TEnemy a l, Just l, True)+                else if isJust (case closest of (_, m, _) -> m) || me == ll+                     then closest                -- prefer visible foes+                     else (tgt, Just ll, False)  -- last known loc of enemy+        else closest  -- enemy not on the level, temporarily chase others+      TLoc loc -> if me == loc+                  then closest+                  else (tgt, Just loc, False)  -- ignore all and go to loc+      _  -> closest+  closest =+    let hsAndTraitor = if isAMonster pl && memActor pl delState+                       then (pl, bloc $ getPlayerBody delState) : hs+                       else hs+        foes = if L.null hsAndTraitor then ms else hsAndTraitor+        visible = L.filter (uncurry enemyVisible) foes+        foeDist = L.map (\ (a, l) -> (chessDist lxsize me l, l, a)) visible+    in case foeDist of+         [] -> (TCursor, Nothing, False)+         _  -> let (_, l, a) = L.minimum foeDist+               in (TEnemy a l, Just l, True)+  onlyFoe        = onlyMoves (maybe (const False) (==) floc) me+  towardsFoe     = case floc of+                     Nothing -> const mzero+                     Just loc ->+                       let foeDir = towards lxsize me loc+                       in only (\ x -> euclidDistSq lxsize foeDir x <= 1)+  lootHere x     = not $ L.null $ lvl `atI` x+  onlyLoot       = onlyMoves lootHere me+  interestHere x = let t = lvl `at` x+                       ts = map (lvl `at`) $ vicinity lxsize lysize x+                   in Tile.hasFeature cotile F.Exit t ||+                      -- Lit indirectly. E.g., a room entrance.+                      (not (Tile.hasFeature cotile F.Lit t) &&+                       L.any (Tile.hasFeature cotile F.Lit) ts)+  onlyInterest   = onlyMoves interestHere me+  onlyKeepsDir k =+    only (\ x -> maybe True (\ (d, _) -> euclidDistSq lxsize d x <= k) ad)+  onlyKeepsDir_9 = only (\ x -> maybe True (\ (d, _) -> neg x /= d) ad)+  onlyNoMs       = onlyMoves (unoccupied (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      = Tile.SecretStrength $+                   case strongestSearch coitem items of+                     Just i  -> aiq mk + jpower i+                     Nothing -> aiq mk+  openableHere   = openable cotile lvl openPower+  onlyOpenable   = onlyMoves openableHere me+  accessibleHere = accessible cops lvl me+  onlySensible   = onlyMoves (\ l -> accessibleHere l || openableHere l) me+  focusedMonster = aspeed mk >= 10+  movesNotBack   = maybe id (\ (d, _) -> L.filter (/= neg d)) ad $ moves lxsize+  smells         =+    L.map fst $+    L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $+    L.filter (\ (_, s) -> s > 0) $+    L.map (\ x -> let sm = Tile.smelltime $ IM.findWithDefault+                             (Tile.SmellTime 0) (me `shift` x) nsmap+                  in (x, (sm - time) `max` 0)) movesNotBack+  attackDir d = dirToAction actor newTgt True  `liftM` d+  moveDir d   = dirToAction actor newTgt False `liftM` d++  strat =+    foeVisible .=> attackDir (onlyFoe moveFreely)+    .| foeVisible .=> liftFrequency (msum seenFreqs)+    .| lootHere me .=> actionPickup+    .| moveDir moveTowards  -- go to last known foe location+    .| attackDir moveAround+  actionPickup = return $ actorPickupItem actor+  tis = lvl `atI` me+  seenFreqs = [applyFreq items 1, applyFreq tis 2,+               throwFreq items 3, throwFreq tis 6] ++ towardsFreq+  applyFreq is multi = toFreq+    [ (benefit * multi,+       applyGroupItem actor (iverbApply ik) i)+    | i <- is,+      let ik = iokind (jkind i),+      let benefit = (1 + jpower i) * Effect.effectToBenefit (ieffect ik),+      benefit > 0,+      asight mk || isymbol ik == '!']+  throwFreq is multi = if adjacent lxsize me (fromJust floc) || not (asight mk)+                       then mzero+                       else toFreq+    [ (benefit * multi,+       projectGroupItem actor (fromJust floc) (iverbProject ik) i)+    | i <- is,+      let ik = iokind (jkind i),+      let benefit =+            - (1 + jpower i) * Effect.effectToBenefit (ieffect ik),+      benefit > 0,+      -- Wasting swords would be too cruel to the player.+      isymbol ik /= ')']+  towardsFreq = map (scaleFreq 30) $ runStrategy $ moveDir moveTowards+  moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely)+  moveAround =+    onlySensible $+      (if asight mk then onlyNoMs else id) $+        asmell mk .=> L.foldr ((.|) . return) reject smells+        .| onlyOpenable moveFreely+        .| moveFreely+  moveIQ = aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly+        .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly+        .| aiq mk > 5  .=> onlyKeepsDir 2 moveRandomly+        .| onlyKeepsDir_9 moveRandomly+  interestFreq =  -- don't detour towards an interest if already on one+    if interestHere me+    then []+    else map (scaleFreq 3)+           (runStrategy $ onlyInterest (onlyKeepsDir 2 moveRandomly))+  interestIQFreq = interestFreq ++ runStrategy moveIQ+  moveFreely = onlyLoot moveRandomly+               .| liftFrequency (msum interestIQFreq)+               .| moveRandomly+  onlyMoves :: (Point -> Bool) -> Point -> Strategy Vector -> Strategy Vector+  onlyMoves p l = only (\ x -> p (l `shift` x))+  moveRandomly :: Strategy Vector+  moveRandomly = liftFrequency $ uniformFreq (moves lxsize)++dirToAction :: ActorId -> Target -> Bool -> Vector -> Action ()+dirToAction actor tgt allowAttacks dir = do+  -- set new direction+  updateAnyActor actor $ \ m -> m { bdir = Just (dir, 0), btarget = tgt }+  -- perform action+  tryWith (advanceTime actor) $+    -- if the following action aborts, we just advance the time and continue+    -- TODO: ensure time is taken for other aborted actions in this file+    moveOrAttack allowAttacks actor dir++-- | A strategy to always just wait.+wait :: ActorId -> Strategy (Action ())+wait actor = return $ advanceTime actor
+ Game/LambdaHack/Tile.hs view
@@ -0,0 +1,78 @@+-- | Operations concerning dungeon level tiles.+--+-- Unlike for many other content types, there is no type @Tile@,+-- of particular concrete tiles in the dungeon,+-- corresponding to 'TileKind' (the type of kinds of terrain tiles).+-- This is because the tiles are too numerous and there's not enough+-- storage space for a well-rounded @Tile@ type, on one hand,+-- and on the other hand, tiles are accessed+-- too often in performance critical code+-- to try to compress their representation and/or recompute them.+-- Instead, of defining a @Tile@ type, we express various properties+-- of concrete tiles by arrays or sparse IntMaps, as appropriate.+module Game.LambdaHack.Tile+  ( SecretStrength(..), SmellTime(..)+  , kindHasFeature, kindHas, hasFeature+  , isClear, isLit, similar, canBeHidden+  ) where++import qualified Data.List as L+import Data.Binary++import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Feature as F+import qualified Game.LambdaHack.Kind as Kind+import Game.LambdaHack.Misc++-- | The type of secrecy strength of hidden terrain tiles (e.g., doors).+newtype SecretStrength = SecretStrength{secretStrength :: Time}+  deriving (Show, Eq, Ord)+instance Binary SecretStrength where+  put = put . secretStrength+  get = fmap SecretStrength get++-- | The last time a hero left a smell in a given tile. To be used+-- by monsters that hunt by smell.+newtype SmellTime = SmellTime{smelltime :: Time} deriving Show+instance Binary SmellTime where+  put = put . smelltime+  get = fmap SmellTime get++-- | Whether a tile kind has the given feature.+kindHasFeature :: F.Feature -> TileKind -> Bool+kindHasFeature f t = f `elem` tfeature t++-- | Whether a tile kind has all features of the first set+-- and no features of the second.+kindHas :: [F.Feature] -> [F.Feature] -> TileKind -> Bool+kindHas yes no t = L.all (`kindHasFeature` t) yes+                   && not (L.any (`kindHasFeature` t) no)++-- | Whether a tile kind (specified by its id) has the given feature.+hasFeature :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Bool+hasFeature Kind.Ops{okind} f t =+  kindHasFeature f (okind t)++-- | Whether a tile does not block vision.+-- Essential for efficiency of "FOV", hence tabulated.+isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isClear Kind.Ops{ospeedup = Kind.TileSpeedup{isClearTab}} = isClearTab++-- | Whether a tile is lit on its own.+-- Essential for efficiency of "Perception", hence tabulated.+isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isLit Kind.Ops{ospeedup = Kind.TileSpeedup{isLitTab}} = isLitTab++-- | The player can't tell one tile from the other.+similar :: TileKind -> TileKind -> Bool+similar t u =+  tsymbol t == tsymbol u &&+  tname   t == tname   u &&+  tcolor  t == tcolor  u &&+  tcolor2 t == tcolor2 u++-- | The player can't tell if the tile is hidden or not.+canBeHidden :: Kind.Ops TileKind -> TileKind -> Bool+canBeHidden Kind.Ops{ofoldrWithKey} t =+  let sim _ s acc = acc || kindHasFeature F.Hidden s && similar t s+  in ofoldrWithKey sim False
+ Game/LambdaHack/Turn.hs view
@@ -0,0 +1,198 @@+-- | The main loop of the game, processing player and AI moves turn by turn.+module Game.LambdaHack.Turn ( handle ) where++import Control.Monad+import Control.Monad.State hiding (State, state)+import qualified Data.List as L+import qualified Data.Ord as Ord+import qualified Data.IntMap as IM+import qualified Data.Map as M++import Game.LambdaHack.Action+import Game.LambdaHack.Actions+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.EffectAction+import qualified Game.LambdaHack.Binding as Binding+import Game.LambdaHack.Level+import Game.LambdaHack.Actor+import Game.LambdaHack.ActorState+import Game.LambdaHack.Random+import Game.LambdaHack.State+import Game.LambdaHack.Strategy+import Game.LambdaHack.StrategyAction+import Game.LambdaHack.Running+import qualified Game.LambdaHack.Tile as Tile++-- One turn proceeds through the following functions:+--+-- handle+-- handleAI, handleMonster+-- nextMove+-- handle (again)+--+-- OR:+--+-- handle+-- handlePlayer, playerCommand+-- handleAI, handleMonster+-- nextMove+-- handle (again)+--+-- What's happening where:+--+-- handle: determine who moves next,+--   dispatch to handleAI or handlePlayer+--+-- handlePlayer: remember, display, get and process commmand(s),+--   update smell map, update perception+--+-- handleAI: find monsters that can move+--+-- 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.+-- If yes, run a player move, if not, run an AI move.+-- In either case, eventually the next turn is started or the game ends.+handle :: Action ()+handle = do+  debug "handle"+  state <- get+  let ptime = btime (getPlayerBody state)  -- time of player's next move+  let time  = stime state                  -- current game time+  debug $ "handle: time check. ptime = "+          ++ show ptime ++ ", time = " ++ show time+  if ptime > time+    then handleAI  -- the hero can't make a move yet; monsters first+    else handlePlayer    -- it's the hero's turn!++    -- TODO: readd this, but only for the turns when anything moved+    -- and only after a rendering delay is added, so that the move is visible+    -- on modern computers. Use the same delay for running (not disabled now).+    -- We redraw the map even between player moves so that the movements of fast+    -- monsters can be traced on the map.+    -- displayGeneric ColorFull (const "")++-- TODO: We should replace this structure using a priority search queue/tree.+-- | Handle monster moves. Perform moves for individual monsters as long as+-- there are monsters that have a move time which is less than or equal to+-- the current time.+handleAI :: Action ()+handleAI = do+  debug "handleAI"+  time <- gets stime+  ms   <- gets (lmonsters . slevel)+  pl   <- gets splayer+  if IM.null ms+    then nextMove+    else let order  = Ord.comparing (btime . snd)+             (i, m) = L.minimumBy order (IM.assocs ms)+             actor = AMonster i+         in if btime m > time || actor == pl+            then nextMove  -- no monster is ready for another move+            else handleMonster actor++-- | Handle the move of a single monster.+handleMonster :: ActorId -> Action ()+handleMonster actor = do+  debug "handleMonster"+  cops  <- contentOps+  state <- get+  -- Simplification: this is the perception after the last player command+  -- and does not take into account, e.g., other monsters opening doors.+  per <- currentPerception+  -- Run the AI: choses an action from those given by the AI strategy.+  join $ rndToAction $+           frequency (head (runStrategy (strategy cops actor state per+                                         .| wait actor)))+  handleAI++-- TODO: nextMove may not be a good name. It's part of the problem of the+-- current design that all of the top-level functions directly call each+-- other, rather than being called by a driver function.+-- | After everything has been handled for the current game time, we can+-- advance the time. Here is the place to do whatever has to be done for+-- every time unit, e.g., monster generation.+nextMove :: Action ()+nextMove = do+  debug "nextMove"+  modify (updateTime (+1))+  regenerateLevelHP+  generateMonster+  handle++-- | Handle the move of the hero.+handlePlayer :: Action ()+handlePlayer = do+  debug "handlePlayer"+  -- Determine perception before running player command, in case monsters+  -- have opened doors, etc.+  withPerception $ do+    remember  -- The hero notices his surroundings, before they get displayed.+    oldPlayerTime <- gets (btime . getPlayerBody)+    playerCommand+    -- At this point, the command was successful and possibly took some time.+    newPlayerTime <- gets (btime . getPlayerBody)+    if newPlayerTime == oldPlayerTime+      then handlePlayer  -- no time taken, repeat+      else do+        state <- get+        pl    <- gets splayer+        let time = stime state+            ploc = bloc (getPlayerBody state)+            sTimeout = Config.get (sconfig state) "monsters" "smellTimeout"+        -- Update smell. Only humans leave a strong scent.+        when (isAHero pl) $+          modify (updateLevel (updateSmell (IM.insert ploc+                                             (Tile.SmellTime+                                                (time + sTimeout)))))+        -- Determine perception to let monsters target heroes.+        withPerception handleAI++-- | Determine and process the next player command.+playerCommand :: Action ()+playerCommand = do+  displayAll -- draw the current surroundings+  history    -- update the message history and reset current message+  tryRepeatedlyWith stopRunning $  -- on abort, just ask for a new command+    ifRunning continueRun $ do+      k <- session nextCommand+      session (\ Session{skeyb} ->+                case M.lookup k (Binding.kcmd skeyb) of+                  Just (_, c)  -> c+                  Nothing ->+                    abortWith $ "unknown command <" ++ show k ++ ">")++-- 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.
+ Game/LambdaHack/Utils/Assert.hs view
@@ -0,0 +1,66 @@+-- | Tools for specifying assertions. A step towards contracts.+-- Actually, a bunch of hacks wrapping the original @assert@ function,+-- which is the only easy way of obtaining source locations.+module Game.LambdaHack.Utils.Assert+  ( assert, blame, failure, allB, checkM, trueM, falseM+  ) where++import Control.Exception (assert)+import Debug.Trace (trace)++infix 1 `blame`+-- | If the condition fails, display the value blamed for the failure.+-- Used as in+--+-- > assert (c /= 0 `blame` c) $ 10 / c+blame :: Show a => Bool -> a -> Bool+{-# INLINE blame #-}+blame condition blamed+  | condition = True+  | otherwise =+    let s = "Contract failed and the following is to blame:\n" +++            "  " ++ show blamed+    in trace s False++-- | Like 'Prelude.undefined', but shows the source location+-- and also the value to blame for the failure. To be used as in:+--+-- > assert `failure` ((x1, y1), (x2, y2), "designate a vertical line")+failure :: Show a => (Bool -> b -> b) -> a -> b+{-# INLINE failure #-}+failure asrt blamed =+  let s = "Internal failure occured and the following is to blame:\n" +++          "  " ++ show blamed+  in trace s $+     asrt False (error "Assert.failure: no error location (upgrade to GHC 7.4)")++-- | Like 'List.all', but if the predicate fails, blame all the list elements+-- and especially those for which it fails. To be used as in:+--+-- > assert (allB (>= 0) [yf, xf, y1, x1, y2, x2])+allB :: Show a => (a -> Bool) -> [a] -> Bool+{-# INLINE allB #-}+allB predicate l =+  let s = show (filter (not . predicate) l) ++ " in the context of " ++ show l+  in blame (all predicate l) s++-- | Check that the value returned from a monad action satisfies a predicate.+-- Reports source location and the suspects. Drops the value.+checkM :: (Show a, Monad m) =>+          (Bool -> m () -> m ()) -> (c -> Bool) -> a -> c -> m ()+checkM asrt predicate blamed value+  | predicate value = return ()+  | otherwise =+    let s = "The returned value is wrong and the following is to blame:\n" +++            "  " ++ show blamed+    in trace s $+       asrt False+         (error "Assert.checkM: no error location (upgrade to GHC 7.4)")++-- | Verifies that the returned value is true (respectively, false). Used as in:+--+-- > open newValve >>= assert `trueM` (newValve, "is already opened, not new")+trueM, falseM :: (Show a, Monad m) => (Bool -> m () -> m ()) -> a -> Bool+              -> m ()+trueM  asrt = checkM asrt id+falseM asrt = checkM asrt not
+ Game/LambdaHack/Utils/File.hs view
@@ -0,0 +1,42 @@+-- | Saving/loading with serialization and compression.+module Game.LambdaHack.Utils.File+  ( encodeEOF, strictDecodeEOF+  ) where++import System.IO+import Data.Binary+import qualified Data.ByteString.Lazy as LBS+import qualified Codec.Compression.Zlib as Z++-- | Serialize, compress and save data.+-- Note that LBS.writeFile opens the file in binary mode.+encodeData :: Binary a => FilePath -> a -> IO ()+encodeData f = LBS.writeFile f . Z.compress . encode++-- | Serialize, compress and save data with an EOF marker.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary a => FilePath -> a -> IO ()+encodeEOF f a = encodeData f (a, "OK")++-- | Read and decompress the serialized data.+strictReadSerialized :: FilePath -> IO LBS.ByteString+strictReadSerialized f =+  withBinaryFile f ReadMode $ \ h -> do+    c <- LBS.hGetContents h+    let d = Z.decompress c+    LBS.length d `seq` return d++-- | Read, decompress and deserialize data.+strictDecodeData :: Binary a => FilePath -> IO a+strictDecodeData = fmap decode . strictReadSerialized++-- | Read, decompress and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before the function returns.+strictDecodeEOF :: Binary a => FilePath -> IO a+strictDecodeEOF f = do+  (a, n) <- strictDecodeData f+  if n == "OK"+    then return a+    else error $ "Fatal error: corrupted file " ++ f
+ Game/LambdaHack/Utils/Frequency.hs view
@@ -0,0 +1,74 @@+-- | A list of items with relative frequencies of appearance.+module Game.LambdaHack.Utils.Frequency+  ( -- * The @Frequency@ type+    Frequency+    -- * Construction+  , uniformFreq, toFreq+    -- * Transformation+  , scaleFreq, filterFreq+    -- * Consumption+  , rollFreq, nullFreq, runFrequency+  ) where++import Control.Monad+import qualified System.Random as R++import Game.LambdaHack.Utils.Assert++-- TODO: do not expose runFrequency+-- | The frequency distribution type.+newtype Frequency a = Frequency+  { runFrequency :: [(Int, a)]  -- ^ Give acces to raw frequency values.+  }+  deriving Show++instance Monad Frequency where+  return x = Frequency [(1, x)]+  m >>= f  = Frequency+               [(p * q, y) | (p, x) <- runFrequency m,+                             (q, y) <- runFrequency (f x) ]++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)++-- | Uniform discrete frequency distribution.+uniformFreq :: [a] -> Frequency a+uniformFreq = Frequency . map (\ x -> (1, x))++-- | Takes a list of frequencies and items into the frequency distribution.+toFreq :: [(Int, a)] -> Frequency a+toFreq = Frequency++-- | Scale frequecy distribution, multiplying it by an integer constant.+scaleFreq :: Int -> Frequency a -> Frequency a+scaleFreq n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs)++-- | Leave only items that satisfy a predicate.+filterFreq :: (a -> Bool) -> Frequency a -> Frequency a+filterFreq p (Frequency l) = Frequency $ filter (p . snd) l++-- | Randomly choose an item according to the distribution.+rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)+rollFreq (Frequency []) _ =+  assert `failure` "choice from an empty frequency"+rollFreq (Frequency [(n, x)]) _ | n <= 0 =+  assert `failure` ("singleton frequency with nothing to pick", n, x)+rollFreq (Frequency [(_, x)]) g = (x, g)  -- speedup+rollFreq (Frequency fs) g =+  assert (sumf > 0 `blame` ("frequency with nothing to pick", fs)) $+  (frec r fs, ng)+ where+  sumf = sum (map fst fs)+  (r, ng) = R.randomR (1, sumf) g+  frec :: Int -> [(Int, a)] -> a+  frec m []                     = assert `failure` ("impossible", fs, m)+  frec m ((n, x) : _)  | m <= n = x+  frec m ((n, _) : xs)          = frec (m - n) xs++-- | Test if the frequency distribution is empty.+nullFreq :: Frequency a -> Bool+nullFreq fr = null $ runFrequency fr
+ Game/LambdaHack/Vector.hs view
@@ -0,0 +1,128 @@+-- | Basic operations on 2D vectors represented in an efficient,+-- but not unique, way.+module Game.LambdaHack.Vector+  ( Vector, toVector, shift, shiftBounded, moves, movesWidth+  , euclidDistSq, diagonal, neg, towards+  ) where++import Data.Binary++import Game.LambdaHack.PointXY+import Game.LambdaHack.VectorXY+import Game.LambdaHack.Area+import Game.LambdaHack.Point+import Game.LambdaHack.Utils.Assert++-- | 2D vectors  represented as offsets in the linear framebuffer+-- indexed by 'Point'.+--+-- A newtype is used to prevent mixing up the type with @Point@ itself.+-- Note that the offset representations of a vector is usually not unique.+-- E.g., for vectors of lenth 1 in the chessboard metric, used to denote+-- geographical directions, the representations are pairwise distinct+-- if and only if the level width and height are at least 3.+newtype Vector = Vector Int+  deriving (Show, Eq)++instance Binary Vector where+  put (Vector dir) = put dir+  get = fmap Vector get++-- | Converts a vector in cartesian representation into @Vector@.+toVector :: X -> VectorXY -> Vector+toVector lxsize (VectorXY (x, y)) =+  Vector $ x + y * lxsize++-- | Converts a unit vector in cartesian representation into @Vector@.+toDir :: X -> VectorXY -> Vector+toDir lxsize v@(VectorXY (x, y)) =+  assert (lxsize >= 3 && chessDistXY v == 1 `blame` (lxsize, v)) $+  Vector $ x + y * lxsize++-- | Converts a unit vector in the offset representation+-- into the cartesian representation. Arbitrary vectors can't be+-- converted uniquely.+fromDir :: X -> Vector -> VectorXY+fromDir lxsize (Vector dir) =+  assert (lxsize >= 3 && chessDistXY res == 1 &&+          fst len1 + snd len1 * lxsize == dir+          `blame` (lxsize, dir, res)) $+  res+ where+  (x, y) = (dir `mod` lxsize, dir `div` lxsize)+  -- Pick the vector's canonical form of length 1:+  len1 = if x > 1+         then (x - lxsize, y + 1)+         else (x, y)+  res = VectorXY len1++-- | Translate a point by a vector.+--+-- Particularly simple and fast implementation in the linear representation.+shift :: Point -> Vector -> Point+shift loc (Vector dir) = loc + dir++-- | Translate a point by a vector, but only if the result fits in an area.+shiftBounded :: X -> Area -> Point -> Vector -> Point+shiftBounded lxsize area loc dir =+  let res = shift loc dir+  in if inside lxsize res area then res else loc++-- | Vectors of all unit moves, clockwise, starting north-west.+moves :: X -> [Vector]+moves lxsize = map (toDir lxsize) movesXY++-- | Vectors of all unit moves, clockwise, starting north-west,+-- parameterized by level width.+movesWidth :: [X -> Vector]+movesWidth = map (flip toDir) movesXY++-- | Squared euclidean distance between two unit vectors.+euclidDistSq :: X -> Vector -> Vector -> Int+euclidDistSq lxsize dir0 dir1+  | VectorXY (x0, y0) <- fromDir lxsize dir0+  , VectorXY (x1, y1) <- fromDir lxsize dir1 =+  euclidDistSqXY $ VectorXY (y1 - y0, x1 - x0)++-- | Checks whether a unit vector is a diagonal direction,+-- as opposed to cardinal.+diagonal :: X -> Vector -> Bool+diagonal lxsize dir | VectorXY (x, y) <- fromDir lxsize dir =+  x * y /= 0++-- | Reverse an arbirary vector.+neg :: Vector -> Vector+neg (Vector dir) = Vector (-dir)++-- | Given a vector of arbitrary non-zero length, produce a unit vector+-- that points in the same direction (in the chessboard metric).+-- Of several equally good directions it picks one of those that visually+-- (in the euclidean metric) maximally align with the original vector.+normalize :: X -> VectorXY -> Vector+normalize lxsize (VectorXY (dx, dy)) =+  assert (dx /= 0 || dy /= 0 `blame` (dx, dy)) $+  let angle :: Double+      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)+      dxy | angle <= -0.75 = (0, -1)+          | angle <= -0.25 = (1, -1)+          | angle <= 0.25  = (1, 0)+          | angle <= 0.75  = (1, 1)+          | angle <= 1.25  = (0, 1)+          | otherwise = assert `failure` (lxsize, dx, dy, angle)+  in if dx >= 0+     then toDir lxsize $ VectorXY dxy+     else neg (toDir lxsize $ VectorXY dxy)++-- TODO: Perhaps produce all acceptable directions and let AI choose.+-- That would also eliminate the Doubles.+-- | Given two distinct locations, determine the direction (a unit vector)+-- in which one should move from the first in order to get closer+-- to the second. Ignores obstacles. Of several equally good directions+-- (in the chessboard metric) it picks one of those that visually+-- (in the euclidean metric) maximally align with the vector between+-- the two points..+towards :: X -> Point -> Point -> Vector+towards lxsize loc0 loc1 =+  assert (loc0 /= loc1 `blame` (loc0, loc1)) $+  let v = displacement lxsize loc0 loc1+  in normalize lxsize v
+ Game/LambdaHack/VectorXY.hs view
@@ -0,0 +1,39 @@+-- | Basic cartesian geometry operations on 2D vectors.+module Game.LambdaHack.VectorXY+  ( VectorXY(..), shiftXY, movesXY, movesCardinalXY+  , chessDistXY, euclidDistSqXY, negXY+  ) where++import Game.LambdaHack.PointXY++-- | 2D vectors in cartesian representation.+newtype VectorXY = VectorXY (X, Y)+  deriving (Show, Eq)++-- | Shift a point by a vector.+shiftXY :: PointXY -> VectorXY -> PointXY+shiftXY (PointXY (x0, y0)) (VectorXY (x1, y1)) = PointXY (x0 + x1, y0 + y1)++-- | Vectors of all unit moves in the chessboard metric,+-- clockwise, starting north-west.+movesXY :: [VectorXY]+movesXY =+  map VectorXY+    [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]++-- | Vectors of all cardinal direction unit moves, clockwise, starting north.+movesCardinalXY :: [VectorXY]+movesCardinalXY = map VectorXY [(0, -1), (1, 0), (0, 1), (-1, 0)]++-- | The lenght of a vector in the chessboard metric,+-- where diagonal moves cost 1.+chessDistXY :: VectorXY -> Int+chessDistXY (VectorXY (x, y)) = max (abs x) (abs y)++-- | Squared euclidean length of a vector.+euclidDistSqXY :: VectorXY -> Int+euclidDistSqXY (VectorXY (x, y)) = x * x + y * y++-- | Reverse an arbirary vector.+negXY :: VectorXY -> VectorXY+negXY (VectorXY (x, y)) = VectorXY (-x, -y)
LICENSE view
@@ -1,5 +1,5 @@-Copyright (c) 2008--2011 Andres Loeh-Copyright (c) 2010--2011 Mikolaj Konarski+Copyright (c) 2008--2012 Andres Loeh+Copyright (c) 2010--2012 Mikolaj Konarski  All rights reserved.
LambdaHack.cabal view
@@ -1,80 +1,203 @@-cabal-version: >= 1.6+cabal-version: >= 1.10 name:          LambdaHack-version:       0.1.20110918+version:       0.2.0 license:       BSD3 license-file:  LICENSE-tested-with:   GHC == 6.12.3, GHC == 7.3.20110911-data-files:    LICENSE, CREDITS, DESIGN.markdown, PLAYING.markdown,-               README.markdown, src/config.default, scores+tested-with:   GHC == 7.2.2, GHC == 7.4+data-files:    LICENSE, CREDITS, PLAYING.md, README.md,+               config.default, config.bot, scores author:        Andres Loeh, Mikolaj Konarski-maintainer:    Andres Loeh <mail@andres-loeh.de>-description:   This is an alpha release of LambdaHack, a roguelike game engine-               packaged together with a small example roguelike game-               (not yet well separated; this is future work,-               together with improving the AI monad EDSL,-               so that the rules for synthesising monster behaviour-               from game content are more readable and easier to debug).+maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com>+description:   This is an alpha release of LambdaHack,+               a game engine library for roguelike games+               of arbitrary theme, size and complexity,+               packaged together with a small example dungeon crawler.+               When completed, it will let you specify content+               to be procedurally generated, define the AI behaviour+               on top of the generic content-independent rules+               and compile a ready-to-play game binary, using either+               the supplied or a custom-made main loop.+               Several frontends are available (GTK is the default)+               and many other generic engine components are easily overridden,+               but the fundamental source of flexibility lies+               in the strict and type-safe separation of code and content.                .-               Another game using this engine is Allure of the Stars-               at <http://hackage.haskell.org/package/Allure>.-synopsis:      A roguelike game engine in early development+               Upcoming new features: improved squad combat,+               player action undo/redo, ranged combat animations,+               completely redesigned UI. Long term goals are focused+               around procedural content generation and include+               the improvement of the AI monad EDSL, so that rules+               for synthesising monster behaviour from game content+               are extensible, readable and easy to debug,+               in-game content creation, auto-balancing and persistent+               content modification based on player behaviour.+               .+               A larger game that depends on the LambdaHack library+               is Allure of the Stars, available from+               <http://hackage.haskell.org/package/Allure>.+synopsis:      A roguelike game engine in early and very active development homepage:      http://github.com/kosmikus/LambdaHack bug-reports:   http://github.com/kosmikus/LambdaHack/issues-category:      Game+category:      Game Engine build-type:    Simple +source-repository head+  type:            git+  location:        git://github.com/kosmikus/LambdaHack.git+ flag curses-  description:   enable curses support-  default:       False+  description:     pick the curses frontend+  default:         False  flag vty-  description:   enable vty support-  default:       False+  description:     pick the vty frontend+  default:         False -executable LambdaHack-  main-is:       Main.hs-  hs-source-dirs:src-  other-modules: Action, Actions, ActorAdd, ActorKind, Actor, ActorState,-                 Color, Command, Config, ConfigDefault,-                 Display, Dungeon, DungeonState,-                 Effect, EffectAction, File, Flavour,-                 FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,-                 Frequency, Geometry, GeometryRnd, Grammar,-                 HighScores, Item, ItemKind, ItemAction,-                 Keys, Keybindings, Level, LevelState,-                 Main, Message, Multiline, Perception, Random,-                 Save, State, Strategy, StrategyState,-                 Turn, Terrain, Version-  build-depends: base >= 4 && < 5, containers >= 0.1 && < 1,-                 binary >= 0.4 && < 1,-                 random >= 1 && < 2, zlib >= 0.4 && < 1,-                 bytestring >= 0.9 && < 1, directory >= 1 && < 2,-                 mtl >= 1.1 && < 3, old-time, ConfigFile >= 1.0.6 && < 2,-                 MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 2-  extensions:    CPP, FlexibleContexts, QuasiQuotes, MultiParamTypeClasses,-                 RankNTypes, BangPatterns+flag std+  description:     pick the stdin/stdout frontend+  default:         False -  if impl(ghc < 7.0)-     -- GHC 6.12.3 does not like template-haskell 2.6 and 7.3 does not like 2.5-      build-depends: template-haskell >= 2.5 && < 2.6-  else-      build-depends: template-haskell >= 2.5+library+  exposed-modules: Game.LambdaHack.Action,+                   Game.LambdaHack.Actions,+                   Game.LambdaHack.Actor,+                   Game.LambdaHack.ActorState,+                   Game.LambdaHack.Area,+                   Game.LambdaHack.AreaRnd,+                   Game.LambdaHack.Binding,+                   Game.LambdaHack.BindingAction,+                   Game.LambdaHack.Cave,+                   Game.LambdaHack.Color,+                   Game.LambdaHack.Command,+                   Game.LambdaHack.Config,+                   Game.LambdaHack.Content,+                   Game.LambdaHack.Content.ActorKind,+                   Game.LambdaHack.Content.CaveKind,+                   Game.LambdaHack.Content.ItemKind,+                   Game.LambdaHack.Content.PlaceKind,+                   Game.LambdaHack.Content.RuleKind,+                   Game.LambdaHack.Content.TileKind,+                   Game.LambdaHack.Display,+                   Game.LambdaHack.Dungeon,+                   Game.LambdaHack.DungeonState,+                   Game.LambdaHack.Effect,+                   Game.LambdaHack.EffectAction,+                   Game.LambdaHack.Feature,+                   Game.LambdaHack.Flavour,+                   Game.LambdaHack.FOV,+                   Game.LambdaHack.FOV.Common,+                   Game.LambdaHack.FOV.Digital,+                   Game.LambdaHack.FOV.Permissive,+                   Game.LambdaHack.FOV.Shadow,+                   Game.LambdaHack.Grammar,+                   Game.LambdaHack.HighScore,+                   Game.LambdaHack.Item,+                   Game.LambdaHack.ItemAction,+                   Game.LambdaHack.Key,+                   Game.LambdaHack.Kind,+                   Game.LambdaHack.Level,+                   Game.LambdaHack.Misc,+                   Game.LambdaHack.Msg,+                   Game.LambdaHack.Perception,+                   Game.LambdaHack.Place,+                   Game.LambdaHack.Point,+                   Game.LambdaHack.PointXY,+                   Game.LambdaHack.Random,+                   Game.LambdaHack.Running,+                   Game.LambdaHack.Save,+                   Game.LambdaHack.Start,+                   Game.LambdaHack.State,+                   Game.LambdaHack.Strategy,+                   Game.LambdaHack.StrategyAction,+                   Game.LambdaHack.Tile,+                   Game.LambdaHack.Turn,+                   Game.LambdaHack.Utils.Assert,+                   Game.LambdaHack.Utils.File,+                   Game.LambdaHack.Utils.Frequency,+                   Game.LambdaHack.Vector+                   Game.LambdaHack.VectorXY+  other-modules:   Paths_LambdaHack+  build-depends:   ConfigFile >= 1.1.1   && < 2,+                   array      >= 0.3.0.3 && < 1,+                   base       >= 4       && < 5,+                   binary     >= 0.5.0.2 && < 1,+                   bytestring >= 0.9.2   && < 1,+                   containers >= 0.4.1   && < 1,+                   directory  >= 1.1.0.1 && < 2,+                   filepath   >= 1.2.0.1 && < 2,+                   mtl        >= 2.0.1   && < 3,+                   old-time   >= 1.0.0.7 && < 2,+                   random     >= 1.0.1   && < 2,+                   zlib       >= 0.5.3.1 && < 1+  default-language: Haskell2010+  default-extensions: MonoLocalBinds,+                      BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions: MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,+                    TypeFamilies, CPP+  ghc-options:     -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:     -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind+  ghc-options:     -fno-ignore-asserts -funbox-strict-fields    if flag(curses) {-    other-modules: Display.Curses-    build-depends: hscurses >= 1.3 && < 2+    exposed-modules: Game.LambdaHack.Display.Curses+    build-depends: hscurses >= 1.4.1 && < 2     cpp-options:   -DCURSES-    extra-libraries: curses   } else { if flag(vty) {-    other-modules: Display.Vty-    build-depends: vty >= 4.4+    exposed-modules: Game.LambdaHack.Display.Vty+    build-depends: vty >= 4.7.0.6+    cpp-options:   -DVTY+  } else { if flag(std) {+    exposed-modules: Game.LambdaHack.Display.Std+    cpp-options:   -DSTD   } else {-    other-modules: Display.Gtk-    build-depends: gtk >= 0.11 && < 0.13-    cpp-options:   -DGTK-    ghc-options:   -threaded-  } }+    exposed-modules: Game.LambdaHack.Display.Gtk+    build-depends: gtk >= 0.12.1 && < 0.13+  } } } -source-repository head-  type:              git-  location:          git://github.com/kosmikus/LambdaHack.git+executable LambdaHack+  main-is:         Main.hs+  other-modules:   Content.ActorKind,+                   Content.CaveKind,+                   Content.ItemKind,+                   Content.PlaceKind,+                   Content.RuleKind,+                   Content.TileKind,+                   Multiline,+                   ConfigDefault+  hs-source-dirs:  LambdaHack+  other-modules:   Paths_LambdaHack+  build-depends:   LambdaHack >= 0.2.0   && < 0.2.1,+                   template-haskell >= 2.6 && < 3,++                   ConfigFile >= 1.1.1   && < 2,+                   array      >= 0.3.0.3 && < 1,+                   base       >= 4       && < 5,+                   binary     >= 0.5.0.2 && < 1,+                   bytestring >= 0.9.2   && < 1,+                   containers >= 0.4.1   && < 1,+                   directory  >= 1.1.0.1 && < 2,+                   filepath   >= 1.2.0.1 && < 2,+                   mtl        >= 2.0.1   && < 3,+                   old-time   >= 1.0.0.7 && < 2,+                   random     >= 1.0.1   && < 2,+                   zlib       >= 0.5.3.1 && < 1+  default-language: Haskell2010+  default-extensions: MonoLocalBinds,+                      BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions: CPP, QuasiQuotes+  ghc-options:     -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:     -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind+  ghc-options:     -fno-ignore-asserts -funbox-strict-fields+  ghc-options:     -threaded++executable DumbBot+  main-is:         Main.hs+  hs-source-dirs:  DumbBot+  build-depends:   base       >= 4       && < 5,+                   random     >= 1.0.1   && < 2+  default-language: Haskell2010+  default-extensions: MonoLocalBinds,+                      BangPatterns, RecordWildCards, NamedFieldPuns+  ghc-options:     -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:     -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind+  ghc-options:     -fno-ignore-asserts -funbox-strict-fields
+ LambdaHack/ConfigDefault.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP, QuasiQuotes #-}+-- | The default configurations file included via CPP as a Haskell string.+module ConfigDefault ( configDefault ) where++import Multiline++-- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?)+-- as soon as the config file grows very big.++-- | The string containing the default configuration+-- included from file config.default.+-- Warning: cabal does not detect that the default config is changed,+-- so touching this file is needed to reinclude config and recompile.+configDefault :: String+configDefault = [multiline|+#include "../config.default"+|]
+ LambdaHack/Content/ActorKind.hs view
@@ -0,0 +1,68 @@+-- | Monsters and heroes for LambdaHack.+module Content.ActorKind ( cdefs ) where++import Game.LambdaHack.Color+import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Random++cdefs :: Content.CDefs ActorKind+cdefs = Content.CDefs+  { getSymbol = asymbol+  , getName = aname+  , getFreq = afreq+  , validate = avalidate+  , content =+      [hero, eye, fastEye, nose]+  }+hero,        eye, fastEye, nose :: ActorKind++hero = ActorKind+  { asymbol = '@'+  , aname   = "hero"+  , afreq   = [("hero", 1)]  -- Does not appear randomly in the dungeon.+  , acolor  = BrWhite  -- Heroes white, monsters colorful.+  , ahp     = RollDice 60 1+  , aspeed  = 10+  , asight  = True+  , asmell  = False+  , aiq     = 13  -- Can see hidden doors, when he is under alien control.+  , aregen  = 5000+  }++eye = ActorKind+  { asymbol = 'e'+  , aname   = "reducible eye"+  , afreq   = [("monster", 60), ("summon", 50)]+  , acolor  = BrRed+  , ahp     = RollDice 3 4+  , aspeed  = 10+  , asight  = True+  , asmell  = False+  , aiq     = 8+  , aregen  = 1000+  }+fastEye = ActorKind+  { asymbol = 'e'+  , aname   = "super-fast eye"+  , afreq   = [("monster", 15)]+  , acolor  = BrBlue+  , ahp     = RollDice 1 4+  , aspeed  = 5+  , asight  = True+  , asmell  = False+  , aiq     = 12+  , aregen  = 50  -- Regenerates fast (at max HP most of the time!).+  }+nose = ActorKind+  { asymbol = 'n'+  , aname   = "point-free nose"+  , afreq   = [("monster", 20), ("summon", 100)]+  , acolor  = Green+  , ahp     = RollDice 7 2+  , aspeed  = 11+  , asight  = False+  , asmell  = True+  , aiq     = 0+  , aregen  = 1000+  }
+ LambdaHack/Content/CaveKind.hs view
@@ -0,0 +1,82 @@+-- | Cave layouts for LambdaHack.+module Content.CaveKind ( cdefs ) where++import Data.Ratio++import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.Random as Random+import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Misc++cdefs :: Content.CDefs CaveKind+cdefs = Content.CDefs+  { getSymbol = csymbol+  , getName = cname+  , getFreq = cfreq+  , validate = cvalidate+  , content =+      [rogue, arena, empty, noise]+  }+rogue,        arena, empty, noise :: CaveKind++rogue = CaveKind+  { csymbol       = '$'+  , cname         = "A maze of twisty passages"+  , cfreq         = [("dng", 100), ("caveRogue", 1)]+  , cxsize        = fst normalLevelBound + 1+  , cysize        = snd normalLevelBound + 1+  , cgrid         = RollDiceXY (RollDice 2 3, RollDice 2 2)+  , cminPlaceSize = RollDiceXY (RollDice 2 2, RollDice 2 1)+  , cdarkChance   = (RollDice 1 54, RollDice 0 0)+  , cauxConnects  = 1%3+  , cvoidChance   = 1%4+  , cnonVoidMin   = 4+  , cminStairDist = 30+  , cdoorChance   = 1%2+  , copenChance   = 1%10+  , chiddenChance = 1%5+  , citemNum      = RollDice 5 2+  , cdefTile      = "fillerWall"+  , ccorTile      = "darkCorridor"+  }+arena = rogue+  { csymbol       = 'A'+  , cname         = "Underground city"+  , cfreq         = [("dng", 30), ("caveArena", 1)]+  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 2 2)+  , cminPlaceSize = RollDiceXY (RollDice 3 2, RollDice 2 1)+  , cdarkChance   = (RollDice 1 80, RollDice 1 60)+  , cvoidChance   = 1%3+  , cnonVoidMin   = 2+  , citemNum      = RollDice 3 2  -- few rooms+  , cdefTile      = "floorArenaLit"+  , ccorTile      = "path"+  }+empty = rogue+  { csymbol       = '.'+  , cname         = "Tall cavern"+  , cfreq         = [("dng", 20), ("caveEmpty", 1)]+  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 1 2)+  , cminPlaceSize = RollDiceXY (RollDice 4 3, RollDice 4 1)+  , cdarkChance   = (RollDice 1 80, RollDice 1 80)+  , cauxConnects  = 1+  , cvoidChance   = 3%4+  , cnonVoidMin   = 1+  , cminStairDist = 50+  , citemNum      = RollDice 6 2  -- whole floor strewn with treasure+  , cdefTile      = "floorRoomLit"+  , ccorTile      = "floorRoomLit"+  }+noise = rogue+  { csymbol       = '!'+  , cname         = "Glittering cave"+  , cfreq         = [("dng", 20), ("caveNoise", 1)]+  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 1 2)+  , cminPlaceSize = RollDiceXY (RollDice 4 2, RollDice 4 1)+  , cdarkChance   = (RollDice 1 80, RollDice 1 40)+  , cvoidChance   = 0+  , cnonVoidMin   = 0+  , citemNum      = RollDice 3 2  -- few rooms+  , cdefTile      = "noiseSet"+  , ccorTile      = "path"+  }
+ LambdaHack/Content/ItemKind.hs view
@@ -0,0 +1,197 @@+-- | Weapons and treasure for LambdaHack.+module Content.ItemKind ( cdefs ) where++import Game.LambdaHack.Color+import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.Effect+import Game.LambdaHack.Flavour+import Game.LambdaHack.Random+import Game.LambdaHack.Content.ItemKind++cdefs :: Content.CDefs ItemKind+cdefs = Content.CDefs+  { getSymbol = isymbol+  , getName = iname+  , getFreq = ifreq+  , validate = ivalidate+  , content =+      [amulet, dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight]+  }+amulet,        dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight :: ItemKind++gem, potion, scroll :: ItemKind  -- generic templates++-- rollDeep (aDb, xDy) = rollDice aDb + lvl * rollDice xDy / depth++amulet = ItemKind+  { isymbol  = '"'+  , iname    = "amulet"+  , ifreq    = [("dng", 6)]+  , iflavour = zipFancy [BrGreen]+  , ieffect  = Regeneration+  , icount   = intToDeep 1+  , ipower   = (RollDice 2 3, RollDice 1 10)+  , iverbApply   = "tear down"+  , iverbProject = "throw"+  }+dart = ItemKind+  { isymbol  = '|'+  , iname    = "dart"+  , ifreq    = [("dng", 30)]+  , iflavour = zipPlain [Cyan]+  , ieffect  = Wound (RollDice 1 1)+  , icount   = (RollDice 3 3, RollDice 0 0)+  , ipower   = intToDeep 0+  , iverbApply   = "snap"+  , iverbProject = "throw"+  }+gem = ItemKind+  { isymbol  = '*'+  , iname    = "gem"+  , ifreq    = [("dng", 20)]       -- x3, but rare on shallow levels+  , iflavour = zipPlain brightCol  -- natural, so not fancy+  , ieffect  = NoEffect+  , icount   = intToDeep 0+  , ipower   = intToDeep 0+  , iverbApply   = "crush"+  , iverbProject = "throw"+  }+gem1 = gem+  { icount   = (RollDice 1 1, RollDice 1 1)  -- appears on lvl 1+  }+gem2 = gem+  { icount   = (RollDice 0 0, RollDice 1 2)  -- appears halfway+  }+gem3 = gem+  { icount   = (RollDice 0 0, RollDice 1 1)  -- appears on max depth+  }+gold = ItemKind+  { isymbol  = '$'+  , iname    = "gold piece"+  , ifreq    = [("dng", 80)]+  , iflavour = zipPlain [BrYellow]+  , ieffect  = NoEffect+  , icount   = (RollDice 0 0, RollDice 10 10)+  , ipower   = intToDeep 0+  , iverbApply   = "grind"+  , iverbProject = "throw"+  }+javelin = ItemKind+  { isymbol  = '|'+  , iname    = "javelin"+  , ifreq    = [("dng", 30)]+  , iflavour = zipPlain [Brown]+  , ieffect  = Wound (RollDice 1 2)+  , icount   = (RollDice 0 0, RollDice 2 2)+  , ipower   = (RollDice 1 1, RollDice 2 2)+  , iverbApply   = "break up"+  , iverbProject = "throw"+  }+potion = ItemKind+  { isymbol  = '!'+  , iname    = "potion"+  , ifreq    = [("dng", 15)]+  , iflavour = zipFancy stdCol+  , ieffect  = NoEffect+  , icount   = intToDeep 1+  , ipower   = intToDeep 0+  , iverbApply   = "gulp down"+  , iverbProject = "lob"+  }+potion1 = potion+  { ifreq    = [("dng", 5)]+  , ieffect  = ApplyPerfume+  }+potion2 = potion+  { ieffect  = Heal+  , ipower   = (RollDice 5 1, RollDice 0 0)+  }+potion3 = potion+  { ifreq    = [("dng", 5)]+  , ieffect  = Wound (RollDice 0 0)+  , ipower   = (RollDice 5 1, RollDice 0 0)+  }+ring = ItemKind+  { isymbol  = '='+  , iname    = "ring"+  , ifreq    = [("dng", 10)]+  , iflavour = zipPlain [White]+  , ieffect  = Searching+  , icount   = intToDeep 1+  , ipower   = (RollDice 1 6, RollDice 3 2)+  , iverbApply   = "squeeze down"+  , iverbProject = "throw"+  }+scroll = ItemKind+  { isymbol  = '?'+  , iname    = "scroll"+  , ifreq    = [("dng", 6)]+  , iflavour = zipFancy darkCol  -- arcane and old+  , ieffect  = NoEffect+  , icount   = intToDeep 1+  , ipower   = intToDeep 0+  , iverbApply   = "decipher"+  , iverbProject = "throw"+  }+scroll1 = scroll+  { ieffect  = SummonFriend+  }+scroll2 = scroll+  { ifreq    = [("dng", 3)]+  , ieffect  = SummonEnemy+  }+scroll3 = scroll+  { ieffect  = Descend+  }+sword = ItemKind+  { isymbol  = ')'+  , iname    = "sword"+  , ifreq    = [("dng", 60)]+  , iflavour = zipPlain [BrCyan]+  , ieffect  = Wound (RollDice 3 1)+  , icount   = intToDeep 1+  , ipower   = (RollDice 1 2, RollDice 4 2)+  , iverbApply   = "hit"+  , iverbProject = "heave"+  }+wand = ItemKind+  { isymbol  = '/'+  , iname    = "wand"+  , ifreq    = [("dng", 15)]+  , iflavour = zipFancy [BrRed]+  , ieffect  = Dominate+  , icount   = intToDeep 1+  , ipower   = intToDeep 0+  , iverbApply   = "snap"+  , iverbProject = "zap"+  }+fist = sword+  { isymbol  = '@'+  , iname    = "fist"+  , ifreq    = [("unarmed", 100)]+  , iverbApply   = "punch"+  , iverbProject = "ERROR, please report: iverbProject fist"+  }+foot = sword+  { isymbol  = '@'+  , iname    = "foot"+  , ifreq    = [("unarmed", 50)]+  , iverbApply   = "kick"+  , iverbProject = "ERROR, please report: iverbProject foot"+  }+tentacle = sword+  { isymbol  = 'S'+  , iname    = "tentacle"+  , ifreq    = [("monstrous", 100)]+  , iverbApply   = "hit"+  , iverbProject = "ERROR, please report: iverbProject tentacle"+  }+weight = sword+  { isymbol  = '@'+  , iname    = "power jump"+  , ifreq    = [("weight", 100)]+  , ieffect  = Wound (RollDice 99 99)+  , ipower   = (RollDice 1 99, RollDice 0 0)+  , iverbApply   = "squash"+  , iverbProject = "ERROR, please report: iverbProject weight"+  }
+ LambdaHack/Content/PlaceKind.hs view
@@ -0,0 +1,72 @@+-- | Rooms, halls and passages for LambdaHack.+module Content.PlaceKind ( cdefs ) where++import qualified Game.LambdaHack.Content as Content+import Game.LambdaHack.Content.PlaceKind++cdefs :: Content.CDefs PlaceKind+cdefs = Content.CDefs+  { getSymbol = psymbol+  , getName = pname+  , getFreq = pfreq+  , validate = pvalidate+  , content =+      [rect, pillar, pillarC, pillar3, colonnade, colonnadeW]+  }+rect,        pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind++rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.+  { psymbol  = 'r'+  , pname    = "room"+  , pfreq    = [("rogue", 100)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "--"+               , "|."+               ]+  }+pillar = PlaceKind+  { psymbol  = 'p'+  , pname    = "pillar room"+  , pfreq    = [("rogue", 1000)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|...."+               , "|.O.."+               , "|...."+               , "|...."+              ]+  }+pillarC = pillar+  { ptopLeft = [ "-----"+               , "|O..."+               , "|...."+               , "|...."+               , "|...."+              ]+  }+pillar3 = pillar+  { pfreq    = [("rogue", 100)]  -- Feels a bit intrusive with so many pillars.+  , ptopLeft = [ "-----"+               , "|O.O."+               , "|...."+               , "|O..."+               , "|...."+              ]+  }+colonnade = PlaceKind+  { psymbol  = 'c'+  , pname    = "colonnade"+  , pfreq    = [("rogue", 500)]+  , pcover   = CAlternate+  , pfence   = FFloor+  , ptopLeft = [ "O."+               , ".O"+               ]+  }+colonnadeW = colonnade+  { ptopLeft = [ "O."+               , ".."+               ]+  }
+ LambdaHack/Content/RuleKind.hs view
@@ -0,0 +1,40 @@+-- | Game rules and assorted data for LambdaHack.+module Content.RuleKind ( cdefs ) where++-- Cabal+import qualified Paths_LambdaHack as Self (getDataFileName, version)++import Game.LambdaHack.Vector+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Feature as F+import qualified Game.LambdaHack.Content as Content++cdefs :: Content.CDefs RuleKind+cdefs = Content.CDefs+  { getSymbol = rsymbol+  , getName = rname+  , getFreq = rfreq+  , validate = ruvalidate+  , content =+      [standard]+  }+standard :: RuleKind++standard = RuleKind+  { rsymbol        = 's'+  , rname          = "standard LambdaHack ruleset"+  , rfreq          = [("standard", 100)]+    -- Check whether one location is accessible from another.+    -- Precondition: the two locations are next to each other.+    -- Apart of checking the target tile, we forbid diagonal movement+    -- to and from doors.+  , raccessible    = \ lxsize sloc src tloc tgt ->+      F.Walkable `elem` tfeature tgt+      && not ((F.Closable `elem` tfeature src ||+               F.Closable `elem` tfeature tgt)+              && diagonal lxsize (towards lxsize sloc tloc))+  , rtitle         = "LambdaHack"+  , rpathsDataFile = Self.getDataFileName+  , rpathsVersion  = Self.version+  }
+ LambdaHack/Content/TileKind.hs view
@@ -0,0 +1,209 @@+-- | Terrain tiles for LambdaHack.+module Content.TileKind ( cdefs ) where++import Game.LambdaHack.Color+import qualified Game.LambdaHack.Content as Content+import qualified Game.LambdaHack.Effect as Effect+import Game.LambdaHack.Feature+import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Random as Random++cdefs :: Content.CDefs TileKind+cdefs = Content.CDefs+  { getSymbol = tsymbol+  , getName = tname+  , getFreq = tfreq+  , validate = tvalidate+  , content =+      [wall, pillar, wallV, doorHiddenV, doorClosedV, doorOpenV, wallH, doorHiddenH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDownDark, stairsDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorRoomLit, floorRoomDark, floorRed, floorBlue, floorGreen, floorBrown]+  }+wall,        pillar, wallV, doorHiddenV, doorClosedV, doorOpenV, wallH, doorHiddenH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDownDark, stairsDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorRoomLit, floorRoomDark, floorRed, floorBlue, floorGreen, floorBrown :: TileKind++wall = TileKind+  { tsymbol  = ' '+  , tname    = "rock"+  , tfreq    = [("litLegend", 100), ("darkLegend", 100), ("fillerWall", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = []+  }+pillar = TileKind+  { tsymbol  = 'O'+  , tname    = "pillar"+  , tfreq    = [("litLegend", 100), ("darkLegend", 100), ("noiseSet", 55)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = []+  }+wallV = TileKind+  { tsymbol  = '|'+  , tname    = "wall"+  , tfreq    = [("litLegend", 100), ("darkLegend", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = []+  }+doorHiddenV = wallV+  { tfreq    = [("hidden", 100)]+  , tfeature = [ Hidden, Secret (Random.RollDice 7 2)+               , ChangeTo "vertical closed door"+               ]+  }+doorClosedV = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [("vertical closed door", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Exit, Openable+               , ChangeTo "vertical open door"+               ]+  }+doorOpenV = TileKind+  { tsymbol  = '-'+  , tname    = "open door"+  , tfreq    = [("vertical open door", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Walkable, Clear, Exit, Closable+               , ChangeTo "vertical closed door"+               ]+  }+wallH = TileKind+  { tsymbol  = '-'+  , tname    = "wall"+  , tfreq    = [("litLegend", 100), ("darkLegend", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = []+  }+doorHiddenH = wallH+  { tfreq    = [("hidden", 100)]+  , tfeature = [ Hidden, Secret (Random.RollDice 7 2)+               , ChangeTo "horizontal closed door"+               ]+  }+doorClosedH = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [("horizontal closed door", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Exit, Openable+               , ChangeTo "horizontal open door"+               ]+  }+doorOpenH = TileKind+  { tsymbol  = '|'+  , tname    = "open door"+  , tfreq    = [("horizontal open door", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Walkable, Clear, Exit, Closable+               , ChangeTo "horizontal closed door"+               ]+  }+stairsUpDark = TileKind+  { tsymbol  = '<'+  , tname    = "staircase up"+  , tfreq    = [("darkLegend", 100)]+-- Disabled, because the yellow artificial light does not fit LambdaHack.+--  , tcolor   = BrYellow+-- Dark room interior, OTOH, is fine:+  , tcolor   = BrWhite+  , tcolor2  = BrBlack+  , tfeature = [Walkable, Clear, Exit, Ascendable, Cause Effect.Ascend]+  }+stairsUpLit = stairsUpDark+  { tfreq    = [("litLegend", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = Lit : tfeature stairsUpDark+  }+stairsDownDark = TileKind+  { tsymbol  = '>'+  , tname    = "staircase down"+  , tfreq    = [("darkLegend", 100)]+-- Disabled, because the yellow artificial light does not fit LambdaHack.+--  , tcolor   = BrYellow+-- Dark room interior, OTOH, is fine:+  , tcolor   = BrWhite+  , tcolor2  = BrBlack+  , tfeature = [Walkable, Clear, Exit, Descendable, Cause Effect.Descend]+  }+stairsDownLit = stairsDownDark+  { tfreq    = [("litLegend", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = Lit : tfeature stairsDownDark+  }+unknown = TileKind+  { tsymbol  = ' '+  , tname    = "unknown space"+  , tfreq    = [("unknown space", 1)]+  , tcolor   = defFG+  , tcolor2  = BrWhite+  , tfeature = []+  }+floorCorridorLit = TileKind+  { tsymbol  = '#'+  , tname    = "corridor"+  , tfreq    = []+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Walkable, Clear, Lit]+  }+floorCorridorDark = floorCorridorLit+  { tfreq    = [("darkCorridor", 1)]+-- Disabled, because dark corridors and yellow light does not fit LambdaHack.+--  , tcolor   = BrYellow+--  , tcolor2  = BrBlack+  , tfeature = [Walkable, Clear]+  }+floorArenaLit = floorCorridorLit+  { tsymbol  = '.'+  , tname    = "stone floor"+  , tfreq    = [("noiseSet", 100), ("floorArenaLit", 1)]+  }+floorArenaDark = floorCorridorDark+  { tsymbol  = '.'+  , tname    = "stone floor"+  , tfreq    = []+-- Disabled, because the yellow artificial light does not fit LambdaHack.+--  , tcolor   = BrYellow+-- Dark room interior, OTOH, is fine:+  , tcolor2  = BrBlack+  }+floorRoomLit = floorArenaLit+  { tfreq    = [("litLegend", 100), ("floorRoomLit", 1)]+  , tfeature = Boring : tfeature floorArenaLit+  }+floorRoomDark = floorArenaDark+  { tfreq    = [("darkLegend", 100)]+  , tfeature = Boring : tfeature floorArenaDark+  }+floorRed = floorArenaLit+  { tname    = "brick pavement"+  , tfreq    = [("path", 30)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , tfeature = Path : tfeature floorArenaLit+  }+floorBlue = floorRed+  { tname    = "granite cobblestones"+  , tfreq    = [("path", 100)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  }+floorGreen = floorRed+  { tname    = "mossy stone path"+  , tfreq    = [("path", 100)]+  , tcolor   = BrGreen+  , tcolor2  = Green+  }+floorBrown = floorRed+  { tname    = "rotting mahogany deck"+  , tfreq    = [("path", 10)]+  , tcolor   = BrMagenta+  , tcolor2  = Magenta+  }
+ LambdaHack/Main.hs view
@@ -0,0 +1,59 @@+-- | The main code file of LambdaHack. Here the knot of engine+-- code pieces and the LambdaHack-specific content defintions is tied,+-- resulting in an executable game.+module Main ( main ) where++import Data.Maybe++import qualified Game.LambdaHack.Display as Display+import qualified Game.LambdaHack.Kind as Kind+import qualified Content.ActorKind+import qualified Content.CaveKind+import qualified Content.ItemKind+import qualified Content.PlaceKind+import qualified Content.RuleKind+import qualified Content.TileKind+import qualified Game.LambdaHack.Start as Start+import Game.LambdaHack.Command+import Game.LambdaHack.Display+import qualified Game.LambdaHack.Config as Config+import Game.LambdaHack.Action+import qualified Game.LambdaHack.BindingAction as BindingAction++import qualified ConfigDefault++-- | Gather together the content and verify its consistency.+cops :: Kind.COps+cops = Kind.COps+  { coactor = Kind.createOps Content.ActorKind.cdefs+  , cocave  = Kind.createOps Content.CaveKind.cdefs+  , coitem  = Kind.createOps Content.ItemKind.cdefs+  , coplace = Kind.createOps Content.PlaceKind.cdefs+  , corule  = Kind.createOps Content.RuleKind.cdefs+  , cotile  = Kind.createOps Content.TileKind.cdefs+  }++-- | Wire together config, content and the definitions of game commands+-- to form the starting game session. Evaluate to check for errors.+sess :: Config.CP -> FrontendSession -> Session+sess config sfs =+  let !skeyb = BindingAction.stdBinding config cmdSemantics cmdDescription+      !scops = cops+  in Session{..}++-- | Create the starting game config from the default config file+-- and initialize the engine with the starting session.+start :: IO (String, FrontendSession -> IO ())+start = do+  config <- Config.mkConfig ConfigDefault.configDefault+  -- The only option taken not from conif in savegame, but from fresh config.+  let configFont = fromMaybe "" $ Config.getOption config "ui" "font"+  return (configFont, Start.start config . sess config)++-- | Fire up the frontend with the engine fueled by config and content.+-- Which of the frontends is run depends on the flags supplied+-- when compiling the engine library.+main :: IO ()+main = do+  (configFont, loop) <- start+  Display.startup configFont loop
+ LambdaHack/Multiline.hs view
@@ -0,0 +1,10 @@+-- | Template Haskell machinery for quoting multiline strings.+module Multiline (multiline) where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TQ++-- | Handle multiline verbatim string expressions.+multiline :: TQ.QuasiQuoter+multiline  = TQ.QuasiQuoter (\x -> (TH.litE . TH.stringL) x)+               undefined undefined undefined
− PLAYING.markdown 
@@ -1,154 +0,0 @@-Playing LambdaHack-==================--Playing LambdaHack involves walking around the dungeon,-alone or in a party of fearless adventurers, jumping between levels,-bumping into monsters, doors and walls, gathering magical treasure-and making creative use of it. The bloodthirsty monsters do the same,-intelligence allowing, while tirelessly chasing the noble heroes-by smell and night-sight.--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 (horizontal and vertical)     - and |-               pillar wall                        O-               corridor                           #-               stairs (up and down)               < and >-               closed door                        +-               open door                          | and --               rock                               blank--The game world is persistent, i. e., every time 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,-though only under older versions of hscurses.)--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-               T      cycle among level terrain generation stages---Monsters-----------The hero is not alone in the dungeon. Monsters roam the dark caves-and crawl from damp holes day and night. While heroes pay attention-to all other party members and take moves sequentially, one after another,-monsters don't care about each other and all move at once,-sometimes brutally colliding by mistake.--When the hero bumps into a monster or a monster attacks the hero,-melee combat occurs. The best weapon carried by each opponent-is taken into account for calculating bonus damage. The total damage-the current hero can potentially inflict is displayed at the bottom-of the screen. The total damage potential of a monster may change-as it finds and picks up new weapons. Heroes and monsters running-into another (with the Shift key) do not inflict damage, but change places.-This gives the opponent a free blow, but can improve the tactical situation-or aid escape.--Throwing weapons at targets wounds them, consuming the weapon in the process.-You can target a monster with the '*' key from the top row or numpad.-You may throw any object in your possession-(press '*' for a non-standard choice) or on the floor (press '-'),-though only objects of a few kinds inflict any damage.-Whenever a monster or a hero hit points reach zero, the combatant dies.-When the last hero dies, the game ends.---On Winning and Dying-----------------------You win the game if you escape the dungeon alive. Your score is-the sum of all gold you've plundered plus 100gp for each gem.-Only the loot in possession of the party members on level 1 counts-(the rest is considered MIA).--If all heroes die, your score is halved and only the treasure carried-by the last standing hero counts. You are free to start again-from the first level of the dungeon, but all your wealth and items-are gone and the dungeon and it's treasure look differently.
+ PLAYING.md view
@@ -0,0 +1,161 @@+Playing LambdaHack+==================++LambdaHack is a small dungeon crawler illustrating the roguelike game engine+library also called LambdaHack. Playing the game involves walking around+the dungeon, alone or in a party of fearless adventurers, setting up ambushes,+hiding in shadow, covering tracks, breaking through to deeper caves,+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 elusive heroes+by smell and sight.++Once the few basic command keys and on-screen symbols are learned,+mastery and enjoyment of the game is the matter of tactical skill+and literary imagination. To be honest, a lot of imagination is required+for this simple game, but it's playable and winnable.+++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                              .+               corridor                           #+               wall (horizontal and vertical)     - and |+               pillar                             O+               stairs up                          <+               stairs down                        >+               open door                          | and -+               closed door                        ++               rock                               blank++The game world is persistent, i.e., every time the player visits a level+during a single game, the level layout is the same. Some items+aid in dungeon exploration, e.g., a ring of searching improves the speed+of finding hidden doors by heroes and monsters. The higher the ability+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 your party.+++Keys+----++You move throughout the level using the numerical keypad or+the vi text editor keys (also known as "Rogue-like keys").++               7 8 9     y k u+                \|/       \|/+               4-5-6     h-.-l+                /|\       /|\+               1 2 3     b j n++Shift and a movement key make the hero run in the indicated direction,+until anything of interest is spotted. '5' and '.' skip a turn.+(Note that If you are using the curses or vty frontends,+numerical keypad may not work correctly depending on the versions+of curses, terminfo and terminal emulators. Vi keys should work regardless.)+Melee, searching for secret doors and opening closed doors can be done+by bumping into a monster, a wall and a door, respectively.++Below are the default keys for major commands. Those of them that take+hero time are marked with a *.++               key    command+               <      ascend a level*+               >      descend a level*+               ?      display help+               Q      quit without saving+               X      save and exit the game+               c      close a door*+               d      drop an object*+               g      get an object*+               i      display inventory+               o      open a door*+               q      quaff a potion*+               r      read a scroll*+               t      throw a dart*+               z      zap a wand*++To make a ranged attack, you need to set your target first, using+targeting mode. Note that the target, for the few commands that require any,+is indicated by the targeting cursor. The origin of a command+--- the  hero that performs it --- is unaffected by targeting. For example,+not the targeted door, but one adjacent to the selected hero is closed by him.++To avoid confusion, commands that take time are blocked when targeting+at a remote level (when the cursor is on a different level+than the selected hero). The targeting commands and all the less used+commands are listed below. None of them takes hero time.++               key    command+               ESC    cancel action+               RET    accept choice+               SPACE  clear messages+               TAB    cycle among heroes on level+               *      target monster+               /      target location+               D      dump current configuration+               P      display previous messages+               V      display game version+               [      target next shallower level+               ]      target next deeper level+               {      target 10 levels shallower+               }      target 10 levels deeper+               0--9   select a hero anywhere in the dungeon (gtk only)++There are also some debug and cheat keys. Use at your own 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 accident.++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.+Target a monster with the '*' key from the top keyboard row or from keypad.+You may throw any object in your possession (press '?' to choose+an object and press it again for a non-standard choice) or on the floor+(press '-'). Only objects of a few kinds inflict any damage.+Whenever the monster's or hero's 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 the current level+counts (the rest of the party 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 a different entrance to the dungeon, but all your previous wealth+is gone and fresh, fearless enemies bar your way.
− README.markdown 
@@ -1,52 +0,0 @@-LambdaHack-==========--LambdaHack is a small [roguelike] [1] game written in [Haskell] [2].-It is getting more and more configurable and aims to become a flexible-rouguelike engine, suitable for large and small dungeon crawling games-of arbitrary themes. In particular, we try to keep the AI code independent-of particular monster, item and terrain definitions.---Compilation and installation-------------------------------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] [3] as follows--    cabal install LambdaHack--For a more current snapshot, download the source from [github] [4]-and run Cabal from the main directory--    cabal install--or you may try one of the terminal frontends with--    cabal install -fvty---Savegame directory---------------------If you don't want LambdaHack to write to the current directory,-create a personal savegame directory (on Linux it's ~/.LambdaHack/).-and copy the scores file there. You may also want to-copy the configuration file src/config.default to-~/.LambdaHack/config and modify it, but be careful changing-gameplay options --- they can easily unbalance or break the game.---Further information----------------------See files PLAYING.markdown, DESIGN.markdown, CREDITS and LICENSE-for more information.----[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation-[2]: http://www.haskell.org/-[3]: http://hackage.haskell.org/package/LambdaHack-[4]: http://github.com/kosmikus/LambdaHack
+ README.md view
@@ -0,0 +1,87 @@+LambdaHack+==========++This is an alpha release of LambdaHack, a [Haskell] [1] game engine+library for [roguelike] [2] games of arbitrary theme, size and complexity,+packaged together with a small example dungeon crawler. When completed,+it will let you specify content to be procedurally generated,+define the AI behaviour on top of the generic content-independent rules+and compile a ready-to-play game binary, using either the supplied+or a custom-made main loop. Several frontends are available+(GTK is the default) and many other generic engine components+are easily overridden, but the fundamental source of flexibility lies+in the strict and type-safe separation of code and content.+Long-term goals for LambdaHack include support for tactical squad combat,+in-game content creation, auto-balancing and persistent content+modification based on player behaviour.++The engine comes with a sample code for a little dungeon crawler,+called LambdaHack and described in PLAYING.md. The engine and the example+game are bundled together in a single [Hackage] [3] package.+You are welcome to create your own game by modifying the sample game+and the engine code, but please consider eventually splitting your changes+into a separate Hackage package that depends on the upstream library,+to help us exchange ideas and share improvements to the common code.++Games known to use the LambdaHack library:++* Allure of the Stars, a near-future Sci-Fi game in early development,+see http://hackage.haskell.org/package/Allure+++Compilation and installation+----------------------------++The library is best compiled and installed via Cabal, which also takes care+of all dependencies. The latest official version of the library+can be downloaded automatically by Cabal from [Hackage] [3] as follows++    cabal install LambdaHack++For a newer snapshot, download source from a development branch+at [github] [5] and run Cabal from the main directory++    cabal install++For the example game, the best frontend (keyboard support and colours) is gtk.+To compile with one of the terminal frontends, use Cabal flags, e.g,++    cabal install -fvty++To use a crude bot for testing the game, you have to compile with+the standard input/output frontend, as follows++    cabal install -fstd++and run the bot, for instance storing the output in a log++    DumbBot 42 20000000 | LambdaHack > /tmp/log++You may wish to tweak the game configuration file for the bot,+e.g., by helping it play longer, as in the supplied config.bot.+++Compatibility note+------------------++The current code was tested with GHC 7.2.2 and several pre-release versions+of GHC 7.4. A [few tweaks] [6] are needed to compile with 7.0+and some more are needed for 6.12.+++Further information+-------------------++For more information, visit the [wiki] [4]+and see the files PLAYING.md, CREDITS and LICENSE.++Have fun!++++[1]: http://www.haskell.org/+[2]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation+[3]: http://hackage.haskell.org/package/LambdaHack+[4]: https://github.com/kosmikus/LambdaHack/wiki+[5]: http://github.com/kosmikus/LambdaHack+[6]: https://github.com/Mikolaj/Allure/commit/3d0aa5bef7a0ef39e7611d4e12229224f4cead75
+ config.bot view
@@ -0,0 +1,9 @@+; Overriding config file options to help the bot.+; DumbBot 42 20000000 | LambdaHack > /tmp/log++[dungeon]+depth: 100++[heroes]+baseHP: 999999+extraHeroes: 1
+ config.default view
@@ -0,0 +1,91 @@+; ; This is a commented out copy of the default config file+; ; that is embedded in the binary.+; ; The game looks for the user config file that overrides some options+; ; in the ~/.LambdaHack/config file (or similar, depending on the OS).+; ; Warning: options are case-sensitive and only ';' comments are permitted.++; [commands]+; ; All commands are defined here, except movement, hero selection and debug.+; ;+; ; Interaction with the dungeon.+; c: TriggerDir { verb = "close", object = "door", feature = Closable }+; o: TriggerDir { verb = "open", object = "door", feature = Openable }+; less:    TriggerTile { verb = "ascend", object = "level", feature = Cause Ascend }+; greater: TriggerTile { verb = "descend", object = "level", feature = Cause Descend }+; bracketleft:  TgtAscend 1+; bracketright: TgtAscend (-1)+; braceleft:    TgtAscend 10+; braceright:   TgtAscend (-10)+; slash: TgtFloor+; asterisk: TgtEnemy+; Tab: HeroCycle+; ;+; ; Items.+; g: Pickup+; d: Drop+; i: Inventory+; q: Apply { verb = "quaff", object = "potion", syms = "!" }+; r: Apply { verb = "read", object = "scroll", syms = "?" }+; z: Project { verb = "zap", object = "wand", syms = "/" }+; t: Project { verb = "throw", object = "dart", syms = "|" }+; ;+; ; Saving or ending the game.+; X: GameSave+; Q: GameQuit+; ;+; ; Information for the player.+; P: History+; V: Version+; question: Help+; D: CfgDump+; ;+; ; General.+; KP_Begin: Wait+; Escape: Cancel+; Return: Accept+; space: Redraw++; [dungeon]+; ; Fixed caves for the first levels, then randomly picked caves.+; LambdaCave_1: caveRogue+; LambdaCave_2: caveRogue+; LambdaCave_3: caveEmpty+; LambdaCave_10: caveNoise+; depth: 10++; [engine]+; fovMode: digital+; ;fovMode: permissive+; ;fovMode: shadow+; fovRadius: 12+; ;startingRandomGenerator: 42+; ;dungeonRandomGenerator: 42++; [files]+; ; Paths to various game files; relative to the save file directory.+; scoresFile: scores+; saveFile: save+; diaryFile : diary++; [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]+; ; Handy with Vi keys:+; comma: g+; period: KP_Begin++; [monsters]+; smellTimeout: 1000++; [ui]+; font: Terminus,Monospace normal normal normal normal 12+; historyMax: 5000
scores view

binary file changed (144 → 226 bytes)

− src/Action.hs 
@@ -1,255 +0,0 @@-{-# 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 Actor-import ActorState-import ActorKind-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 with modified current message.-displayGeneric :: ColorMode -> (String -> String) -> Action Bool-displayGeneric dm f = Action (\ s e p k a st ms -> displayLevel dm s p st (f ms) Nothing >>= k st ms)---- | Display the current level, with the current message and color. Most common.-display :: Action Bool-display = displayGeneric ColorFull id---- | Display an overlay on top of the current screen.-overlay :: String -> Action Bool-overlay txt = Action (\ s e p k a st ms -> displayLevel ColorFull s p st ms (Just txt) >>= k st ms)---- | Wipe out and set a new value for the current message.-messageReset :: Message -> Action ()-messageReset nm = Action (\ s e p k a st ms -> k st nm ())---- | Add to the current message.-messageAdd :: Message -> Action ()-messageAdd nm = Action (\ s e p k a st ms -> k st (addMsg ms nm) ())---- | Clear the current message.-messageClear :: Action ()-messageClear = Action (\ s e p k a st ms -> k st "" ())---- | Get the current message.-currentMessage :: Action Message-currentMessage = Action (\ s e p k a st ms -> k st ms ms)---- | 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-  messageReset msg-  display-  abort--neverMind :: Bool -> Action a-neverMind b = abortIfWith b "never mind"---- | Abort, and print the given message if the condition is true.-abortIfWith :: Bool -> Message -> Action a-abortIfWith True msg = abortWith msg-abortIfWith False _  = abortWith ""---- | Print message, await confirmation. Return value indicates--- if the player tried to abort/escape.-messageMoreConfirm :: ColorMode -> Message -> Action Bool-messageMoreConfirm dm msg = do-  messageAdd (msg ++ more)-  displayGeneric dm id-  session getConfirm---- | Print message, await confirmation, ignore confirmation.-messageMore :: Message -> Action ()-messageMore msg = messageClear >> messageMoreConfirm ColorFull msg >> return ()---- | Print a yes/no question and return the player's answer.-messageYesNo :: Message -> Action Bool-messageYesNo msg = do-  messageReset (msg ++ yesno)-  displayGeneric ColorBW id  -- turn player's attention to the choice-  session getYesNo---- | Print a message and an overlay, await confirmation. Return value--- indicates if the player tried to abort/escape.-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-    messageClear-    display-    return True-messageOverlaysConfirm msg (x:xs) =-  do-    messageReset 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-      messageClear-      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 :: ActorId -> (Actor -> Actor) -> Action ()-updateAnyActor actor f = modify (updateAnyActorBody actor f)--updatePlayerBody :: (Actor -> Actor) -> Action ()-updatePlayerBody f = do-  pl <- gets splayer-  updateAnyActor pl f---- | Advance the move time for the given actor.-advanceTime :: ActorId -> Action ()-advanceTime actor = do-  time <- gets stime-  let upd m = m { atime = time + (bspeed (akind m)) }-  -- A hack to synchronize the whole party:-  pl <- gets splayer-  if (actor == pl || isAHero actor)-    then do-           modify (updateLevel (updateHeroes (IM.map upd)))-           when (not $ isAHero pl) $ updatePlayerBody upd-    else updateAnyActor actor upd--playerAdvanceTime :: Action ()-playerAdvanceTime = do-  pl <- gets splayer-  advanceTime pl
− src/Actions.hs 
@@ -1,640 +0,0 @@-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 Actor-import ActorState-import ActorKind-import ActorAdd-import Perception-import Random-import State-import qualified Config-import qualified Save-import Terrain-import qualified Effect-import EffectAction---- 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 -- TODO: why no highscore? no display, because the user may be in a hurry, since he quits the game instead of getting himself killed properly? no score recording, not to polute the scores list with games that the player didn't even want to end honourably?-      else abortWith "Game resumed."---- | End targeting mode, accepting the current location or not.-endTargeting :: Bool -> Action ()-endTargeting accept = do-  returnLn <- gets (creturnLn . scursor)-  target   <- gets (atarget . getPlayerBody)-  cloc     <- gets (clocation . scursor)-  lvlSwitch returnLn  -- return to the original level of the player-  modify (updateCursor (\ c -> c { ctargeting = False }))-  let isEnemy = case target of TEnemy _ _ -> True ; _ -> False-  when (not isEnemy) $-    if accept-       then updatePlayerBody (\ p -> p { atarget = TLoc cloc })-       else updatePlayerBody (\ p -> p { atarget = TCursor })-  endTargetingMsg--endTargetingMsg :: Action ()-endTargetingMsg = do-  pkind  <- gets (akind . getPlayerBody)-  target <- gets (atarget . getPlayerBody)-  state  <- get-  let verb = "target"-      targetMsg = case target of-                    TEnemy a _ll ->-                      case findActorAnyLevel a state of-                        Just (_, m) -> objectActor (akind m)-                        Nothing     -> "a long gone adversary"-                    TLoc loc -> "location " ++ show loc-                    TCursor  -> "current cursor position continuously"-  messageAdd $ subjectActorVerb pkind verb ++ " " ++ targetMsg ++ "."---- | Cancel something, e.g., targeting mode, resetting the cursor--- to the position of the player. Chosen target is not invalidated.-cancelCurrent :: Action ()-cancelCurrent = do-  targeting <- gets (ctargeting . scursor)-  if targeting-    then endTargeting False-    else abortWith "Press Q to quit."---- | Accept something, e.g., targeting mode, keeping cursor where it was.--- Or perform the default action, if nothing needs accepting.-acceptCurrent :: Action () -> Action ()-acceptCurrent h = do-  targeting <- gets (ctargeting . scursor)-  if targeting-    then endTargeting True-    else h  -- nothing to accept right now--moveCursor :: Dir -> Int -> Action ()-moveCursor dir n = do-  (sy, sx) <- gets (lsize . slevel)-  let upd cursor =-        let (ny, nx) = iterate (`shift` dir) (clocation cursor) !! n-            cloc = (max 1 $ min ny (sy-1), max 1 $ min nx (sx-1))-        in  cursor { clocation = cloc }-  modify (updateCursor upd)-  doLook---- TODO: Think about doing the mode dispatch elsewhere, especially if over--- time more and more commands need to do the dispatch inside their code--- (currently only a couple do).-move :: Dir -> Action ()-move 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 { adir = Just dir })-      -- attacks and opening doors disallowed while running-      moveOrAttack False False pl dir---- | This function implements the actual "logic" of running. It checks if we--- have to stop running because something interested happened, and it checks--- 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 (aloc . getPlayerBody)-    per   <- currentPerception-    msg   <- currentMessage-    ms    <- gets (lmonsters . slevel)-    hs    <- gets (lheroes . slevel)-    lmap  <- gets (lmap . slevel)-    pl    <- gets splayer-    let dms = case pl of-                AMonster n -> IM.delete n ms  -- don't be afraid of yourself-                AHero _ -> ms-        mslocs = S.fromList (L.map aloc (IM.elems dms))-        monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per))-        newsReported    = not (L.null msg)-        t         = lmap `at` loc  -- tile at current location-        itemsHere = not (L.null (titems t))-        heroThere = L.elem (loc `shift` dir) (L.map aloc (IM.elems hs))-        dirOK     = accessible lmap loc (loc `shift` dir)-    -- What happens next is mostly depending on the terrain we're currently on.-    let exit (Stairs  {}) = True-        exit (Opening {}) = True-        exit (Door    {}) = True-        exit _            = False-    let hop t-          | monstersVisible || heroThere-            || newsReported || itemsHere || exit t = abort-        hop Corridor =-          -- in corridors, explore all corners and stop at all crossings-          -- TODO: even in corridors, stop if you run past an exit (rare)-          let ns = L.filter (\ x -> distance (neg dir, x) > 1-                                    && (accessible lmap loc (loc `shift` x))-                                        || openable 1 lmap (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 exit ts then abort else run dir-    hop (tterrain t)--ifRunning :: (Dir -> Action a) -> Action a -> Action a-ifRunning t e =-  do-    adir <- gets (adir . getPlayerBody)-    maybe e t adir---- | 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-    messageReset "direction?"-    display-    e  <- session nextCommand-    pl <- gets splayer-    K.handleDirection e (actorOpenClose pl True o) (neverMind True)--actorOpenClose :: ActorId ->-                  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 = aloc body-    let isPlayer  = actor == pl-    let isVerbose = v && isPlayer-    let dloc = shift loc dir  -- location we act upon-    let openPower = case strongestItem (aitems body) "ring" of-                      Just i  -> biq (akind body) + ipower i-                      Nothing -> biq (akind body)-      in case lmap `at` dloc of-           Tile d@(Door hv o') []-             | secret o' && isPlayer -> -- door is secret, cannot be opened or closed by 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 an actor-                                       abortIfWith isVerbose "blocked"-             | otherwise            -> -- door can be opened / closed-                                       -- TODO: print message if action performed by monster and perceived-                                       let nt  = Tile (Door hv (toOpen o)) []-                                           adj = M.adjust (\ (_, mt) -> (nt, mt)) dloc-                                       in  modify (updateLevel (updateLMap adj))-           Tile d@(Door hv o') _    -> -- door is jammed by items-                                       abortIfWith isVerbose "jammed"-           _                        -> -- there is no door here-                                       neverMind isVerbose-    advanceTime actor-- -- | 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 aloc pbody-    case map `at` loc of-      Tile (Stairs _ vdir' next) is-        | vdir == vdir' -> -- stairs are in the right direction-          case next of-            Nothing ->-              -- we are at the "end" of the dungeon-              if targeting-              then abortWith "cannot escape dungeon in targeting mode"-              else do-                b <- messageYesNo "Really escape the dungeon?"-                if b-                  then fleeDungeon-                  else abortWith "Game resumed."-            Just (nln, nloc) -> do-              if targeting-                then do-                  -- this assertion says no stairs go back to the same level-                  assertTrue $ lvlSwitch nln-                  -- do not freely reveal the other end of the stairs-                  map <- gets (lmap . slevel)  -- lvlSwitch modifies map-                  let upd cursor =-                        let cloc = if Level.isUnknown (rememberAt map nloc)-                                   then loc-                                   else nloc-                        in  cursor { clocation = cloc, clocLn = nln }-                  modify (updateCursor upd)-                  doLook-                else tryWith (abortWith "somebody blocks the staircase") $ do-                  -- Remove the player from the old level.-                  modify (deleteActor pl)-                  -- At this place the invariant that the player exists fails.-                  -- Change to the new level (invariant not needed).-                  assertTrue $ lvlSwitch nln-                  -- Add the player to the new level.-                  modify (insertActor pl pbody)-                  -- At this place the invariant is restored again.-                  -- Land the player at the other end of the stairs.-                  updatePlayerBody (\ p -> p { aloc = nloc })-                  -- Change the level of the player recorded in cursor.-                  modify (updateCursor (\ c -> c { creturnLn = nln }))-                  -- Bail out if anybody blocks the staircase.-                  inhabitants <- gets (locToActors nloc)-                  when (length inhabitants > 1) abort-                  -- The invariant "at most one actor on a tile" restored.-                  -- Create a backup of the savegame.-                  state <- get-                  liftIO $ Save.saveGame state >> Save.mvBkp (sconfig state)-                  playerAdvanceTime-      _ -> -- no stairs-        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 aitems (levelHeroList state)-    if total == 0-      then do-             go <- messageClear >> messageMoreConfirm ColorFull "Coward!"-             when go $-               messageMore "Next time try to grab some loot before escape!"-             end-      else do-             let winMsg = "Congratulations, you won! Your loot, worth " ++-                          show total ++ " gold, is:"-             displayItems winMsg True items-             go <- session getConfirm-             when go $ 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 (aloc . getPlayerBody)-    pitems <- gets (aitems . getPlayerBody)-    let delta = case strongestItem pitems "ring" of-                  Just i  -> 1 + ipower i-                  Nothing -> 1-        searchTile (Tile (Door hv (Just n)) x, t') =-          (Tile (Door hv (Just (max (n - delta) 0))) x, t')-        searchTile t = t-        f l m = M.adjust searchTile (shift ploc m) l-        slmap = L.foldl' f lmap moves-    modify (updateLevel (updateLMap (const slmap)))-    playerAdvanceTime---- | Start the floor targeting mode or reset the cursor location to the player.-targetFloor :: Action ()-targetFloor = do-  ploc      <- gets (aloc . getPlayerBody)-  target    <- gets (atarget . getPlayerBody)-  targeting <- gets (ctargeting . scursor)-  let tgt = case target of-              _ | targeting -> TLoc ploc  -- double key press: reset cursor-              TEnemy _ _ -> TCursor  -- forget enemy target, keep the cursor-              t -> t  -- keep the target from previous targeting session-  updatePlayerBody (\ p -> p { atarget = tgt })-  setCursor tgt---- | Start the monster targeting mode. Cycle between monster targets.--- TODO: also target a monster by moving the cursor, if in target monster mode.--- TODO: sort monsters by distance to the player.-targetMonster :: Action ()-targetMonster = do-  pl        <- gets splayer-  ms        <- gets (lmonsters . slevel)-  per       <- currentPerception-  target    <- gets (atarget . getPlayerBody)-  targeting <- gets (ctargeting . scursor)-  let i = case target of-            TEnemy (AMonster n) _ | targeting -> n  -- try next monster-            TEnemy (AMonster n) _ -> n - 1  -- try to retarget old monster-            _ -> -1  -- try to target first monster (e.g., number 0)-      dms = case pl of-              AMonster n -> IM.delete n ms  -- don't target yourself-              AHero _ -> ms-      (lt, gt) = IM.split i dms-      gtlt     = IM.assocs gt ++ IM.assocs lt-      lf = L.filter (\ (_, m) -> actorSeesLoc pl (aloc m) per (Just pl)) gtlt-      tgt = case lf of-              [] -> target  -- no monsters in sight, stick to last target-              (na, nm) : _ -> TEnemy (AMonster na) (aloc nm)  -- pick the next-  updatePlayerBody (\ p -> p { atarget = tgt })-  setCursor tgt---- | Set, activate and display cursor information.-setCursor :: Target -> Action ()-setCursor tgt = do-  state <- get-  per   <- currentPerception-  ploc  <- gets (aloc . getPlayerBody)-  ln    <- gets (lname . slevel)-  let upd cursor =-        let cloc = case targetToLoc (ptvisible per) state of-                     Nothing -> ploc-                     Just l  -> l-        in  cursor { ctargeting = True, clocation = cloc, clocLn = ln }-  modify (updateCursor upd)-  doLook---- | Perform look around in the current location of the cursor.--- TODO: depending on tgt, show extra info about tile or monster or both-doLook :: Action ()-doLook =-  do-    loc    <- gets (clocation . scursor)-    state  <- get-    lmap   <- gets (lmap . slevel)-    per    <- currentPerception-    target <- gets (atarget . getPlayerBody)-    let canSee = S.member loc (ptvisible per)-        monsterMsg =-          if canSee-          then case L.find (\ m -> aloc m == loc) (levelMonsterList state) of-                 Just m  -> subjectActor (akind m) ++ " is here. "-                 Nothing -> ""-          else ""-        mode = case target of-                 TEnemy _ _ -> "[targeting monster] "-                 TLoc _   -> "[targeting location] "-                 TCursor  -> "[targeting current] "-        -- general info about current loc-        lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg-        -- check if there's something lying around at current loc-        t = lmap `at` loc-    if length (titems t) <= 2-      then do-             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-                ActorId ->     -- who's moving?-                Dir ->-                Action ()-moveOrAttack allowAttacks autoOpen actor dir-  | dir == (0,0) =-      -- Moving with no direction is a noop.-      -- We include it currently to prevent that-      -- monsters attack themselves by accident.-      advanceTime actor-  | otherwise = do-      -- We start by looking at the target position.-      state <- get-      pl    <- gets splayer-      lmap  <- gets (lmap . slevel)-      sm    <- gets (getActor actor)-      let sloc = aloc sm           -- source location-          tloc = sloc `shift` dir  -- target location-      tgt <- gets (locToActor tloc)-      case tgt of-        Just target ->-          if allowAttacks then-            -- Attacking does not require full access, adjacency is enough.-            actorAttackActor actor target-          else if accessible lmap sloc tloc then do-            -- Switching positions requires full access.-            actorRunActor actor target-            when (actor == pl) $-              messageAdd $ lookAt False True state lmap tloc ""-          else abortWith ""-        Nothing ->-          if accessible lmap sloc tloc then do-            -- perform the move-            updateAnyActor actor $ \ body -> body { aloc = tloc }-            when (actor == pl) $-              messageAdd $ lookAt False True state lmap tloc ""-            advanceTime actor-          else if allowAttacks && actor == pl-                  && canBeDoor (lmap `rememberAt` tloc) then do-            messageAdd "You search your surroundings."  -- TODO: proper msg-            search-          else if autoOpen then-            -- try to open a door-            actorOpenClose actor False True dir-          else abortWith ""---- | Resolves the result of an actor moving into another. Usually this--- involves melee attack, but with two heroes it just changes focus.--- Actors on blocked locations can be attacked without any restrictions.--- For instance, an actor on an open door can be attacked diagonally,--- and an actor capable of moving through walls can be attacked from an--- adjacent position.--- This function is analogous to zapGroupItem, but for melee--- and not using up the weapon.-actorAttackActor :: ActorId -> ActorId -> Action ()-actorAttackActor (AHero _) target@(AHero _) =-  -- Select adjacent hero by bumping into him. Takes no time.-  assertTrue $ selectPlayer target-actorAttackActor source target = do-  state <- get-  sm    <- gets (getActor source)-  tm    <- gets (getActor target)-  per   <- currentPerception-  let groupName = "sword"-      verb = attackToVerb groupName-      sloc = aloc sm-      -- The hand-to-hand "weapon", equivalent to +0 sword.-      h2h = Item ItemKind.swordKindId 0 Nothing 1-      str = strongestItem (aitems sm) groupName-      stack  = fromMaybe h2h str-      single = stack { icount = 1 }-      -- The message describes the source part of the action.-      -- TODO: right now it also describes the victim and weapon;-      -- perhaps, when a weapon is equipped, just say "you hit" or "you miss"-      -- and then "nose dies" or "nose yells in pain".-      msg = subjectVerbMObject sm verb tm $-              if isJust str then " with " ++ objectItem state single else ""-  when (sloc `S.member` ptvisible per) $ messageAdd msg-  -- Messages inside itemEffectAction describe the target part.-  itemEffectAction 0 source target single-  advanceTime source--attackToVerb :: String -> String-attackToVerb "sword" = "hit"  -- TODO: "slash"? "pierce"? "swing"?-attackToVerb "mace" = "bludgeon"-attackToVerb _ = "hit"---- | Resolves the result of an actor running into another.--- This involves switching positions of the two actors.-actorRunActor :: ActorId -> ActorId -> Action ()-actorRunActor source target = do-  pl    <- gets splayer-  sloc  <- gets (aloc . getActor source)  -- source location-  tloc  <- gets (aloc . getActor target)  -- target location-  updateAnyActor source $ \ m -> m { aloc = tloc }-  updateAnyActor target $ \ m -> m { aloc = sloc }-  if source == pl-    then stopRunning  -- do not switch positions repeatedly-    else if isAMonster source-         then focusIfAHero target-         else return ()-  advanceTime source---- | Generate a monster, possibly.-generateMonster :: Action ()-generateMonster =-  do  -- TODO: simplify-    state  <- get-    nstate <- liftIO $ rndToIO $ rollMonster state-    modify (const nstate)---- | Possibly regenerate HP for all actors on the current level.-regenerateLevelHP :: Action ()-regenerateLevelHP =-  do-    time  <- gets stime-    let upd m =-          let regen = bregen (akind m) `div`-                      case strongestItem (aitems m) "amulet" of-                        Just i  -> ipower i-                        Nothing -> 1-          in if time `mod` regen /= 0-             then m-             else m { ahp = min (bhpMax (akind m)) (ahp m + 1) }-    -- We really want hero selection to be a purely UI distinction,-    -- so all heroes need to regenerate, not just the player.-    -- Only the heroes on the current level regenerate (others are frozen-    -- in time together with their level). This prevents cheating-    -- via sending one hero to a safe level and waiting there.-    modify (updateLevel (updateHeroes   (IM.map upd)))-    modify (updateLevel (updateMonsters (IM.map upd)))
− src/Actor.hs 
@@ -1,83 +0,0 @@-module Actor where--import Data.Binary-import Control.Monad--import Geometry-import Item-import ActorKind---- | Monster properties that are changing a lot. If they are dublets--- of properties form ActorKind, the intention is they may be modified--- temporarily, but will return to the original value over time. E.g., HP.-data Actor = Actor-  { akind   :: !ActorKind, -- ^ kind of the actor; TODO: make this an index-    ahp     :: !Int,       -- ^ current hit pints-    adir    :: Maybe Dir,  -- ^ the direction of running-    atarget :: Target,     -- ^ the target for distance attacks and AI-    aloc    :: !Loc,       -- ^ current location-    aitems  :: [Item],     -- ^ inventory-    aletter :: !Char,      -- ^ next inventory letter-    atime   :: !Time }     -- ^ time of next action-  deriving Show--instance Binary Actor where-  put (Actor akind ahp adir atarget aloc aitems aletter atime) =-    do-      put akind-      put ahp-      put adir-      put atarget-      put aloc-      put aitems-      put aletter-      put atime-  get = do-          akind   <- get-          ahp     <- get-          adir    <- get-          atarget <- get-          aloc    <- get-          aitems  <- get-          aletter <- get-          atime   <- get-          return (Actor akind ahp adir atarget aloc aitems aletter atime)--data ActorId = AHero Int     -- ^ hero index (on the lheroes intmap)-             | AMonster Int  -- ^ monster index (on the lmonsters intmap)-  deriving (Show, Eq, Ord)--isAHero :: ActorId -> Bool-isAHero (AHero _) = True-isAHero (AMonster _) = False--isAMonster :: ActorId -> Bool-isAMonster = not . isAHero--instance Binary ActorId where-  put (AHero n)    = putWord8 0 >> put n-  put (AMonster n) = putWord8 1 >> put n-  get = do-          tag <- getWord8-          case tag of-            0 -> liftM AHero get-            1 -> liftM AMonster get-            _ -> fail "no parse (ActorId)"--data Target =-    TEnemy ActorId Loc  -- ^ fire at the actor; last seen location-  | TLoc Loc            -- ^ fire at a given location-  | TCursor             -- ^ fire at the current position of the cursor; default-  deriving (Show, Eq)--instance Binary Target where-  put (TEnemy a ll) = putWord8 0 >> put a >> put ll-  put (TLoc loc) = putWord8 1 >> put loc-  put TCursor    = putWord8 2-  get = do-          tag <- getWord8-          case tag of-            0 -> liftM2 TEnemy get get-            1 -> liftM TLoc get-            2 -> return TCursor-            _ -> fail "no parse (Target)"
− src/ActorAdd.hs 
@@ -1,108 +0,0 @@-module ActorAdd where--import Prelude hiding (floor)-import qualified Data.IntMap as IM-import Data.List as L-import Data.Map as M-import Data.Ratio-import Data.Maybe-import qualified Data.Char as Char--import Geometry-import State-import Level-import Dungeon-import Actor-import ActorState-import ActorKind-import Random-import qualified Config---- Generic functions---- setting the time of new monsters to 0 makes them able to--- move immediately after generation; this does not seem like--- a bad idea, but it would certainly be "more correct" to set--- the time to the creation time instead-template :: ActorKind -> Int -> Loc -> Actor-template mk hp loc = Actor mk hp Nothing TCursor loc [] 'a' 0--nearbyFreeLoc :: Loc -> State -> Loc-nearbyFreeLoc origin state@(State { slevel = Level { lmap = map } }) =-  let hs = levelHeroList state-      ms = levelMonsterList state-      places = origin : L.nub (concatMap surroundings places)-      good loc = open (map `at` loc) && not (loc `L.elem` L.map aloc (hs ++ ms))-  in  fromMaybe (error "no nearby free location found") $ L.find good places---- Adding heroes--findHeroName :: Config.CP -> Int -> String-findHeroName config n =-  let heroName = Config.getOption config "heroes" ("HeroName_" ++ show n)-  in  fromMaybe ("hero number " ++ show n) heroName---- | Create a new hero on the current level, close to the given location.-addHero :: Loc -> State -> State-addHero ploc state =-  let config = sconfig state-      bHP = Config.get config "heroes" "baseHP"-      mk = hero {bhpMin = bHP, bhpMax = bHP, bsymbol = symbol, bname = name }-      loc = nearbyFreeLoc ploc state-      n = fst (scounter state)-      symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n-      name = findHeroName config n-      startHP = bHP `div` (min 10 (n + 1))-      m = template mk startHP loc-      state' = state { scounter = (n + 1, snd (scounter state)) }-  in  updateLevel (updateHeroes (IM.insert n m)) state'---- | Create a set of initial heroes on the current level, at location ploc.-initialHeroes :: Loc -> State -> State-initialHeroes ploc state =-  let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes"-  in  iterate (addHero ploc) state !! k---- Adding monsters---- | Chance that a new monster is generated. Currently depends on the--- number of monsters already present, and on the level. In the future,--- the strength of the character and the strength of the monsters present--- could further influence the chance, and the chance could also affect--- which monster is generated.-monsterGenChance :: LevelName -> Int -> Rnd Bool-monsterGenChance (LambdaCave depth) numMonsters =-  chance $ 1%(fromIntegral (250 + 200 * (numMonsters - depth)) `max` 50)-monsterGenChance _ _ = return False---- | Create a new monster in the level, at a random position.-addMonster :: ActorKind -> Int -> Loc -> State -> State-addMonster mk hp ploc state = do-  let loc = nearbyFreeLoc ploc state-      n = snd (scounter state)-      m = template mk hp loc-      state' = state { scounter = (fst (scounter state), n + 1) }-  updateLevel (updateMonsters (IM.insert n m)) state'---- | Create a new monster in the level, at a random position.-rollMonster :: State -> Rnd State-rollMonster state@(State { slevel = lvl }) = do-  let hs = levelHeroList state-      ms = levelMonsterList state-  rc <- monsterGenChance (lname lvl) (L.length ms)-  if not rc-    then return state-    else do-      -- TODO: new monsters should always be generated in a place that isn't-      -- visible by the player (if possible -- not possible for bigrooms)-      -- levels with few rooms are dangerous, because monsters may spawn-      -- in adjacent and unexpected places-      loc <- findLocTry 1000 lvl-             (\ l t -> open t-                       && not (l `L.elem` L.map aloc (hs ++ ms)))-             (\ l t -> floor t-                       && L.all (\ pl -> distance (aloc pl, l) > 400) hs)-      let fmk = Frequency $ L.zip (L.map bfreq dungeonMonsters) dungeonMonsters-      mk <- frequency fmk-      hp <- randomR (bhpMin mk, bhpMax mk)-      return $ addMonster mk hp loc state
− src/ActorKind.hs 
@@ -1,111 +0,0 @@-module ActorKind where--import Data.Binary-import Control.Monad--import Geometry-import Random-import qualified Color---- | Monster properties that are changing rarely and permanently.-data ActorKind = ActorKind-  { bhpMin  :: !Int,          -- ^ minimal initial hp-    bhpMax  :: !Int,          -- ^ maximal possible and initial hp-    bspeed  :: !Time,         -- ^ natural speed-    bsymbol :: !Char,         -- ^ map symbol-    bcolor  :: !Color.Color,  -- ^ map color-    bname   :: String,        -- ^ name-    bsight  :: !Bool,         -- ^ can it see?-    bsmell  :: !Bool,         -- ^ can it smell?-    biq     :: !Int,          -- ^ intelligence-    bregen  :: !Int,          -- ^ regeneration interval-    bfreq   :: !Int           -- ^ dungeon frequency-  }-  deriving (Show, Eq)--instance Binary ActorKind where-  put (ActorKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq) =-    do-      put nhpMin-      put nhpMax-      put nsp-      put nsym-      put ncol-      put nnm-      put nsi-      put nsm-      put niq-      put nreg-      put nfreq-  get = do-    nhpMin <- get-    nhpMax <- get-    nsp    <- get-    nsym   <- get-    ncol   <- get-    nnm    <- get-    nsi    <- get-    nsm    <- get-    niq    <- get-    nreg   <- get-    nfreq  <- get-    return (ActorKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq)---- | The list of kinds of monsters that appear randomly throughout the dungeon.-dungeonMonsters :: [ActorKind]-dungeonMonsters = [eye, fastEye, nose]--hero, eye, fastEye, nose :: ActorKind-hero = ActorKind-  { bhpMin  = 50,-    bhpMax  = 50,-    bspeed  = 10,-    bsymbol = '@',-    bname   = "you",-    bcolor  = Color.BrWhite,  -- Heroes white, monsters colorful.-    bsight  = True,-    bsmell  = False,-    biq     = 13,  -- Can see secret doors under alien control.-    bregen  = 1500,-    bfreq   = 0-  }--eye = ActorKind-  { bhpMin  = 1,  -- falls in 1--4 unarmed rounds-    bhpMax  = 12,-    bspeed  = 10,-    bsymbol = 'e',-    bcolor  = Color.BrRed,-    bname   = "the reducible eye",-    bsight  = True,-    bsmell  = False,-    biq     = 8,-    bregen  = 1500,-    bfreq   = 6-  }-fastEye = ActorKind-  { bhpMin  = 1,  -- falls in 1--2 unarmed rounds-    bhpMax  = 6,-    bspeed  = 4,-    bsymbol = 'e',-    bcolor  = Color.BrBlue,-    bname   = "the super-fast eye",-    bsight  = True,-    bsmell  = False,-    biq     = 12,-    bregen  = 1500,-    bfreq   = 1-  }-nose = ActorKind-  { bhpMin  = 6,  -- 2--5 and in 1 round of the strongest sword-    bhpMax  = 13,-    bspeed  = 11,-    bsymbol = 'n',-    bcolor  = Color.Green,-    bname   = "the point-free nose",-    bsight  = False,-    bsmell  = True,-    biq     = 0,-    bregen  = 1500,-    bfreq   = 2-  }
− src/ActorState.hs 
@@ -1,122 +0,0 @@-module ActorState where--import qualified Data.List as L-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.IntMap as IM-import Control.Monad-import Data.Maybe-import Control.Exception (assert)--import Geometry-import Actor-import Level-import Dungeon-import State---- The operations with "Any", and those that use them, consider all the dungeon.--- All the other actor and level operations only consider the current level.---- | Finds an actor body on any level. Error if not found.-findActorAnyLevel :: ActorId -> State -> Maybe (LevelName, Actor)-findActorAnyLevel actor state@(State { slevel   = lvl,-                                       sdungeon = Dungeon m }) =-  let chk lvl =-        fmap (\ m -> (lname lvl, m)) $-        case actor of-          AHero n    -> IM.lookup n (lheroes lvl)-          AMonster n -> IM.lookup n (lmonsters lvl)-  in  listToMaybe $ mapMaybe chk (lvl : M.elems m)--getPlayerBody :: State -> Actor-getPlayerBody state = snd $ fromMaybe (error "getPlayerBody") $-                      findActorAnyLevel (splayer state) state---- | The list of actors and levels for all heroes in the dungeon.--- Heroes from the current level go first.-allHeroesAnyLevel :: State -> [(ActorId, LevelName)]-allHeroesAnyLevel state =-  let Dungeon m = sdungeon state-      one (Level { lname = ln, lheroes = hs }) =-        L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs hs)-  in  L.concatMap one (slevel state : M.elems m)--updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State-updateAnyActorBody actor f state =-  case findActorAnyLevel actor state of-    Just (ln, _) ->-      case actor of-        AHero n    -> updateAnyLevel (updateHeroes   $ IM.adjust f n) ln state-        AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state-    Nothing -> error "updateAnyActorBody"--updateAnyLevel :: (Level -> Level) -> LevelName -> State -> State-updateAnyLevel f ln state@(State { slevel = level,-                                   sdungeon = Dungeon dng })-  | ln == lname level = updateLevel f state-  | otherwise = updateDungeon (const $ Dungeon $ M.adjust f ln dng) state---- | Calculate the location of player's target.-targetToLoc :: S.Set Loc -> State -> Maybe Loc-targetToLoc visible state =-  case atarget (getPlayerBody state) of-    TLoc loc -> Just loc-    TCursor  ->-      if lname (slevel state) == clocLn (scursor state)-      then Just $ clocation (scursor state)-      else Nothing  -- cursor invalid: set at a different level-    TEnemy a _ll -> do-      guard $ memActor a state           -- alive and on the current level?-      let loc = aloc (getActor a state)-      guard $ S.member loc visible       -- visible?-      return loc---- The operations below disregard levels other than the current.---- | Checks if the actor is present on the current level.-memActor :: ActorId -> State -> Bool-memActor a (State { slevel = lvl }) =-  case a of-    AHero n    -> IM.member n (lheroes lvl)-    AMonster n -> IM.member n (lmonsters lvl)---- | Gets actor body from the current level. Error if not found.-getActor :: ActorId -> State -> Actor-getActor a (State { slevel = lvl }) =-  case a of-    AHero n    -> lheroes   lvl IM.! n-    AMonster n -> lmonsters lvl IM.! n---- | Removes the actor, if present, from the current level.-deleteActor :: ActorId -> State -> State-deleteActor a =-  case a of-    AHero n    -> updateLevel (updateHeroes   (IM.delete n))-    AMonster n -> updateLevel (updateMonsters (IM.delete n))---- | Add actor to the current level.-insertActor :: ActorId -> Actor -> State -> State-insertActor a m =-  case a of-    AHero n    -> updateLevel (updateHeroes   (IM.insert n m))-    AMonster n -> updateLevel (updateMonsters (IM.insert n m))--levelHeroList, levelMonsterList :: State -> [Actor]-levelHeroList    (State { slevel = Level { lheroes   = hs } }) = IM.elems hs-levelMonsterList (State { slevel = Level { lmonsters = ms } }) = IM.elems ms---- | Finds an actor at a location on the current level. Perception irrelevant.-locToActor :: Loc -> State -> Maybe ActorId-locToActor loc state =-  let l = locToActors loc state-  in assert (L.length l <= 1) $-       listToMaybe l--locToActors :: Loc -> State -> [ActorId]-locToActors loc state =-  getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero)-    where-      getIndex (projection, injection) =-        let l  = IM.assocs $ projection $ slevel state-            im = L.filter (\ (_i, m) -> aloc m == loc) l-        in  fmap (injection . fst) im
− src/Color.hs 
@@ -1,119 +0,0 @@-module Color where--import Control.Monad-import qualified Data.Binary as Binary--data Color =-    Black-  | Red-  | Green-  | Yellow-  | Blue-  | Magenta-  | Cyan-  | White-  | BrBlack-  | BrRed-  | BrGreen-  | BrYellow-  | BrBlue-  | BrMagenta-  | BrCyan-  | BrWhite-  deriving (Show, Eq, Ord, Enum, Bounded)--instance Binary.Binary Color where-  put = Binary.putWord8 . fromIntegral . fromEnum-  get = liftM (toEnum . fromIntegral) Binary.getWord8--defBG, defFG :: Color-defBG = Black-defFG = White--type Attr = (Color.Color, Color.Color)-defaultAttr :: Attr-defaultAttr = (Color.defFG, Color.defBG)--isBright :: Color -> Bool-isBright c = fromEnum c > 7  -- for terminals that display bright via bold---- | Due to limitation of curses, only these are legal backgrounds.-legalBG :: [Color]-legalBG = [Black, White, Blue, Magenta]---- Heavily modified Linux console colors.-colorToRGB :: Color -> String-colorToRGB Black     = "#000000"-colorToRGB Red       = "#D50000"-colorToRGB Green     = "#00AA00"-colorToRGB Yellow    = "#AA5500"  -- brown-colorToRGB Blue      = "#203AF0"-colorToRGB Magenta   = "#AA00AA"-colorToRGB Cyan      = "#00AAAA"-colorToRGB White     = "#C5BCB8"-colorToRGB BrBlack   = "#6F5F5F"-colorToRGB BrRed     = "#FF5555"-colorToRGB BrGreen   = "#75FF45"-colorToRGB BrYellow  = "#FFE855"-colorToRGB BrBlue    = "#4090FF"-colorToRGB BrMagenta = "#FF77FF"-colorToRGB BrCyan    = "#60FFF0"-colorToRGB BrWhite   = "#FFFFFF"---- For reference, the original Linux console colors.--- Good old retro feel and more useful than xterm (e.g. brown).-colorToRGB' :: Color -> String-colorToRGB' Black     = "#000000"-colorToRGB' Red       = "#AA0000"-colorToRGB' Green     = "#00AA00"-colorToRGB' Yellow    = "#AA5500"  -- brown-colorToRGB' Blue      = "#0000AA"-colorToRGB' Magenta   = "#AA00AA"-colorToRGB' Cyan      = "#00AAAA"-colorToRGB' White     = "#AAAAAA"-colorToRGB' BrBlack   = "#555555"-colorToRGB' BrRed     = "#FF5555"-colorToRGB' BrGreen   = "#55FF55"-colorToRGB' BrYellow  = "#FFFF55"-colorToRGB' BrBlue    = "#5555FF"-colorToRGB' BrMagenta = "#FF55FF"-colorToRGB' BrCyan    = "#55FFFF"-colorToRGB' BrWhite   = "#FFFFFF"---- Human-readable names, for item descriptions. The simple set.-colorToName :: Color -> String-colorToName Black     = "black"-colorToName Red       = "red"-colorToName Green     = "green"-colorToName Yellow    = "brown"-colorToName Blue      = "blue"-colorToName Magenta   = "purple"-colorToName Cyan      = "cyan"-colorToName White     = "ivory"-colorToName BrBlack   = "gray"-colorToName BrRed     = "coral"-colorToName BrGreen   = "lime"-colorToName BrYellow  = "yellow"-colorToName BrBlue    = "azure"-colorToName BrMagenta = "pink"-colorToName BrCyan    = "aquamarine"-colorToName BrWhite   = "white"---- The fancy set.-colorToName' :: Color -> String-colorToName' Black     = "smoky black"-colorToName' Red       = "apple red"-colorToName' Green     = "forest green"-colorToName' Yellow    = "mahogany"-colorToName' Blue      = "royal blue"-colorToName' Magenta   = "indigo"-colorToName' Cyan      = "teal"-colorToName' White     = "silver gray"-colorToName' BrBlack   = "charcoal"-colorToName' BrRed     = "salmon"-colorToName' BrGreen   = "emerald"-colorToName' BrYellow  = "amber"-colorToName' BrBlue    = "sky blue"-colorToName' BrMagenta = "magenta"-colorToName' BrCyan    = "turquoise"-colorToName' BrWhite   = "ghost white"
− src/Command.hs 
@@ -1,41 +0,0 @@-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 
@@ -1,113 +0,0 @@-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 "LambdaHack"-    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 "LambdaHack"-    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 
@@ -1,19 +0,0 @@-{-# 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 
@@ -1,208 +0,0 @@-{-# 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 Actor-import ActorState-import ActorKind-import Item-import qualified Keys as K-import qualified Terrain---- Re-exported from the display frontend, with an extra slot for function--- for translating keys to a canonical form.-type InternalSession = D.Session-type Session = (InternalSession, M.Map K.Key K.Key)-display area = D.display area . fst-startup = D.startup-shutdown = D.shutdown . fst-displayId = D.displayId---- | Next event translated to a canonical form.-nextCommand :: MonadIO m => Session -> m K.Key-nextCommand session =-  do-    e <- liftIO $ D.nextEvent (fst session)-    return $-      case M.lookup e (snd session) of-        Just key -> key-        Nothing  -> K.canonMoveKey e---- | Displays a message on a blank screen. Waits for confirmation.-displayBlankConfirm :: Session -> String -> IO Bool-displayBlankConfirm session txt =-  let x = txt ++ more-      doBlank = const (Color.defaultAttr, ' ')-  in do-       display ((0, 0), normalLevelSize) session doBlank x ""-       getConfirm session---- | Waits for a space or return or '?' or '*'. The last two act this way,--- to let keys that request information toggle display the information off.-getConfirm :: MonadIO m => Session -> m Bool-getConfirm session =-  getOptionalConfirm return (const $ getConfirm session) session--getOptionalConfirm :: MonadIO m =>-                      (Bool -> m a) -> (K.Key -> m a) -> Session -> m a-getOptionalConfirm h k session =-  do-    e <- liftIO $ nextCommand session-    case e of-      K.Char ' ' -> h True-      K.Char '?' -> h True-      K.Char '*' -> h True-      K.Return   -> h True-      K.Esc      -> h False-      _          -> k e---- | A yes-no confirmation.-getYesNo :: MonadIO m => Session -> m Bool-getYesNo session =-  do-    e <- liftIO $ nextCommand session-    case e of-      K.Char 'y' -> return True-      K.Char 'n' -> return False-      K.Esc      -> return False-      _          -> getYesNo session--splitOverlay :: Int -> String -> [[String]]-splitOverlay s xs = splitOverlay' (lines xs)-  where-    splitOverlay' ls-      | length ls <= s = [ls]  -- everything fits on one screen-      | otherwise      = let (pre,post) = splitAt (s - 1) ls-                         in  (pre ++ [more]) : splitOverlay' post---- | Returns a function that looks up the characters in the--- string by location. Takes the height of the display plus--- the string. Returns also the number of screens required--- to display all of the string.-stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)-stringByLocation sy xs =-  let-    ls   = splitOverlay sy xs-    m    = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))-    k    = length ls-  in-    (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)--data ColorMode = ColorFull | ColorBW--displayLevel ::-  ColorMode -> Session -> Perceptions -> State -> Message -> Maybe String-  -> IO Bool-displayLevel-  dm session per-  (state@(State { scursor = cursor,-                  stime   = time,-                  sassocs = assocs,-                  slevel  = Level ln _ (sy, sx) _ smap lmap _ }))-  msg moverlay =-  let Actor { akind = ActorKind { bhpMax = xhp },-              ahp = php, aloc = ploc, aitems = pitems } = getPlayerBody state-      reachable = ptreachable per-      visible   = ptvisible per-      overlay   = fromMaybe "" moverlay-      (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed-      sSml   = ssensory state == Smell-      sVis   = case ssensory state of Vision _ -> True; _ -> False-      sOmn   = sdisplay state == Omniscient-      sTer   = case sdisplay state of Terrain n -> n; _ -> 0-      lAt    = if sOmn || sTer > 0 then at else rememberAt-      sVisBG = if sVis-               then \ vis rea -> if vis-                                 then Color.Blue-                                 else if rea-                                      then Color.Magenta-                                      else Color.defBG-                else \ vis rea -> Color.defBG-      wealth  = L.sum $ L.map itemPrice pitems-      damage  = case strongestItem pitems "sword" of-                  Just sw -> 3 + ipower sw-                  Nothing -> 3-      hs      = levelHeroList state-      ms      = levelMonsterList state-      dis n loc =-        let tile = lmap `lAt` loc-            sml  = ((smap ! loc) - time) `div` 100-            viewActor loc (Actor { akind = mk })-              | loc == ploc && ln == creturnLn cursor =-                  (bsymbol mk, Color.defBG)  -- highlight player-              | otherwise = (bsymbol mk, bcolor mk)-            viewSmell :: Int -> Char-            viewSmell n-              | n > 9     = '*'-              | n < 0     = '-'-              | otherwise = Char.intToDigit n-            rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1)-            (char, fg) =-              case L.find (\ m -> loc == aloc m) (hs ++ ms) of-                _ | sTer > 0 -> Terrain.viewTerrain sTer False (tterrain tile)-                Just m | sOmn || vis -> viewActor loc m-                _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc)-                  | otherwise        -> viewTile vis tile assocs-            vis = S.member loc visible-            rea = S.member loc reachable-            bg = if ctargeting cursor && loc == clocation cursor-                 then Color.defFG      -- highlight targeting cursor-                 else sVisBG vis rea  -- FOV debug-            reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)-            optVisually (fg, bg) =-              if fg == Color.defBG-              then reverseVideo-              else if bg == Color.defFG && fg == Color.defFG-                   then reverseVideo-                   else (fg, bg)-            a = case dm of-                  ColorBW   -> Color.defaultAttr-                  ColorFull -> optVisually (fg, bg)-        in case over (loc `shift` ((sy+1) * n, 0)) of-             Just c -> (Color.defaultAttr, c)-             _      -> (a, char)-      status =-        take 30 (levelName ln ++ repeat ' ') ++-        take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') ++-        take 10 ("$: " ++ show wealth ++ repeat ' ') ++-        take 10 ("Dmg: " ++ show damage ++ repeat ' ') ++-        take 20 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ')-      disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg status-      msgs = splitMsg sx msg-      perf k []     = perfo k ""-      perf k [xs]   = perfo k xs-      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->-                      if b then perf k xs else return False-      perfo k xs-        | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->-                      if b then perfo (k+1) xs else return False-        | otherwise = disp k xs >> return True-  in  perf 0 msgs
− src/Display/Curses.hs 
@@ -1,126 +0,0 @@-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; see https://github.com/skogsbaer/hscurses/issues/10-    -- For now, movement keys are more important than hero selection:-    C.KeyChar c-      | c `elem` ['1'..'9'] -> K.KP c-      | otherwise           -> K.Char c-    _                       -> K.Unknown (show e)--nextEvent :: Session -> IO K.Key-nextEvent session =-  do-    e <- C.getKey refresh-    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 
@@ -1,172 +0,0 @@-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 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White-    widgetModifyBase tv StateNormal black-    widgetModifyText tv StateNormal white--    ec <- newChan-    forkIO $ k (Session ec tts tv)--    onKeyPress tv (\ e -> postGUIAsync (writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)) >> return True)--    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 
@@ -1,96 +0,0 @@-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.--- HSCurses does this by default, but in Vty you have to request the hack.-hack c a = if Color.isBright c then with_style a bold else a--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 
@@ -1,343 +0,0 @@-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 Terrain-import qualified ItemKind---- | The complete dungeon is a map from level names to levels.--- We usually store all but the current level in this data structure.-newtype Dungeon = Dungeon (M.Map LevelName Level)-  deriving Show--instance Binary Dungeon where-  put (Dungeon dng) = put (M.elems dng)-  get = liftM dungeon get---- | Create a dungeon from a list of levels.-dungeon :: [Level] -> Dungeon-dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))---- | Extract a level from a dungeon.-getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)-getDungeonLevel ln (Dungeon dng) = (dng ! ln, Dungeon (M.delete ln dng))---- | Put a level into a dungeon.-putDungeonLevel :: Level -> Dungeon -> Dungeon-putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)--sizeDungeon :: Dungeon -> Int-sizeDungeon (Dungeon dng) = M.size dng--type Corridor = [(Y,X)]-type Room = Area---- | 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---- | Actually dig a corridor.-digCorridor :: Corridor -> LMap -> LMap-digCorridor (p1:p2:ps) l =-  digCorridor (p2:ps) (M.unionWith corridorUpdate newPos l)-  where-    newPos = M.fromList [ (ps,newTile Corridor) | ps <- fromTo p1 p2 ]-    corridorUpdate _ (Tile (Wall hv) is,u)    = (Tile (Opening hv) is,u)-    corridorUpdate _ (Tile (Opening hv) is,u) = (Tile (Opening hv) is,u)-    corridorUpdate _ (Tile (Floor l) is,u)    = (Tile (Floor l) is,u)-    corridorUpdate (x,u) _                    = (x,u)-digCorridor _ l = l---- | Create a new tile.-newTile :: Terrain DungeonLoc -> (Tile, Tile)-newTile t = (Tile t [], Tile Unknown [])---- | Create a level consisting of only one room. Optionally, insert some walls.-emptyRoom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig ->-           LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-emptyRoom addWallsRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm =-  do-    let lmap = digRoom Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx))-    let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ]-    let lvl = Level nm 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-    addWalls <- addWallsRnd lvl-    let addItem lmap (l,it) =-          M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l lmap-        flmap lu ld =-          addWalls $-          maybe id (\ l -> M.insert su (newTile (Stairs Light Up   l))) lu $-          maybe id (\ l -> M.insert sd (newTile (Stairs Light Down l))) ld $-          (\lmap -> 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 ->-           LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> 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 ->-             LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-noiseRoom cfg =-  let addWalls lvl = do-        rs <- rollPillars cfg lvl-        let insertWall lmap l =-              case lmap `at` l of-                Tile (Floor _) [] -> M.insert l (newTile (Wall O)) lmap-                _ -> lmap-        return $ \ lmap -> L.foldl' insertWall lmap rs-  in  emptyRoom addWalls 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.-rogueRoom :: LevelConfig ->-         LevelName ->-         Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) ->-              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, toDL (not c))) rooms) :: Rnd [((Loc, Loc), 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 lmap :: LMap-        lmap = L.foldr digCorridor (L.foldr (\ (r, dl) m -> digRoom dl r m)-                                        (emptyLMap (levelSize cfg)) dlrooms) cs-    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 (Opening hv) _ ->-                      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 (Door hv 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 (Stairs (toDL $ light t) Up   l)) su) lu $-                  maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Down l)) sd) ld $-                  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 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 :: DL -> Room -> LMap -> LMap-digRoom dl ((y0,x0),(y1,x1)) l-  | y0 == y1 && x0 == x1 =-  M.insert (y0,x0) (newTile Corridor) l-  | otherwise =-  let rm = M.fromList $ [ ((y,x),newTile (Floor dl))   | x <- [x0..x1],     y <- [y0..y1]    ]-                     ++ [ ((y,x),newTile (Wall p))     | (x,y,p) <- [(x0-1,y0-1,UL),(x1+1,y0-1,UR),(x0-1,y1+1,DL),(x1+1,y1+1,DR)] ]-                     ++ [ ((y,x),newTile (Wall p))     | x <- [x0..x1], (y,p) <- [(y0-1,U),(y1+1,D)] ]-                     ++ [ ((y,x),newTile (Wall p))     | (x,p) <- [(x0-1,L),(x1+1,R)],  y <- [y0..y1]    ]-  in M.unionWith const rm l
− src/DungeonState.hs 
@@ -1,40 +0,0 @@-module DungeonState where--import Data.Map as M--import Geometry-import Level-import Dungeon-import Random-import qualified Config--connect ::-  Maybe (Maybe DungeonLoc) ->-  [(Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)] ->-  [Level]-connect au [(x,_,_)] = [x au Nothing]-connect au ((x,_,d):ys@((_,u,_):_)) =-  let (z:zs) = connect (Just (Just (lname x',d))) ys-      x'     = x au (Just (Just (lname z,u)))-  in  x' : z : zs--matchGenerator n Nothing = rogueRoom  -- the default-matchGenerator n (Just "bigRoom")   = bigRoom-matchGenerator n (Just "noiseRoom") = noiseRoom-matchGenerator n (Just "rogueRoom") = rogueRoom-matchGenerator n (Just s) =-  error $ "matchGenerator: unknown: " ++ show n ++ ", " ++ s--findGenerator config n =-  let ln = "LambdaCave_" ++ show n-      genName = Config.getOption config "dungeon" ln-  in  matchGenerator n genName (defaultLevelConfig n) (LambdaCave n)---- | Generate the dungeon for a new game.-generate :: Config.CP -> Rnd (Loc, Level, Dungeon)-generate config = do-  let depth = Config.get config "dungeon" "depth"-  levels <- mapM (findGenerator config) [1..depth]-  let lvls = connect (Just Nothing) levels-      ploc = ((\ (_,x,_) -> x) (head levels))-  return $ (ploc, head lvls, dungeon (tail lvls))
− src/Effect.hs 
@@ -1,41 +0,0 @@-module Effect where--import Random--data Effect =-    NoEffect-  | Heal            -- healing strength in ipower-  | Wound RollDice  -- base damage, to-dam bonus in ipower-  | Dominate-  | SummonFriend-  | SummonEnemy-  | ApplyPerfume-  | Regneration-  | Searching-  deriving (Show, Eq, Ord)--effectToName :: Effect -> String-effectToName NoEffect = ""-effectToName Heal = "of healing"-effectToName (Wound (a, b)) = if a == 0 && b == 0-                              then "of wounding"-                              else "(" ++ show a ++ "d" ++ show b ++ ")"-effectToName Dominate = "of domination"-effectToName SummonFriend = "of aid calling"-effectToName SummonEnemy = "of summoning"-effectToName ApplyPerfume = "of rose water"-effectToName Regneration = "of regeneration"-effectToName Searching = "of searching"---- | How much AI benefits from applying the effect. Multipllied by item power.--- Negative means harm to the enemy when thrown. Zero won't ever be used.-effectToBenefit :: Effect -> Int-effectToBenefit NoEffect = 0-effectToBenefit Heal = 10           -- TODO: depends on (maxhp - hp)-effectToBenefit (Wound _) = -10     -- TODO: dice ignored for now-effectToBenefit Dominate = 0        -- AI can't use this-effectToBenefit SummonFriend = 100-effectToBenefit SummonEnemy = 0-effectToBenefit ApplyPerfume = 0-effectToBenefit Regneration = 0     -- much more benefit from carrying around-effectToBenefit Searching = 0       -- AI does not need to search
− src/EffectAction.hs 
@@ -1,334 +0,0 @@-module EffectAction where--import Control.Monad-import Control.Monad.State hiding (State)-import Data.Function-import Data.List as L-import Data.Map as M-import qualified Data.IntMap as IM-import Data.Maybe-import Data.Set as S-import System.Time-import Control.Exception (assert)--import Action-import Display hiding (display)-import Dungeon-import Geometry-import Grammar-import qualified HighScores as H-import Item-import qualified ItemKind-import qualified Keys as K-import Level-import LevelState-import Message-import Actor-import ActorState-import ActorKind-import ActorAdd-import Perception-import Random-import State-import qualified Config-import qualified Save-import Terrain-import qualified Effect---- The effectToAction function and all it depends on.--- This file should not depend on Action.hs nor ItemAction.hs.---- | The source actor affects the target actor, with a given effect and power.--- The second argument is verbosity of the resulting message.--- TODO: instead of verbosity return msg components and tailor them outside?--- Both actors are on the current level and can be the same actor.--- The bool result indicates if the actors identify the effect.--- TODO: separately define messages for the case when source == target--- and for the other case; then use the messages outside of effectToAction,--- depending on the returned bool, perception and identity of the actors.-effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int ->-                  Action (Bool, String)-effectToAction Effect.NoEffect _ source target power = nullEffect-effectToAction Effect.Heal _ _source target power = do-  tm <- gets (getActor target)-  if ahp tm >= bhpMax (akind tm) || power <= 0-    then nullEffect-    else do-      focusIfAHero target-      let upd m = m { ahp = min (bhpMax (akind m)) (ahp m + power) }-      updateAnyActor target upd-      return (True, subjectActorVerb (akind tm) "feel" ++ " better.")-effectToAction (Effect.Wound nDm) verbosity source target power = do-  n <- liftIO $ rndToIO $ rollDice nDm-  if (n + power <= 0) then nullEffect else do-    focusIfAHero target-    tm <- gets (getActor target)-    let newHP  = ahp tm - n - power-        killed = newHP <= 0-        msg = if source == target  -- a potion of wounding, etc.-              then subjectActorVerb (akind tm) "feel"-                   ++ if killed then " mortally" else ""-                   ++ " wounded."-              else if killed-                   then if isAHero target-                        then ""-                        else subjectActorVerb (akind tm) "die" ++ "."-                   else if verbosity <= 0-                        then ""-                        else if isAHero target-                             then subjectActorVerb (akind tm) "lose"-                                  ++ " " ++ show (n + power) ++ "HP."-                             else subjectActorVerb (akind tm) "hiss"-                                  ++ " in pain."-    updateAnyActor target $ \ m -> m { ahp = newHP }  -- Damage the target.-    when killed $ do-      -- Place the actor's possessions on the map.-      modify (updateLevel (dropItemsAt (aitems tm) (aloc tm)))-      -- Clean bodies up.-      pl <- gets splayer-      if target == pl-        then checkPartyDeath  -- kills the player and checks game over-        else modify (deleteActor target)  -- kills the enemy-    return (True, msg)-effectToAction Effect.Dominate _ source target power =-  if isAMonster target  -- Monsters have weaker will than heroes.-  then do-         assertTrue $ selectPlayer target-         -- Prevent AI from getting a few free moves until new player ready.-         updatePlayerBody (\ m -> m { atime = 0})-         display-         return (True, "")-  else nullEffect-effectToAction Effect.SummonFriend _ source target power = do-  tm <- gets (getActor target)-  if isAHero source-    then summonHeroes (1 + power) (aloc tm)-    else summonMonsters (1 + power) (aloc tm)-  return (True, "")-effectToAction Effect.SummonEnemy _ source target power = do-  tm <- gets (getActor target)-  if not $ isAHero source  -- a trick: monster player will summon a hero-    then summonHeroes (1 + power) (aloc tm)-    else summonMonsters (1 + power) (aloc tm)-  return (True, "")-effectToAction Effect.ApplyPerfume _ source target _ =-  if source == target-  then return (True, "Tastes like water, but with a strong rose scent.")-  else do-    let upd lvl = lvl { lsmell = M.map (const (-100)) (lsmell lvl) }-    modify (updateLevel upd)-    return (True, "The fragrance quells all scents in the vicinity.")-effectToAction Effect.Regneration verbosity source target power =-  effectToAction Effect.Heal verbosity source target power-effectToAction Effect.Searching _ source target power =-  return (True, "It gets lost and you search in vain.")--nullEffect :: Action (Bool, String)-nullEffect = return (False, "Nothing happens.")---- | The source actor affects the target actor, with a given item.--- If either actor is a hero, the item may get identified.-itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool-itemEffectAction verbosity source target item = do-  state <- get-  pl    <- gets splayer-  tm    <- gets (getActor target)-  per   <- currentPerception-  let effect = ItemKind.jeffect $ ItemKind.getIK $ ikind item-  -- The message describes the target part of the action.-  (b, msg) <- effectToAction effect verbosity source target (ipower item)-  -- Determine how the player perceives the event.-  -- TODO: factor it out as a function messageActor-  -- and messageActorVerb (incorporating subjectActorVerb).-  if aloc tm `S.member` ptvisible per-     then messageAdd msg-     else if not b-          then return ()  -- victim is not seen and nothing interestng happens-          else messageAdd "You hear some noises."-  -- If something happens, the item gets identified.-  when (b && (isAHero source || isAHero target)) $ discover item-  return b---- | Given item is now known to the player.-discover :: Item -> Action ()-discover i = do-  state <- get-  let ik = ikind i-      obj = unwords $ tail $ words $ objectItem state i-      msg = "The " ++ obj ++ " turns out to be "-      kind = ItemKind.getIK ik-      alreadyIdentified = L.length (ItemKind.jflavour kind) == 1 ||-                          ik `S.member` sdiscoveries state-  if alreadyIdentified-    then return ()-    else do-           modify (updateDiscoveries (S.insert ik))-           state <- get-           messageAdd $ msg ++ objectItem state i ++ "."---- | Make the actor controlled by the player.--- Focus on the actor if level changes. False, if nothing to do.-selectPlayer :: ActorId -> Action Bool-selectPlayer actor =-  do-    pl <- gets splayer-    if (actor == pl)-      then return False -- already selected-      else do-        state <- get-        case findActorAnyLevel actor state of-          Nothing -> abortWith $ "No such member of the party."-          Just (nln, pbody) -> do-            -- Make the new actor the player-controlled actor.-            modify (\ s -> s { splayer = actor })-            -- Record the original level of the new player.-            modify (updateCursor (\ c -> c { creturnLn = nln }))-            -- Don't continue an old run, if any.-            stopRunning-            -- Switch to the level.-            lvlSwitch nln-            -- Set smell display, depending on player capabilities.-            -- This also resets FOV mode.-            modify (\ s -> s { ssensory = if ActorKind.bsmell (akind pbody)-                                          then Smell-                                          else Implicit })-            -- Announce.-            messageAdd $ subjectActor (akind pbody) ++ " selected."-            return True--focusIfAHero :: ActorId -> Action ()-focusIfAHero target =-  if isAHero target-  then do-    -- Focus on the hero being wounded/displaced/etc.-    b <- selectPlayer target-    -- Display status line for the new hero.-    when b $ display >> return ()-  else return ()--summonHeroes :: Int -> Loc -> Action ()-summonHeroes n loc =-  assert (n > 0) $ do-  newHeroId <- gets (fst . scounter)-  modify (\ state -> iterate (addHero loc) state !! n)-  assertTrue $ selectPlayer (AHero newHeroId)-  -- Display status line for the new hero.-  display >> return ()--summonMonsters :: Int -> Loc -> Action ()-summonMonsters n loc = do-  let fmk = Frequency $ L.zip (L.map bfreq dungeonMonsters) dungeonMonsters-  mk <- liftIO $ rndToIO $ frequency fmk-  modify (\ state -> iterate (addMonster mk (bhpMax mk) loc) state !! n)---- | Remove dead heroes, check if game over.--- For now we only check the selected hero, but if poison, etc.--- is implemented, we'd need to check all heroes on the level.-checkPartyDeath :: Action ()-checkPartyDeath =-  do-    ahs    <- gets allHeroesAnyLevel-    pl     <- gets splayer-    pbody  <- gets getPlayerBody-    config <- gets sconfig-    when (ahp pbody <= 0) $ do  -- TODO: change to guard? define mzero? Why are the writes to to files performed when I call abort later? That probably breaks the laws of MonadPlus.-      go <- messageMoreConfirm ColorBW $-              subjectActorVerb (akind pbody) "die" ++ "."-      history  -- Prevent the messages from being repeated.-      let firstDeathEnds = Config.get config "heroes" "firstDeathEnds"-      if firstDeathEnds-        then gameOver go-        else case L.filter (\ (actor, _) -> actor /= pl) ahs of-               [] -> gameOver go-               (actor, _nln) : _ -> do-                 messageAdd "The survivors carry on."-                 -- Remove the dead player.-                 modify (deleteActor pl)-                 -- At this place the invariant that the player exists fails.-                 -- Focus on the new hero (invariant not needed).-                 assertTrue $ selectPlayer actor-                 -- At this place the invariant is restored again.---- | End game, showing the ending screens, if requested.-gameOver :: Bool -> Action ()-gameOver showEndingScreens =-  do-    when showEndingScreens $ do-      state <- get-      ln <- gets (lname . slevel)-      let total = calculateTotal state-          status = H.Killed ln-      handleScores True status total-      messageMore "Let's hope another party can save the day!"-    end---- | Calculate loot's worth for heroes on the current level.-calculateTotal :: State -> Int-calculateTotal s =-  L.sum $ L.map itemPrice $ L.concatMap aitems (levelHeroList s)---- | Handle current score and display it with the high scores. Scores--- should not be shown during the game, because ultimately the worth of items might give--- information about the nature of the items.--- False if display of the scores was void or interrupted by the user-handleScores :: Bool -> H.Status -> Int -> Action Bool-handleScores write status total =-  if (total == 0)-  then return False-  else do-    config  <- gets sconfig-    time    <- gets stime-    curDate <- liftIO getClockTime-    let points = case status of-                   H.Killed _ -> (total + 1) `div` 2-                   _ -> total-    let score = H.ScoreRecord points (-time) curDate status-    (placeMsg, slideshow) <- liftIO $ H.register config write score-    messageOverlaysConfirm placeMsg slideshow---- | Perform a level switch to a given level. False, if nothing to do.-lvlSwitch :: LevelName -> Action Bool-lvlSwitch nln =-  do-    ln <- gets (lname . slevel)-    if (nln == ln)-      then return False-      else do-        level   <- gets slevel-        dungeon <- gets sdungeon-        -- put back current level-        -- (first put back, then get, in case we change to the same level!)-        let full = putDungeonLevel level dungeon-        -- get new level-        let (new, ndng) = getDungeonLevel nln full-        modify (\ s -> s { sdungeon = ndng, slevel = new })-        return True---- effectToAction does not depend on this function right now, but it might,--- and I know no better place to put it.-displayItems :: Message -> Bool -> [Item] -> Action Bool-displayItems msg sorted is = do-  state <- get-  let inv = unlines $-            L.map (\ i -> letterLabel (iletter i) ++ objectItem state i ++ " ")-              ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)-  let ovl = inv ++ more-  messageReset msg-  overlay ovl--stopRunning :: Action ()-stopRunning = updatePlayerBody (\ p -> p { adir = Nothing })---- | Store current message in the history and reset current message.-history :: Action ()-history =-  do-    (_, sx) <- gets (lsize . slevel)-    msg     <- currentMessage-    messageClear-    config  <- gets sconfig-    let historyMax = Config.get config "ui" "historyMax"-        -- TODO: not ideal, continuations of sentences are atop beginnings.-        split = splitMsg sx (msg ++ " ")-    unless (L.null msg) $-      modify (updateHistory (take historyMax . (L.reverse split ++)))
− src/FOV.hs 
@@ -1,50 +0,0 @@-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 Debug.Trace--import FOV.Common-import FOV.Digital-import FOV.Permissive-import FOV.Shadow-import Geometry-import Level---- TODO: should Blind really be a FovMode, or a modifier? Let's decide--- when other similar modifiers are added.-data FovMode = Shadow | Permissive Int | Digital Int | Blind---- Three Field of View algorithms. Press 'V' to cycle among them in the game.---- The main FOV function.---- | Perform a full scan for a given location. Returns the locations--- that are currently in the field of view.-fullscan :: FovMode -> Loc -> LMap -> Set Loc-fullscan fovMode loc lmap =-  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 
@@ -1,58 +0,0 @@-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 
@@ -1,137 +0,0 @@-module FOV.Digital where--import Data.Set as S--import FOV.Common-import Geometry-import Level---- Digital FOV with a given range.---- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation,--- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been--- implemented before. The algorithm is based on the PFOV algorithm,--- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View.--- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los--- for some more context.---- | The current state of a scan is kept in Maybe (Line, ConvexHull).--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->-         Set Loc-dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =-  -- trace (show (d,s,e,ps,pe)) $-  S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]])-    -- the scanned area is a square, which is a sphere in this metric; good-    where-      ps = let (n, k) = dintersect sl d       -- minimal progress to check-           in  n `div` k-      pe = let (n, k) = dintersect el d       -- maximal progress to check-               -- Corners obstruct view, so the steep line, constructed-               -- from corners, is itself not a part of the view,-               -- so if its intersection with the line of diagonals is only-               -- at a corner, choose the diamond leading to a smaller view.-           in  -1 + n `divUp` k-      outside-        | d >= r = S.empty-        | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe))-        | open (l `at` tr (B(d, ps))) =-            dscan' (Just s) (ps+1)            -- start in light, jump ahead-        | otherwise = dscan' Nothing (ps+1)   -- start in shadow, jump ahead--      dscan' :: Maybe Edge -> Progress -> Set Loc-      dscan' (Just s@(_, sBumps)) ps-        | ps > pe = dscan r tr l (d+1) (s, e) -- reached end, scan next-        | closed (l `at` tr steepBump) =      -- entering shadow-            S.union-              (dscan r tr l (d+1) (s, (dline nep steepBump, neBumps)))-              (dscan' Nothing (ps+1))-        | otherwise = dscan' (Just s) (ps+1)  -- continue in light-        where-          steepBump = B(d, ps)-          gte = dsteeper steepBump-          nep = maximal gte sBumps-          neBumps = addHull gte steepBump eBumps--      dscan' Nothing ps-        | ps > pe = S.empty                   -- reached end while in shadow-        | open (l `at` tr shallowBump) =      -- moving out of shadow-            dscan' (Just (dline nsp shallowBump, nsBumps)) (ps+1)-        | otherwise = dscan' Nothing (ps+1)   -- continue in shadow-        where-          shallowBump = B(d, ps)-          gte = flip $ dsteeper shallowBump-          nsp = maximal gte eBumps-          nsBumps = addHull gte shallowBump sBumps--      dline p1 p2 =-        ddebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)--      dsteeper f p1 p2 =-        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2---- | The x coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of diamonds at distance d from (0, 0).-dintersect :: Line -> Distance -> (Int, Int)-dintersect (B(y, x), B(yf, xf)) d =-  ((d - y)*(xf - x) + x*(yf - y), yf - y)-{--Derivation of the formula:-The intersection point (yt, xt) satisfies the following equalities:-yt = d-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) + x (yf - y) = xt (yf - y)-xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)--General remarks:-A diamond is denoted by its left corner. Hero at (0,0).-Order of processing in the first quadrant rotated by 45 degrees is- 45678-  123-   @-so the first processed diamond is at (-1, 1). The order is similar-as for the shadow casting algorithm above and reversed wrt PFOV.-The line in the curent state of scan' is called the shallow line,-but it's the one that delimits the view from the left, while the steep-line is on the right, opposite to PFOV. We start scanning from the left.--The Loc coordinates are cartesian, the Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first roatated quadrant, the (Distance, Progress) cordinates-coincide with the Bump coordinates, unlike in PFOV.--}---- | Debug functions for DFOV:---- | Debug: calculate steeper for DFOV in another way and compare results.-ddebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool-ddebugSteeper f p1 p2 x =-  let (n1, k1) = dintersect (p1, f) 0-      (n2, k2) = dintersect (p2, f) 0-  in  if x == (n1 * k2 >= k1 * n2)-      then x-      else error $ "dsteeper: " ++ show (f, p1, p2, x)---- | Debug: check is a view border line for DFOV is legal.-ddebugLine :: Line -> Line-ddebugLine line@(B(y1, x1), B(y2, x2))-  | y1 == y2 && x1 == x2 =-      error $ "ddebugLine: wrongly defined line " ++ show line-  | y2 - y1 == 0 =-      error $ "ddebugLine: horizontal line " ++ show line-  | crossL0 =-      error $ "ddebugLine: crosses the X axis below 0 " ++ show line-  | crossG1 =-      error $ "ddebugLine: crosses the X axis above 1 " ++ show line-  | otherwise = line-    where-      (n, k)  = dintersect line 0-      (q, r)  = if k == 0 then (0, 0) else n `divMod` k-      crossL0 = q < 0  -- q truncated toward negative infinity-      crossG1 = q >= 1 && (q > 1 || r /= 0)
− src/FOV/Permissive.hs 
@@ -1,150 +0,0 @@-module FOV.Permissive where--import Data.Set as S--import FOV.Common-import Geometry-import Level---- Permissive FOV with a given range.---- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View,--- though the general structure is more influenced by recursive shadow casting,--- as implemented in Shadow.hs. In the result, this algorithm is much faster--- than the original algorithm on dense maps, since it does not scan--- areas blocked by shadows.--- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los--- for some more context.---- TODO: Scanning squares on horizontal lines in octants, not squares--- on diagonals in quadrants, may be much faster and a bit simpler.--- Right now we build new view on each end of each visible wall tile--- and this is necessary only for straight, thin, diagonal walls.---- | The current state of a scan is kept in Maybe (Line, ConvexHull).--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->-         Set Loc-pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =-  -- trace (show (d,s,e,ps,pe)) $-  if illegal-  then S.empty-  else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]])-    -- the area is diagonal, which is incorrect, but looks good enough-    where-      (ns, ks) = pintersect sl d-      (ne, ke) = pintersect el d-      -- Corners are translucent, so they are invisible, so if intersection-      -- is at a corner, choose pe that creates the smaller view.-      (ps, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check-      -- Single ray from an extremity, produces non-permissive digital lines.-      illegal  = let (n, k) = pintersect sl 0-                 in  ns*ke == ne*ks && (n == 0 || n == k)-      outside-        | d >= r = S.empty-        | open (l `at` tr (d, ps)) = pscan' (Just s) ps  -- start in light-        | ps == ns `divUp` ks = pscan' (Just s) ps       -- start in a corner-        | otherwise = pscan' Nothing (ps+1)              -- start in mid-wall--      dp2bump     (d, p) = B(p, d - p)-      bottomRight (d, p) = B(p, d - p + 1)-      tr = ptr . dp2bump--      pscan' :: Maybe Edge -> Progress -> Set Loc-      pscan' (Just s@(_, sBumps)) ps-        | ps > pe =                            -- reached end, scan next-            pscan r ptr l (d+1) (s, e)-        | closed (l `at` tr (d, ps)) =         -- entering shadow, steep bump-            let steepBump = bottomRight (d, ps)-                gte = flip $ psteeper steepBump-                -- sBumps may contain steepBump, but maximal will ignore it-                nep = maximal gte sBumps-                neBumps = addHull gte steepBump eBumps-            in  S.union-                  (pscan r ptr l (d+1) (s, (pline nep steepBump, neBumps)))-                  (pscan' Nothing (ps+1))-        | otherwise = pscan' (Just s) (ps+1)   -- continue in light--      pscan' Nothing ps-        | ps > ne `div` ke = S.empty           -- reached absolute end-        | otherwise =                          -- out of shadow, shallow bump-            -- the light can be just through a corner of diagonal walls-            -- and the recursive call verifies that at the same ps coordinate-            let shallowBump = bottomRight (d, ps)-                gte = psteeper shallowBump-                nsp = maximal gte eBumps-                nsBumps = addHull gte shallowBump sBumps-            in  pscan' (Just (pline nsp shallowBump, nsBumps)) ps--      pline p1 p2 =-        pdebugLine $  -- TODO: disable when it becomes a bottleneck-        (p1, p2)--      psteeper f p1 p2 =-        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck-        steeper f p1 p2---- | The y coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of squares at distance d from (0, 0).-pintersect :: Line -> Distance -> (Int, Int)-pintersect (B(y, x), B(yf, xf)) d =-  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))-{--Derivation of the formula:-The intersection point (yt, xt) satisfies the following equalities:-xt = 1 + d - yt-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-yt (xf - x) - y xf = xt (yf - y) - x yf-yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf-yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf-yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)--General remarks:-A square is denoted by its bottom-left corner. Hero at (0,0).-Order of processing in the first quadrant is-9-58-247-@136-so the first processed square is at (0, 1). The order is reversed-wrt the shadow casting algorithm above. The line in the curent state-of scan' is not the steep line, but the shallow line,-and we start scanning from the bottom right.--The Loc coordinates are cartesian, the Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first quadrant, the (Distance, Progress) cordinates-are mangled and not used for geometry.--}---- | Debug functions for PFOV:---- | Debug: calculate steeper for PFOV in another way and compare results.-pdebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool-pdebugSteeper f p1 p2 x =-  let (n1, k1) = pintersect (p1, f) 0-      (n2, k2) = pintersect (p2, f) 0-  in  if x == (n1 * k2 <= k1 * n2)-      then x-      else error $ "psteeper: " ++ show (f, p1, p2, x)---- | Debug: checks postconditions of borderLine.-pdebugLine :: Line -> Line-pdebugLine line@(B(y1, x1), B(y2, x2))-  | y1 == y2 && x1 == x2 =-      error $ "pdebugLine: wrongly defined line " ++ show line-  | x2 - x1 == - (y2 - y1) =-      error $ "pdebugLine: diagonal line " ++ show line-  | crossL0 =-      error $ "pdebugLine: crosses diagonal below 0 " ++ show line-  | crossG1 =-      error $ "pdebugLine: crosses diagonal above 1 " ++ show line-  | otherwise = line-    where-      (n, k)  = pintersect line 0-      (q, r)  = if k == 0 then (0, 0) else n `divMod` k-      crossL0 = q < 0  -- q truncated toward negative infinity-      crossG1 = q >= 1 && (q > 1 || r /= 0)
− src/FOV/Shadow.hs 
@@ -1,54 +0,0 @@-module FOV.Shadow where--import Data.Ratio-import Data.Set as S--import FOV.Common-import Geometry-import Level---- Recursive Shadow Casting.---- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.--- It's not designed for dungeons with diagonal walls, so they block visibility,--- though they don't block movement. Such cases appear in the game only--- when two corridors touch diagonally by accident and on the random pillars--- levels.---- | The current state of a scan is kept in a variable of Maybe Rational.--- If Just something, we're in a visible interval. If Nothing, we're in--- a shadowed interval.-scan :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc-scan tr l d (s,e) =-    let ps = downBias (s * fromIntegral d)   -- minimal progress to check-        pe = upBias (e * fromIntegral d)     -- maximal progress to check-        st = if open (l `at` tr (d,ps)) then Just s   -- start in light-                                        else Nothing  -- start in shadow-    in-        -- trace (show (d,s,e,ps,pe)) $-        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)-  where-    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc-    -- scan' st ps pe-    --   | trace (show (st,ps,pe)) False = undefined-    scan' (Just s) ps pe-      | s  >= e  = S.empty               -- empty interval-      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next-      | closed (l `at` tr (d,ps)) =-                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))-                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe-                                      -- entering shadow-      | otherwise = scan' (Just s) (ps+1) pe-                                      -- continue in light-    scan' Nothing ps pe-      | ps > pe  = S.empty            -- reached end while in shadow-      | open (l `at` tr (d,ps)) =-                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-                   in  scan' (Just ns) (ps+1) pe-                                      -- moving out of shadow-      | otherwise = scan' Nothing (ps+1) pe-                                      -- continue in shadow--downBias, upBias :: (Integral a, Integral b) => Ratio a -> b-downBias x = round (x - 1 % (denominator x * 3))-upBias   x = round (x + 1 % (denominator x * 3))
− src/File.hs 
@@ -1,22 +0,0 @@-module File where--import System.IO-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import Codec.Compression.Zlib as Z--strictReadCompressedFile :: FilePath -> IO LBS.ByteString-strictReadCompressedFile f =-    do-      h <- openBinaryFile f ReadMode-      c <- LBS.hGetContents h-      let d = Z.decompress c-      LBS.length d `seq` return d--strictDecodeCompressedFile :: Binary a => FilePath -> IO a-strictDecodeCompressedFile = fmap decode . strictReadCompressedFile--encodeCompressedFile :: Binary a => FilePath -> a -> IO ()-encodeCompressedFile f = LBS.writeFile f . Z.compress . encode-  -- note that LBS.writeFile opens the file in binary mode-
− src/Flavour.hs 
@@ -1,21 +0,0 @@-module Flavour where--import qualified Data.List as L-import Color---- TODO: add more variety, as the number of items increases-type Flavour = (Color, Bool)  -- the flag tells to use fancy color names--zipPlain cs = L.zip cs (repeat False)-zipFancy cs = L.zip cs (repeat True)-darkCol    = [Red .. Cyan]-brightCol  = [BrRed .. BrCyan]  -- BrBlack is not really that bright-stdCol     = darkCol ++ brightCol-stdFlav    = zipPlain stdCol ++ zipFancy stdCol--flavourToName :: Flavour -> String-flavourToName (c, False) = colorToName c-flavourToName (c, True) = colorToName' c--flavourToColor :: Flavour -> Color-flavourToColor (c, _) = c
− src/Frequency.hs 
@@ -1,31 +0,0 @@-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 
@@ -1,116 +0,0 @@-module Geometry where--import Data.List as L---- | Game time in turns. (Placement in module Geometry is not ideal.)-type Time = Int---- | Vertical directions.-data VDir = Up | Down-  deriving (Eq, Show, Enum, Bounded)--type X = Int-type Y = Int--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 
@@ -1,58 +0,0 @@-module GeometryRnd where--import Data.List as L-import Data.Set as S--import Geometry-import Random--findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc-findLocInArea a@((y0, x0), (y1, x1)) p = do-  rx <- randomR (x0, x1)-  ry <- randomR (y0, y1)-  let loc = (ry, rx)-  if p loc then return loc else findLocInArea a p--locInArea :: Area -> Rnd Loc-locInArea a = findLocInArea a (const True)--connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X), (Y,X))] ->-                Rnd [((Y,X), (Y,X))]-connectGrid' (ny, nx) unconnected candidates acc-  | S.null candidates = return (L.map normalize acc)-  | otherwise = do-      c <- oneOf (S.toList candidates)-      -- potential new candidates:-      let ns = S.fromList $ neighbors ((0,0),(ny-1,nx-1)) c-          nu = S.delete c unconnected  -- new unconnected-          -- (new candidates, potential connections):-          (nc, ds) = S.partition (`S.member` nu) ns-      new <- if S.null ds-             then return id-             else do-                    d <- oneOf (S.toList ds)-                    return ((c,d) :)-      connectGrid' (ny,nx) nu (S.delete c (candidates `S.union` nc)) (new acc)--connectGrid :: (Y,X) -> Rnd [((Y,X), (Y,X))]-connectGrid (ny, nx) = do-  let unconnected = S.fromList [ (y, x) | x <- [0..nx-1], y <- [0..ny-1] ]-  -- candidates are neighbors that are still unconnected; we start with-  -- a random choice-  rx <- randomR (0, nx-1)-  ry <- randomR (0, ny-1)-  let candidates  = S.fromList [ (ry, rx) ]-  connectGrid' (ny, nx) unconnected candidates []--randomConnection :: (Y,X) -> Rnd ((Y,X), (Y,X))-randomConnection (ny, nx) = do-  rb  <- randomR (False, True)-  if rb-    then do-           rx  <- randomR (0, nx-2)-           ry  <- randomR (0, ny-1)-           return (normalize ((ry, rx), (ry, rx+1)))-    else do-           ry  <- randomR (0, ny-2)-           rx  <- randomR (0, nx-1)-           return (normalize ((ry, rx), (ry+1, rx)))
− src/Grammar.hs 
@@ -1,84 +0,0 @@-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 Actor-import ActorKind-import State-import ItemKind-import Effect-import Flavour--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 an actor in object position of a sentence.-objectActor :: ActorKind -> String-objectActor mk = bname mk---- | How to refer to an actor in subject position of a sentence.-subjectActor :: ActorKind -> String-subjectActor x = capitalize $ objectActor x--verbActor :: ActorKind -> String -> String-verbActor mk v = if bname mk == "you" then v else suffixS v---- | Sentences such like "The dog barks".-subjectActorVerb :: ActorKind -> String -> String-subjectActorVerb x v = subjectActor x ++ " " ++ verbActor x v--compoundVerbActor :: ActorKind -> String -> String -> String-compoundVerbActor m v p = verbActor m v ++ " " ++ p--subjectVerbIObject :: State -> Actor -> String -> Item -> String -> String-subjectVerbIObject state m v o add =-  subjectActor (akind m) ++ " " ++-  verbActor (akind m) v ++ " " ++-  objectItem state o ++ add ++ "."--subjectVerbMObject :: Actor -> String -> Actor -> String -> String-subjectVerbMObject m v o add =-  subjectActor (akind m) ++ " " ++-  verbActor (akind m) v ++ " " ++-  objectActor (akind o) ++ add ++ "."--subjCompoundVerbIObj :: State -> Actor -> String -> String ->-                        Item -> String -> String-subjCompoundVerbIObj state m v p o add =-  subjectActor (akind m) ++ " " ++-  compoundVerbActor (akind m) v p ++ " " ++-  objectItem state o ++ add ++ "."--makeObject :: Int -> (String -> String) -> String -> String-makeObject 1 adj obj = let b = adj obj-                       in  case b of-                             (c:_) | c `elem` "aeio" -> "an " ++ b-                             _                       -> "a " ++ b-makeObject n adj obj = show n ++ " " ++ adj (suffixS obj)--objectItem :: State -> Item -> String-objectItem state o =-  let ik = ikind o-      kind = ItemKind.getIK ik-      identified = L.length (jflavour kind) == 1 ||-                   ik `S.member` sdiscoveries state-      addSpace s = if s == "" then "" else " " ++ s-      eff = effectToName (jeffect kind)-      pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")"-      adj name = if identified-                 then name ++ addSpace eff ++ addSpace pwr-                 else let flavour = getFlavour (sassocs state) ik-                      in  flavourToName flavour ++ " " ++ name-  in  makeObject (icount o) adj (jname kind)
− src/HighScores.hs 
@@ -1,160 +0,0 @@-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 Level-import qualified Config---- | 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 LevelName | Camping LevelName | 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   = "              "-      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 
@@ -1,191 +0,0 @@-module Item where--import Data.Binary-import Data.Set as S-import Data.List as L-import qualified Data.IntMap as IM-import qualified Data.Map as M-import Data.Maybe-import Data.Char-import Data.Function-import Control.Monad--import Random-import ItemKind-import qualified Color-import Flavour--data Item = Item-  { ikind    :: !ItemKindId,-    ipower   :: !Int,  -- TODO: see the TODO about jpower-    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 = M.Map ItemKindId Flavour  -- TODO: rewrite and move elsewhere--type Discoveries = S.Set ItemKindId---- | Assinges flavours to item kinds. Assures no flavor is repeated,--- except for items with only one permitted flavour.-rollAssocs :: ItemKindId -> [Flavour] ->-              Rnd (Assocs, S.Set Flavour) ->-              Rnd (Assocs, S.Set Flavour)-rollAssocs key flavours rnd =-  if L.length flavours == 1-  then rnd-  else do-    (assocs, available) <- rnd-    let proper = S.fromList flavours `S.intersection` available-    flavour <- oneOf (S.toList proper)-    return (M.insert key flavour assocs, S.delete flavour available)---- | Randomly chooses flavour for all item kinds for this game.-dungeonAssocs :: Rnd Assocs-dungeonAssocs =-  liftM fst $-  M.foldWithKey rollAssocs (return (M.empty, S.fromList stdFlav)) itemFlavours--getFlavour :: Assocs -> ItemKindId -> Flavour-getFlavour assocs ik =-  let kind = ItemKind.getIK ik-  in  case jflavour kind of-        []  -> error "getFlavour"-        [f] -> f-        _:_ -> assocs M.! ik--viewItem :: ItemKindId -> 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-  ikChosen <- frequency itemFrequency-  let kind = getIK ikChosen-  count <- rollQuad lvl (jcount kind)-  if count == 0-    then newItem lvl  -- Rare item; beware of inifite loops.-    else do-      power <- rollQuad lvl (jpower kind)-      return $ Item ikChosen power (itemLetter kind) count---- | Assigns a letter to an item, for inclusion--- in the inventory of 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 
@@ -1,326 +0,0 @@-module ItemAction where--import Control.Monad-import Control.Monad.State hiding (State)-import Data.Function-import Data.List as L-import Data.Map as M-import qualified Data.IntMap as IM-import Data.Maybe-import Data.Set as S-import System.Time--import Action-import Display hiding (display)-import Dungeon-import Geometry-import Grammar-import qualified HighScores as H-import Item-import qualified ItemKind-import qualified Keys as K-import Level-import LevelState-import Message-import Actor-import ActorState-import ActorKind-import ActorAdd-import Perception-import Random-import State-import qualified Config-import qualified Save-import Terrain-import qualified Effect-import EffectAction---- Item UI code with the Action type and everything it depends on--- that is not already in Action.hs and EffectAction.hs.--- This file should not depend on Action.hs.---- | Display inventory-inventory :: Action a-inventory = do-  items <- gets (aitems . getPlayerBody)-  if L.null items-    then abortWith "Not carrying anything."-    else do-           displayItems "Carrying:" True items-           session getConfirm-           abortWith ""---- | Let the player choose any item with a given group name.--- Note that this does not guarantee an item from the group to be chosen,--- as the player can override the choice.--- TODO: There should be a datatype for item groups instead of strings--- or perhaps the functionality should be implemented differently,--- e.g., based on equipment slot, as soon as it's specified for item kinds.-getGroupItem :: [Item] ->  -- all objects in question-                String ->  -- name of the group-                String ->  -- prompt-                String ->  -- how to refer to the collection of objects-                Action (Maybe Item)-getGroupItem is groupName prompt packName =-  let choice i = groupName == ItemKind.jname (ItemKind.getIK (ikind i))-      header = capitalize $ suffixS groupName-  in  getItem prompt choice header is packName--applyGroupItem :: ActorId ->  -- actor applying the item; on current level-                  String ->   -- how the "applying" is called-                  Item ->     -- the item to be applied-                  Action ()-applyGroupItem actor verb item = do-  state <- get-  body  <- gets (getActor actor)-  per   <- currentPerception-  -- only one item consumed, even if several in inventory-  let consumed = item { icount = 1 }-      msg = subjectVerbIObject state body verb consumed ""-      loc = aloc body-  removeFromInventory actor consumed loc-  when (loc `S.member` ptvisible per) $ messageAdd msg-  itemEffectAction 5 actor actor consumed-  advanceTime actor--playerApplyGroupItem :: String -> Action ()-playerApplyGroupItem groupName = do-  is   <- gets (aitems . getPlayerBody)-  iOpt <- getGroupItem is groupName-            ("What to " ++ applyToVerb groupName ++ "?") "in inventory"-  pl   <- gets splayer-  case iOpt of-    Just i  ->-      let verb = applyToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))-      in  applyGroupItem pl verb i-    Nothing -> neverMind True--applyToVerb :: String -> String-applyToVerb "potion" = "quaff"-applyToVerb "scroll" = "read"-applyToVerb _ = "destructively apply"--quaffPotion :: Action ()-quaffPotion = playerApplyGroupItem "potion"--readScroll :: Action ()-readScroll = playerApplyGroupItem "scroll"--zapGroupItem :: ActorId ->  -- actor zapping the item; on current level-                Loc ->      -- target location for the zapping-                String ->   -- how the "zapping" is called-                Item ->     -- the item to be zapped-                Action ()-zapGroupItem source loc verb item = do-  state <- get-  sm    <- gets (getActor source)-  per   <- currentPerception-  let consumed = item { icount = 1 }-      sloc = aloc sm-      subject = if sloc `S.member` ptvisible per-                then sm-                else template (hero {bname = "somebody"}) 99 sloc-      msg = subjectVerbIObject state subject verb consumed ""-  removeFromInventory source consumed sloc-  case locToActor loc state of-    Just ta -> do-      -- The message describes the source part of the action.-      when (sloc `S.member` ptvisible per || isAHero ta) $ messageAdd msg-      -- Messages inside itemEffectAction describe the target part.-      b <- itemEffectAction 10 source ta consumed-      when (not b) $-        modify (updateLevel (dropItemsAt [consumed] loc))-    Nothing -> do-      when (sloc `S.member` ptvisible per) $ messageAdd msg-      modify (updateLevel (dropItemsAt [consumed] loc))-  advanceTime source--playerZapGroupItem :: String -> Action ()-playerZapGroupItem groupName = do-  state <- get-  is    <- gets (aitems . getPlayerBody)-  iOpt  <- getGroupItem is groupName-             ("What to " ++ zapToVerb groupName ++ "?") "in inventory"-  pl    <- gets splayer-  per   <- currentPerception-  case iOpt of-    Just i  ->-      case targetToLoc (ptvisible per) state of-        Nothing  -> abortWith "target invalid"-        Just loc ->-          -- TODO: draw digital line and see if obstacles prevent firing-          if actorReachesLoc pl loc per (Just pl)-          then let verb = zapToVerb (ItemKind.jname (ItemKind.getIK (ikind i)))-               in  zapGroupItem pl loc verb i-          else abortWith "target not reachable"-    Nothing -> neverMind True--zapToVerb :: String -> String-zapToVerb "wand" = "aim"-zapToVerb "dart" = "throw"-zapToVerb _ = "furiously zap"--aimItem :: Action ()-aimItem = playerZapGroupItem "wand"--throwItem :: Action ()-throwItem = playerZapGroupItem "dart"---- | Drop a single item.--- TODO: allow dropping a given number of identical items.-dropItem :: Action ()-dropItem = do-  pl    <- gets splayer-  state <- get-  pbody <- gets getPlayerBody-  ploc  <- gets (aloc . getPlayerBody)-  items <- gets (aitems . getPlayerBody)-  iOpt  <- getAnyItem "What to drop?" items "inventory"-  case iOpt of-    Just stack -> do-      let i = stack { icount = 1 }-      removeOnlyFromInventory pl i (aloc pbody)-      messageAdd (subjectVerbIObject state pbody "drop" i "")-      modify (updateLevel (dropItemsAt [i] ploc))-    Nothing -> neverMind True-  playerAdvanceTime---- TODO: this is a hack for dropItem, because removeFromInventory--- makes it impossible to drop items if the floor not empty.-removeOnlyFromInventory :: ActorId -> Item -> Loc -> Action ()-removeOnlyFromInventory actor i loc = do-  updateAnyActor actor (\ m -> m { aitems = removeItemByLetter i (aitems m) })---- | Remove given item from an actor's inventory or floor.--- TODO: this is subtly wrong: if identical items are on the floor and in--- inventory, the floor one will be chosen, regardless of player intention.--- TODO: right now it ugly hacks (with the ploc) around removing items--- of dead heros/monsters. The subtle incorrectness helps here a lot,--- because items of dead heroes land on the floor, so we use them up--- in inventory, but remove them after use from the floor.-removeFromInventory :: ActorId -> Item -> Loc -> Action ()-removeFromInventory actor i loc = do-  b <- removeFromLoc i loc-  when (not b) $-    updateAnyActor actor (\ m -> m { aitems = removeItemByLetter i (aitems m) })---- | Remove given item from the given location. Tell if successful.-removeFromLoc :: Item -> Loc -> Action Bool-removeFromLoc i loc = do-  lmap  <- gets (lmap . slevel)-  if not $ L.any (equalItemIdentity i) (titems (lmap `at` loc))-    then return False-    else-      modify (updateLevel (updateLMap adj)) >>-      return True-        where-          adj = M.adjust (\ (t, rt) -> (remove t, rt)) loc-          remove t = t { titems = removeItemByIdentity i (titems t) }--actorPickupItem :: ActorId -> Action ()-actorPickupItem actor = do-  state <- get-  pl    <- gets splayer-  per   <- currentPerception-  lmap  <- gets (lmap . slevel)-  body  <- gets (getActor actor)-  let loc       = aloc body-      t         = lmap `at` loc -- the map tile in question-      perceived = loc `S.member` ptvisible per-      isPlayer  = actor == pl-  -- check if something is here to pick up-  case titems t of-    []   -> abortIfWith isPlayer "nothing here"-    i:rs -> -- pick up first item; TODO: let player select item;not for monsters-      case assignLetter (iletter i) (aletter body) (aitems body) of-        Just l -> do-          let (ni, nitems) = joinItem (i { iletter = Just l }) (aitems body)-          -- message depends on who picks up and if a hero can perceive it-          if isPlayer-            then messageAdd (letterLabel (iletter ni) ++ objectItem state ni)-            else when perceived $-                   messageAdd $ subjCompoundVerbIObj state body "pick" "up" i ""-          assertTrue $ removeFromLoc i loc-          -- add item to actor's inventory:-          updateAnyActor actor $ \ m ->-            m { aitems = nitems, aletter = maxLetter l (aletter body) }-        Nothing -> abortIfWith isPlayer "cannot carry any more"-  advanceTime actor--pickupItem :: Action ()-pickupItem = do-  pl <- gets splayer-  actorPickupItem pl---- TODO: I think that player handlers should be wrappers--- around more general actor handlers, but--- the actor handlers should be performing--- specific actions, i.e., already specify the item to be--- picked up. It doesn't make sense to invoke dialogues--- for arbitrary actors, and most likely the--- decision for a monster is based on perceiving--- a particular item to be present, so it's already--- known. In actor handlers we should make sure--- that messages are printed to the player only if the--- hero can perceive the action.--- Perhaps this means half of this code should be split and moved--- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed.---- | Let the player choose any item from a list of items.--- TODO: you can drop an item on the floor, which works correctly,--- but is weird and useless.-getAnyItem :: String ->  -- prompt-              [Item] ->  -- all objects in question-              String ->  -- how to refer to the collection of objects-              Action (Maybe Item)-getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn---- | Let the player choose a single item from a list of items.-getItem :: String ->              -- prompt message-           (Item -> Bool) ->      -- which items to consider suitable-           String ->              -- how to describe suitable objects-           [Item] ->              -- all objects in question-           String ->              -- how to refer to the collection of objects-           Action (Maybe Item)-getItem prompt p ptext is0 isn = do-  lmap  <- gets (lmap . slevel)-  body  <- gets getPlayerBody-  let loc       = aloc body-      t         = lmap `at` loc -- the map tile in question-      tis       = titems t-      floorMsg  = if L.null tis then "" else " -,"-      is = L.filter p is0-      choice = if L.null is-               then "[*," ++ floorMsg ++ " ESC]"-               else let r = letterRange (concatMap (maybeToList . iletter) is)-                    in  "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]"-      interact = do-        when (L.null is0 && L.null tis) $-          abortWith "Not carrying anything."-        messageReset (prompt ++ " " ++ choice)-        display-        session nextCommand >>= perform-      perform command = do-        messageClear-        case command of-          K.Char '?' -> do-            -- filter for supposedly suitable objects-            b <- displayItems (ptext ++ " " ++ isn) True is-            if b then session (getOptionalConfirm (const interact) perform)-                 else interact-          K.Char '*' -> do-            -- show all objects-            b <- displayItems ("Objects " ++ isn) True is0-            if b then session (getOptionalConfirm (const interact) perform)-                 else interact-          K.Char '-' ->-            case tis of-              []   -> return Nothing-              i:rs -> -- use first item; TODO: let player select item-                      return $ Just i-          K.Char l   ->-            return (find (\ i -> maybe False (== l) (iletter i)) is0)-          K.Return   ->  -- TODO: i should be the first displayed (except $)-            return (case is of [] -> Nothing ; i : _ -> Just i)-          _          -> return Nothing-  interact
− src/ItemKind.hs 
@@ -1,189 +0,0 @@-module ItemKind-  (ItemKind(..), ItemKindId, getIK, itemFrequency, itemFlavours, swordKindId)-  where--import Data.Binary-import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.IntMap as IM-import Control.Monad-import Data.Maybe--import Color-import Effect-import Random-import Flavour---- TODO: jpower is out of place here. It doesn't make sense for all items,--- and will mean different things for different items. Perhaps it should--- be part of the Effect, but then we have to be careful to distinguish--- parts of the Effect that are rolled on item creation and those rolled--- at each use (e.g., sword magical +damage vs. sword damage dice).--- Another thing to keep in minds is that jpower will heavily determine--- the value of the item for shops, treasure chests, artifact set rebalancing,--- etc., so if we make jpower complex, the value computation gets complex too.-data ItemKind = ItemKind-  { jsymbol  :: !Char      -- ^ map symbol-  , jflavour :: [Flavour]  -- ^ possible flavours-  , jname    :: String     -- ^ item group name-  , jeffect  :: Effect     -- ^ the effect when activated-  , jcount   :: RollQuad   -- ^ created in that quantify-  , jfreq    :: !Int       -- ^ created that often-  , jpower   :: RollQuad   -- ^ created with that power-  }-  deriving (Show, Eq, Ord)--newtype ItemKindId = ItemKindId Int-  deriving (Show, Eq, Ord)--instance Binary ItemKindId where-  put (ItemKindId i) = put i-  get = liftM ItemKindId get--itemAssocs :: [(Int, ItemKind)]-itemAssocs = L.zip [0..] loot--itemContent :: IM.IntMap ItemKind-itemContent = IM.fromDistinctAscList itemAssocs--getIK :: ItemKindId -> ItemKind-getIK (ItemKindId i) = itemContent IM.! i--itemFrequency :: Frequency ItemKindId-itemFrequency = Frequency [(jfreq ik, ItemKindId i) | (i, ik) <- itemAssocs]--itemFlavours :: M.Map ItemKindId [Flavour]-itemFlavours =-  M.fromDistinctAscList [(ItemKindId i, jflavour ik) | (i, ik) <- itemAssocs]--swordKindId :: ItemKindId-swordKindId = ItemKindId $ fromJust $ L.elemIndex sword loot--loot :: [ItemKind]-loot =-  [amulet,-   dart,-   gem1, gem2, gem3, gem4,-   gold,-   potion1, potion2, potion3,-   ring,-   scroll1, scroll2,-   sword,-   wand]---- rollQuad (a, b, x, y) = a * d b + (lvl * x * d y) / 10--amulet, dart, gem, gem1, gem2, gem3, gem4, gold :: ItemKind-potion, potion1, potion2, potion3 :: ItemKind-ring, scroll, scroll1, scroll2, sword, wand :: ItemKind-amulet = ItemKind-  { jsymbol  = '"'-  , jflavour = [(BrGreen, True)]-  , jname    = "amulet"-  , jeffect  = Regneration-  , jcount   = intToQuad 1-  , jfreq    = 10-  , jpower   = (2, 1, 2, 2)-  }-dart = ItemKind-  { jsymbol  = ')'-  , jflavour = [(Yellow, False)]-  , jname    = "dart"-  , jeffect  = Wound (1, 1)-  , jcount   = (3, 3, 0, 0)-  , jfreq    = 30-  , jpower   = intToQuad 0-  }-gem = ItemKind-  { jsymbol  = '*'-  , jflavour = zipPlain brightCol  -- natural, so not fancy-  , jname    = "gem"-  , jeffect  = NoEffect-  , jcount   = intToQuad 0-  , jfreq    = 20  -- x4, but rare on shallow levels-  , jpower   = intToQuad 0-  }-gem1 = gem-  { jcount   = (1, 1, 0, 0)  -- appears on lvl 1-  }-gem2 = gem-  { jcount   = (0, 0, 2, 1)  -- appears on lvl 5, doubled on lvl 10-  }-gem3 = gem-  { jcount   = (0, 0, 1, 1)  -- appears on lvl 10-  }-gem4 = gem-  { jcount   = (0, 0, 1, 1)  -- appears on lvl 10-  }-gold = ItemKind-  { jsymbol  = '$'-  , jflavour = [(BrYellow, False)]-  , jname    = "gold piece"-  , jeffect  = NoEffect-  , jcount   = (0, 0, 10, 10)-  , jfreq    = 80-  , jpower   = intToQuad 0-  }-potion = ItemKind-  { jsymbol  = '!'-  , jflavour = zipFancy stdCol-  , jname    = "potion"-  , jeffect  = NoEffect-  , jcount   = intToQuad 1-  , jfreq    = 10-  , jpower   = intToQuad 0-  }-potion1 = potion-  { jeffect  = ApplyPerfume-  }-potion2 = potion-  { jeffect  = Heal-  , jpower   = (10, 1, 0, 0)-  }-potion3 = potion-  { jeffect  = Wound (0, 0)-  , jpower   = (10, 1, 0, 0)-  }-ring = ItemKind-  { jsymbol  = '='-  , jflavour = [(White, False)]-  , jname    = "ring"-  , jeffect  = Searching-  , jcount   = intToQuad 1-  , jfreq    = 10-  , jpower   = (1, 1, 2, 2)-  }-scroll = ItemKind-  { jsymbol  = '?'-  , jflavour = zipFancy darkCol  -- arcane and old-  , jname    = "scroll"-  , jeffect  = NoEffect-  , jcount   = intToQuad 1-  , jfreq    = 10-  , jpower   = intToQuad 0-  }-scroll1 = scroll-  { jeffect  = SummonFriend-  , jfreq    = 20-  }-scroll2 = scroll-  { jeffect  = SummonEnemy-  }-sword = ItemKind-  { jsymbol  = ')'-  , jflavour = [(BrCyan, False)]-  , jname    = "sword"-  , jeffect  = Wound (3, 1)-  , jcount   = intToQuad 1-  , jfreq    = 60-  , jpower   = (1, 2, 4, 2)-  }-wand = ItemKind-  { jsymbol  = '/'-  , jflavour = [(BrRed, True)]-  , jname    = "wand"-  , jeffect  = Dominate-  , jcount   = intToQuad 1-  , jfreq    = 10-  , jpower   = intToQuad 0-  }
− src/Keybindings.hs 
@@ -1,41 +0,0 @@-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 
@@ -1,156 +0,0 @@-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 
@@ -1,215 +0,0 @@-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 Actor-import Item-import Random-import qualified Terrain---- | Names of the dungeon levels are represented using a--- custom data structure.-data LevelName = LambdaCave Int | Exit-  deriving (Show, Eq, Ord)--instance Binary LevelName where-  put (LambdaCave n) = put n-  get = liftM LambdaCave get---- | Provide a textual description of a level name.-levelName :: LevelName -> String-levelName (LambdaCave n) = "The Lambda Cave " ++ show n---- | Gives the numeric representation of the level's depth.-levelNumber :: LevelName -> Int-levelNumber (LambdaCave n) = n---- | A dungeon location is a level together with a location on that level.-type DungeonLoc = (LevelName, Loc)--type Party = IM.IntMap Actor--data Level = Level-  { lname     :: LevelName,-    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)-type SMap = Map (Y,X) Time--data Tile = Tile-              { tterrain :: Terrain.Terrain DungeonLoc,-                titems   :: [Item] }-  deriving Show--instance Binary Tile where-  put (Tile t is) = put t >> put is-  get = liftM2 Tile get get--at         l p = fst (findWithDefault (unknown, unknown) p l)-rememberAt l p = snd (findWithDefault (unknown, unknown) p l)--unknown :: Tile-unknown = 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 t of-    Tile d@(Terrain.Door hv o) _ | secret o -> True-    _ ->-      Terrain.isWall (tterrain t) ||-      Terrain.isRock (tterrain t) ||-      Terrain.isUnknown (tterrain t)--secret :: Maybe Int -> Bool-secret (Just n) | n /= 0 = True-secret _ = False--isUnknown :: Tile -> Bool-isUnknown = Terrain.isUnknown . tterrain--toOpen :: Bool -> Maybe Int-toOpen True = Nothing-toOpen False = Just 0---- | allows moves and vision-open :: Tile -> Bool-open = Terrain.isOpen . tterrain---- | is lighted on its own-light :: Tile -> Bool-light = Terrain.isAlight . tterrain---- | can be lighted by sourrounding tiles-reflects :: Tile -> Bool-reflects = Terrain.reflects . tterrain---- | Passive tiles reflect light from some other (usually adjacent)--- positions. This function returns the offsets from which light is--- reflected. Not all passively lighted tiles reflect from all directions.--- Walls, for instance, cannot usually be seen from the outside.-passive :: Tile -> [Dir]-passive = Terrain.passive . tterrain---- | Perceptible is similar to passive, but describes which tiles can--- be seen from which adjacent fields in the dark.-perceptible :: Tile -> [Dir]-perceptible = Terrain.perceptible . tterrain---- Checks for the presence of actors. Does *not* check if the tile is open.-unoccupied :: [Actor] -> Loc -> Bool-unoccupied actors loc =-  all (\ body -> aloc body /= loc) actors---- check whether one location is accessible from the other--- precondition: the two locations are next to each other--- currently only implements that doors aren't accessible diagonally,--- and that the target location has to be open-accessible :: LMap -> Loc -> Loc -> Bool-accessible lmap source target =-  let dir = shift source (neg target)-      src = lmap `at` source-      tgt = lmap `at` target-  in  open tgt &&-      (not (diagonal dir) ||-       case (tterrain src, tterrain tgt) of-         (Terrain.Door {}, _)  -> False-         (_, Terrain.Door {})  -> False-         _             -> True)---- check whether the location contains a door of secrecy level lower than k-openable :: Int -> LMap -> Loc -> Bool-openable k lmap target =-  let tgt = lmap `at` target-  in  case tterrain tgt of-        Terrain.Door _ (Just n) -> n < k-        _               -> False--findLoc :: Level -> (Loc -> 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 -> Bool) ->  -- loop until satisfied-              (Loc -> 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 { titems = joinItems items (titems t) }-      ntRemember = lmap `rememberAt` loc-  in  updateLMap (M.insert loc (nt, ntRemember)) lvl
− src/LevelState.hs 
@@ -1,34 +0,0 @@-module LevelState where--import qualified Color-import Geometry-import Level-import State-import Item-import Grammar-import qualified Terrain--viewTile :: Bool -> Tile -> Assocs -> (Char, Color.Color)-viewTile b (Tile t [])    a = Terrain.viewTerrain 0 b t-viewTile b (Tile t (i:_)) a = Item.viewItem (ikind i) a---- | Produces a textual description of the terrain and items at an already--- explored location. Mute for unknown locations.--- The "detailed" variant is for use in the targeting mode.-lookAt :: Bool -> Bool -> State -> LMap -> Loc -> String -> String-lookAt detailed canSee s lmap loc msg-  | detailed  =-    Terrain.lookTerrain (tterrain (lmap `rememberAt` loc)) ++ " " ++ msg ++ isd-  | otherwise = msg ++ isd-  where-    is  = titems (lmap `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 
@@ -1,45 +0,0 @@-module Main where--import System.Directory-import Data.Map as M--import Action-import State-import DungeonState-import qualified Display-import Random-import qualified Save-import Turn-import qualified Config-import ActorAdd-import Item-import qualified Keys as K--main :: IO ()-main = Display.startup start---- | Either restore a saved game, or setup a new game.-start :: Display.InternalSession -> IO ()-start internalSession = do-  config <- Config.config-  let section = Config.getItems config "macros"-      !macros = K.macroKey section-      session = (internalSession, macros)-  -- check if we have a savegame-  f <- Save.file config-  b <- doesFileExist f-  restored <- if b-              then do-                     Display.displayBlankConfirm session "Restoring save game"-                     Save.restoreGame config-              else return $ Right "Welcome to LambdaHack!"  -- new game-  case restored of-    Right msg  -> do-      (ploc, lvl, dng) <- rndToIO $ generate config-      assocs <- rndToIO $ dungeonAssocs-      let defState = defaultState dng lvl-          state = defState { sconfig = config, sassocs = assocs }-          hstate = initialHeroes ploc state-      handlerToIO session hstate msg handle-    Left state ->-      handlerToIO session state "Welcome back to LambdaHack." handle
− src/Message.hs 
@@ -1,32 +0,0 @@-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/Multiline.hs 
@@ -1,8 +0,0 @@-module Multiline (multiline) where--import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Quote as TQ---- | Used to handle multiline verbatim string expressions, see ConfigDefault.hs.-multiline :: TQ.QuasiQuoter-multiline  = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined
− src/Perception.hs 
@@ -1,144 +0,0 @@-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 Actor-import ActorState-import qualified ActorKind-import FOV-import qualified Config--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 (TODO. But perhaps only non-blind--- monsters should be controllable?). Right now, the field is used only--- for player-controlled monsters on the current level.-data Perceptions =-  Perceptions { pplayer :: Maybe Perception,-                pheroes :: IM.IntMap Perception,-                ptotal  :: Perception }--ptreachable, ptvisible :: Perceptions -> S.Set Loc-ptreachable = preachable . ptotal-ptvisible   = pvisible . ptotal--actorPrLoc :: (Perception -> S.Set Loc) ->-              ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool-actorPrLoc projection actor loc per pl =-  let tryHero = case actor of-                  AMonster _ -> Nothing-                  AHero i -> do-                    hper <- IM.lookup i (pheroes per)-                    return $ loc `S.member` (projection hper)-      tryPl   = do  -- the case for a monster under player control-                  guard $ Just actor == pl-                  pper <- pplayer per-                  return $ loc `S.member` projection pper-      tryAny  = tryHero `mplus` tryPl-  in  fromMaybe False tryAny  -- assume not visible, if no perception found--actorSeesLoc    :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool-actorSeesLoc    = actorPrLoc pvisible--actorReachesLoc :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool-actorReachesLoc = actorPrLoc preachable---- Not quite correct if FOV not symmetric (Shadow).-actorReachesActor :: ActorId -> ActorId -> Loc -> Loc-                     -> Perceptions -> Maybe ActorId-                     -> Bool-actorReachesActor actor1 actor2 loc1 loc2 per pl =-  actorReachesLoc actor1 loc2 per pl ||-  actorReachesLoc actor2 loc1 per pl--perception_ :: State -> Perceptions-perception_ state@(State { splayer = pl,-                           slevel   = Level { lmap = lmap, lheroes = hs },-                           sconfig  = config,-                           ssensory = sensory }) =-  let mode   = Config.get config "engine" "fovMode"-      radius = Config.get config "engine" "fovRadius"-      fovMode m = if not $ ActorKind.bsight (akind m) then Blind else-        -- terrible, temporary hack-        case 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) (aloc m) lmap-             else Nothing-      pers = IM.map (\ h -> perception (fovMode h) (aloc h) lmap) hs-      lpers = maybeToList pper ++ IM.elems pers-      reachable = S.unions (L.map preachable lpers)-      visible = S.unions (L.map pvisible lpers)-  in  Perceptions { pplayer = pper,-                    pheroes = pers,-                    ptotal = Perception reachable visible }--perception :: FovMode -> Loc -> LMap -> Perception-perception fovMode ploc lmap =-  let-    -- This part is simple. "reachable" contains everything that is on an-    -- unblocked path from the hero position.-    reachable  = fullscan fovMode ploc lmap-    -- In "actVisible", we store the locations that have light and are-    -- reachable. Furthermore, the hero location itself is always visible.-    litVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable-    actVisible = S.insert ploc litVisible-    srnd       = S.fromList $ surroundings ploc-    -- In "dirVisible", we store locations in the surroundings that are-    -- perceptible from the current position.-    dirVisible = S.filter (\ loc -> let p = perceptible (lmap `at` loc) :: [Dir]-                                    in  any (\ d -> shift loc d == ploc) p)-                          srnd-    ownVisible = S.union actVisible dirVisible-    -- Something is "pasVisible" if it is reachable passively visible from an-    -- "actVisible" location, *or* if it is in the surroundings and passively-    -- visible from a "dirVisible" location. (This is complicated, and I'd-    -- like to simplify it, but for now, it seems to at least do what I-    -- want.)-    pasVisible = S.filter (\ loc -> let p = passive (lmap `at` loc)-                                        dp = S.member loc srnd-                                        s = if dp then ownVisible else actVisible-                                    in  any (\ d -> S.member (shift loc d) s) p)-                          reachable-    visible = S.unions [pasVisible, actVisible, dirVisible]-    -- A simpler way to make walls of lit rooms visible, at the cost of making-    -- them reflect light from all sides, also from corridors.-    -- Can be hacked around by checking for corridors in the condition below.-    -- The version in the comment assumes hero light has diameter 3, not 1,-    -- which looks a bit differently in dark rooms, revealing more walls.-    openSurroundings = S.filter (\ loc -> open (lmap `at` loc)) srnd-    openVisible = S.union actVisible openSurroundings-    simpleVisible =-      S.filter-        (\ loc -> S.member loc openVisible-                  || (reflects (lmap `at` loc)-                      && L.any-                           (\ l -> S.member l actVisible{-openVisible-})-                           (surroundings loc))-        ) (S.insert ploc reachable)-  in-    case fovMode of-      Shadow -> Perception reachable visible-      Blind  -> Perception reachable visible-      _      -> Perception reachable simpleVisible
− src/Random.hs 
@@ -1,100 +0,0 @@-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 
@@ -1,52 +0,0 @@-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 
@@ -1,177 +0,0 @@-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 Actor-import Geometry-import Level-import Dungeon-import Item-import Message-import qualified ItemKind---- | The 'State' contains all the game state that has to be saved.--- In practice, we maintain extra state, but that state is state--- accumulated during a turn or relevant only to the current session.--- TODO: consider changing slevel to LevelName, removing the lname field--- and not removing the current level from the dungeon.-data State = State-  { splayer      :: ActorId,      -- ^ represents the player-controlled actor-    scursor      :: Cursor,       -- ^ cursor location and level to return to-    shistory     :: [Message],-    ssensory     :: SensoryMode,-    sdisplay     :: DisplayMode,-    stime        :: Time,-    sassocs      :: Assocs,       -- ^ how every item appears-    sdiscoveries :: Discoveries,  -- ^ items (kinds) that have been discovered-    sdungeon     :: Dungeon,      -- ^ all but the current dungeon level-    slevel       :: Level,-    scounter     :: (Int, Int),   -- ^ stores next hero index and monster index-    sconfig      :: Config.CP-  }-  deriving Show--data Cursor = Cursor-  { ctargeting :: Bool,       -- ^ are we in targeting mode?-    clocLn     :: LevelName,  -- ^ cursor level-    clocation  :: Loc,        -- ^ cursor coordinates-    creturnLn  :: LevelName   -- ^ the level current player resides on-  }-  deriving Show--defaultState :: Dungeon -> Level -> State-defaultState dng lvl =-  State-    (AHero 0)-    (Cursor False (LambdaCave (-1)) (-1, -1) (lname lvl))-    []-    Implicit Normal-    0-    M.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-  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 
@@ -1,50 +0,0 @@-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 
@@ -1,185 +0,0 @@-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 Actor-import ActorState-import ActorKind-import Random-import Perception-import Strategy-import State-import Action-import Actions-import ItemAction-import qualified ItemKind-import Item-import qualified Effect---- import Debug.Trace--strategy :: ActorId -> State -> Perceptions -> Strategy (Action ())-strategy actor-         oldState@(State { scursor = cursor,-                           splayer = pl,-                           stime   = time,-                           slevel  = Level { lname = ln,-                                             lsmell = nsmap,-                                             lmap = lmap } })-         per =---  trace (show time ++ ": " ++ show actor) $-    strategy-  where-    Actor { akind = mk, aloc = me, adir = adir,-            atarget = tgt, aitems = items } =-      getActor actor oldState-    delState = deleteActor actor oldState-    enemyVisible a l =-      -- We assume monster sight is infravision, so light has no significance.-      bsight mk && actorReachesActor a actor l me per Nothing ||-      -- Any enemy is visible if adjacent (e. g., a monster player).-      memActor a delState && adjacent me l-    -- If no heroes on the level, monsters go at each other. TODO: let them-    -- earn XP by killing each other to make this dangerous to the player.-    hs = L.map (\ (i, m) -> (AHero i, aloc m)) $-         IM.assocs $ lheroes $ slevel delState-    ms = L.map (\ (i, m) -> (AMonster i, aloc m)) $-         IM.assocs $ lmonsters $ slevel delState-    -- Below, "foe" is the hero (or a monster, or loc) chased by the actor.-    (newTgt, floc) =-      case tgt of-        TEnemy a ll | focusedMonster ->-          case findActorAnyLevel a delState of-            Just (_, m) ->-              let l = aloc m-              in  if enemyVisible a l-                  then (TEnemy a l, Just l)-                  else if isJust (snd closest) || me == ll-                       then closest         -- prefer visible foes-                       else (tgt, Just ll)  -- last known location of enemy-            Nothing -> closest  -- enemy dead, monsters can feel it-        TLoc loc -> if me == loc-                    then closest-                    else (tgt, Just loc)  -- ignore everything and go to loc-        _  -> closest-    closest =-      let hsAndTraitor = if isAMonster pl-                         then (pl, aloc $ getPlayerBody delState) : hs-                         else hs-          foes = if L.null hsAndTraitor then ms else hsAndTraitor-          -- We assume monster sight is infravision, so light has no effect.-          foeVisible = L.filter (\ (a, l) -> enemyVisible a l) foes-          foeDist = L.map (\ (a, l) -> (distance (me, l), l, a)) foeVisible-      in  case foeDist of-            [] -> (TCursor, Nothing)-            _  -> let (_, l, a) = L.minimum foeDist-                  in  (TEnemy a l, Just l)-    onlyFoe        = onlyMoves (maybe (const False) (==) floc) me-    towardsFoe     = case floc of-                       Nothing -> const mzero-                       Just loc ->-                         let foeDir = towards (me, loc)-                         in  only (\ x -> distance (foeDir, x) <= 1)-    lootHere       = (\ x -> not $ L.null $ titems $ lmap `at` x)-    onlyLoot       = onlyMoves lootHere me-    exitHere       = (\ x -> let t = lmap `at` x in open t && reflects t)-    onlyExit       = onlyMoves exitHere me-    onlyKeepsDir k = only (\ x -> maybe True (\ d -> distance (d, x) <= k) adir)-    onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) adir)-    onlyNoMs       = onlyMoves (unoccupied (levelMonsterList delState)) me-    -- Monsters don't see doors more secret than that. Enforced when actually-    -- opening doors, too, so that monsters don't cheat. TODO: remove the code-    -- duplication, though.-    openPower      = case strongestItem items "ring" of-                       Just i  -> biq mk + ipower i-                       Nothing -> biq mk-    openableHere   = openable openPower lmap-    onlyOpenable   = onlyMoves openableHere me-    accessibleHere = accessible lmap me-    onlySensible   = onlyMoves (\ l -> accessibleHere l || openableHere l) me-    focusedMonster = biq mk > 10-    smells         =-      L.map fst $-      L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $-      L.filter (\ (_, s) -> s > 0) $-      L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves-    fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d--    strategy =-      fromDir True (onlyFoe moveFreely)-      .| isJust floc .=> liftFrequency (msum freqs)-      .| lootHere me .=> actionPickup-      .| fromDir True moveAround-    actionPickup = return $ actorPickupItem actor-    tis = titems $ lmap `at` me-    freqs = [applyFreq items 1, applyFreq tis 2,-             throwFreq items 2, throwFreq tis 5, towardsFreq]-    applyFreq is multi = Frequency-      [ (benefit * multi, actionApply (ItemKind.jname ik) i)-      | i <- is,-        let ik = ItemKind.getIK (ikind i),-        let benefit =-              (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),-        benefit > 0,-        bsight mk || not (ItemKind.jname ik == "scroll")]-    actionApply groupName item =-      applyGroupItem actor (applyToVerb groupName) item-    throwFreq is multi = if not $ bsight mk then mzero else Frequency-      [ (benefit * multi, actionThrow (ItemKind.jname ik) i)-      | i <- is,-        let ik = ItemKind.getIK (ikind i),-        let benefit =-              - (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik),-        benefit > 0,-        -- Wasting swords would be too cruel to the player.-        not (ItemKind.jname ik == "sword")]-    actionThrow groupName item =-      zapGroupItem actor (fromJust floc) (zapToVerb groupName) item-    towardsFreq =-      let freqs = runStrategy $ fromDir False moveTowards-      in  if bsight mk && not (L.null freqs)-          then scale 30 $ head freqs-          else mzero-    moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely)-    moveAround =-      onlySensible $-        (if bsight mk then onlyNoMs else id) $-          bsmell mk .=> L.foldr (.|) reject (L.map return smells)-          .| onlyOpenable moveFreely-          .| moveFreely-    moveFreely = onlyLoot moveRandomly-                 .| onlyExit (onlyKeepsDir 2 moveRandomly)-                 .| biq mk > 15 .=> onlyKeepsDir 0 moveRandomly-                 .| biq mk > 10 .=> onlyKeepsDir 1 moveRandomly-                 .| biq mk > 5  .=> onlyKeepsDir 2 moveRandomly-                 .| onlyKeepsDir_9 moveRandomly-                 .| moveRandomly--dirToAction :: ActorId -> Target -> Bool -> Dir -> Action ()-dirToAction actor tgt allowAttacks dir =-  assert (dir /= (0,0)) $ do-  -- set new direction-  updateAnyActor actor $ \ m -> m { adir = Just dir, atarget = tgt }-  -- perform action-  tryWith (advanceTime actor) $-    -- if the following action aborts, we just advance the time and continue-    -- TODO: ensure time is taken for other aborted actions in this file-    moveOrAttack allowAttacks True actor dir--onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir-onlyMoves p l = only (\ x -> p (l `shift` x))--moveRandomly :: Strategy Dir-moveRandomly = liftFrequency $ uniform moves--wait :: ActorId -> Strategy (Action ())-wait actor = return $ advanceTime actor
− src/Terrain.hs 
@@ -1,234 +0,0 @@-module Terrain where--import Control.Monad--import Data.Binary-import Data.Maybe--import qualified Color-import Geometry---- TODO: let terrain kinds be defined in a config file. Group them--- and assign frequency so that they can be used for dungeon building.--- Goal: Have 2 tileset configs, one small, Rouge/Nethack style,--- the other big, Angband/UFO style. The problem is that the Rogue walls--- are very complex, while Angband style is much simpler, and I love KISS. Hmmm.--data Terrain a =-    Rock-  | Opening Pos-  | Floor DL-  | Unknown-  | Corridor-  | Wall Pos-  | Stairs DL VDir (Maybe a)-  | Door Pos (Maybe Int)  -- Nothing: open, Just 0: closed, otherwise secret-  deriving Show--instance Binary VDir where-  put = putWord8 . fromIntegral . fromEnum-  get = liftM (toEnum . fromIntegral) getWord8--instance Binary a => Binary (Terrain a) where-  put Rock            = putWord8 0-  put (Opening p)     = putWord8 1 >> put p-  put (Floor dl)      = putWord8 2 >> put dl-  put Unknown         = putWord8 3-  put Corridor        = putWord8 4-  put (Wall p)        = putWord8 5 >> put p-  put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n-  put (Door p o)      = putWord8 7 >> put p >> put o-  get = do-          tag <- getWord8-          case tag of-            0 -> return Rock-            1 -> liftM Opening get-            2 -> liftM Floor get-            3 -> return Unknown-            4 -> return Corridor-            5 -> liftM Wall get-            6 -> liftM3 Stairs get get get-            7 -> liftM2 Door get get-            _ -> fail "no parse (Terrain)"--instance Eq a => Eq (Terrain a) where-  Rock == Rock = True-  Opening d == Opening d' = d == d'-  Floor l == Floor l' = l == l'-  Unknown == Unknown = True-  Corridor == Corridor = True-  Wall p == Wall p' = p == p'-  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'-  Door p o == Door p' o' = p == p' && o == o'-  _ == _ = False--data DL = Dark | Light-  deriving (Eq, Show, Enum, Bounded)--instance Binary DL where-  put = putWord8 . fromIntegral . fromEnum-  get = liftM (toEnum . fromIntegral) getWord8---- | All the wall kinds that are possible:------     * 'UL': upper left------     * 'U': upper------     * 'UR': upper right------     * 'L': left------     * 'R': right------     * 'DL': lower left------     * 'D': lower------     * 'DR': lower right------     * 'O': a pillar------ I am tempted to add even more (T-pieces and crossings),--- but currently, we don't need them.-data Pos = UL | U | UR | L | R | DL | D | DR | O-  deriving (Eq, Show, Enum, Bounded)--instance Binary Pos where-  put = putWord8 . fromIntegral . fromEnum-  get = liftM (toEnum . fromIntegral) getWord8--isFloor :: Terrain a -> Bool-isFloor (Floor _) = True-isFloor _         = False--isWall :: Terrain a -> Bool-isWall (Wall _) = True-isWall _        = False--isRock :: Terrain a -> Bool-isRock Rock = True-isRock _    = False--isUnknown :: Terrain a -> Bool-isUnknown Unknown = True-isUnknown _       = False---- | allows moves and vision-isOpen :: Terrain a -> Bool-isOpen (Floor {})    = True-isOpen (Opening {}) = True-isOpen (Door _ o)   = isNothing o-isOpen Corridor     = True-isOpen (Stairs {})  = True-isOpen _            = False--fromDL :: DL -> Bool-fromDL Dark = False-fromDL Light = True--toDL :: Bool -> DL-toDL False = Dark-toDL True  = Light---- | is lighted on its own-isAlight :: Terrain a -> Bool-isAlight (Floor l)      = fromDL l-isAlight (Stairs l _ _) = fromDL l-isAlight _              = False---- | can be lighted by sourrounding tiles-reflects :: Terrain a -> Bool-reflects (Opening _) = True-reflects (Wall _)    = True-reflects (Door _ _)  = True-reflects _           = False---- | Maps wall kinds to lists of expected floor positions.-posToDir :: Pos -> [Dir]-posToDir UL = [downright]-posToDir U  = [down]-posToDir UR = [downleft]-posToDir L  = [right]-posToDir R  = [left]-posToDir DL = [upright]-posToDir D  = [up]-posToDir DR = [upleft]-posToDir O  = moves---- | Passive tiles reflect light from some other (usually adjacent)--- positions. This function returns the offsets from which light is--- reflected. Not all passively lighted tiles reflect from all directions.--- Walls, for instance, cannot usually be seen from the outside.-passive :: Terrain a -> [Dir]-passive (Wall p)          = posToDir p-passive (Opening _)       = moves-passive (Door p Nothing)  = moves-passive (Door p (Just 0)) = moves      -- doors can be seen from all sides-passive (Door p (Just n)) = posToDir p -- secret doors are like walls-passive (Stairs _ _ _)    = moves-passive _                 = []---- | Perceptible is similar to passive, but describes which tiles can--- be seen from which adjacent fields in the dark.-perceptible :: Terrain a -> [Dir]-perceptible Rock = []-perceptible p = case passive p of-                 [] -> moves-                 ds -> ds---- | Produces a textual description for terrain, used if no objects--- are present.-lookTerrain :: Terrain a -> String-lookTerrain (Floor _)          = "Floor."-lookTerrain Corridor           = "Corridor."-lookTerrain (Opening _)        = "An opening."-lookTerrain (Stairs _ Up _)    = "A staircase up."-lookTerrain (Stairs _ Down _)  = "A staircase down."-lookTerrain (Door _ Nothing)   = "An open door."-lookTerrain (Door _ (Just 0))  = "A closed door."-lookTerrain (Door _ (Just _))  = "A wall."  -- secret-lookTerrain (Wall _ )          = "A wall."-lookTerrain _                  = ""---- | The parameter "n" is the level of evolution:------ 0: final--- 1: stairs added--- 2: doors added--- 3: corridors and openings added--- 4: only rooms------ The Bool indicates whether the loc is currently visible.-viewTerrain :: Int -> Bool -> Terrain a -> (Char, Color.Color)-viewTerrain n b t =-  let def =     if b then Color.BrWhite else Color.defFG-      defDark = if b then Color.BrYellow else Color.BrBlack-      defDoor = if b then Color.Yellow else Color.BrBlack-  in case t of-       Rock                -> (' ', def)-       (Opening d)-         | n <= 3          -> ('.', def)-         | otherwise       -> viewTerrain 0 b (Wall d)-       (Floor d)           -> ('.', if d == Light then def else defDark)-       Unknown             -> (' ', def)-       Corridor-         | n <= 3          -> ('#', if b then Color.BrWhite else Color.defFG)-         | otherwise       -> viewTerrain 0 b Rock-       (Wall p)-         | p == O          -> ('O', def)-         | p `elem` [L, R] -> ('|', def)-         | otherwise       -> ('-', def)-       (Stairs d p _)-         | n <= 1          -> (if p == Up then '<' else '>',-                               if d == Light then def else defDark)-         | otherwise       -> viewTerrain 0 b (Floor Dark)-       (Door p (Just 0))-         | n <= 2          -> ('+', defDoor)-         | otherwise       -> viewTerrain n b (Opening p)-       (Door p (Just _))-         | n <= 2          -> viewTerrain n b (Wall p)  -- secret door-         | otherwise       -> viewTerrain n b (Opening p)-       (Door p Nothing)-         | n <= 2          -> (if p `elem` [L, R] then '-' else '|', defDoor)-         | otherwise       -> viewTerrain n b (Opening p)
− src/Turn.hs 
@@ -1,276 +0,0 @@-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 Actor-import ActorState-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 = atime (getPlayerBody state)  -- time of player's next move-    let time  = stime state                  -- current game time-    debug $ "handle: time check. ptime = " ++ show ptime ++ ", time = " ++ show time-    if ptime > time-      then do-             -- 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)-               (displayGeneric ColorFull (const ""))-             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.--- TODO: We should replace thi structure using a priority search queue/tree.-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 (atime . snd)-               (i, m) = L.minimumBy order (IM.assocs ms)-               actor = AMonster i-           in  if atime m > time || actor == pl-               then nextMove  -- no monster is ready for another move-               else handleMonster actor---- | Handle the move of a single monster.-handleMonster :: ActorId -> 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 (atime . getPlayerBody)-    withPerception playerCommand -- get and process a player command-    -- at this point, the command was successful and possibly took some time-    newPlayerTime <- gets (atime . getPlayerBody)-    if newPlayerTime == oldPlayerTime-      then withPerception handlePlayer  -- no time taken, repeat-      else do-        state <- get-        pl    <- gets splayer-        let time = stime state-            ploc = aloc (getPlayerBody state)-            sTimeout = Config.get (sconfig state) "monsters" "smellTimeout"-        -- update smell-        when (isAHero pl) $  -- only humans leave strong scent-          modify (updateLevel (updateSMap (M.insert ploc (time + sTimeout))))-        -- determine player perception and continue with monster moves-        withPerception handleMonsters---- | Determine and process the next player command.-playerCommand :: Action ()-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 
@@ -1,11 +0,0 @@-module Version where--import Data.Version---- Cabal-import qualified Paths_LambdaHack as Self (version)--import qualified Display--version :: String-version = showVersion Self.version ++ " (" ++ Display.displayId ++ " frontend)"
− src/config.default 
@@ -1,60 +0,0 @@-; This is the default config file, included in the binary itself.-; The game looks for the user config file in ~/.LambdaHack/config.-; We restricts the config file format by insisting that-; options are case-sensitive and permitting only ';' comments.--; If you contribute to the game, please create directory ~/.LambdaHack/-; as described in README.markdown. In this way, you will not accidentally-; commit your private high scores (nor your save files) to the game-; git repository.--[dungeon]-; the hardcoded default for levels with no specified layout:-LambdaCave_1: rogueRoom-; access to stairs may be blocked, so only suitable for the last level:-LambdaCave_10: noiseRoom-LambdaCave_3: bigRoom-depth: 10--[engine]-fovMode: shadow-;fovMode: digital-;fovMode: permissive-fovRadius: 40--; paths to various game files; relative to ~/.LambdaHack/-; (or analogous prefixes for other OSes, see getAppUserDataDirectory)-[files]-highScores: scores-saveGame: save--[heroes]-HeroName_0: you-HeroName_1: Haskell Alvin-HeroName_2: Alonzo Barkley-HeroName_3: Ernst Abraham-HeroName_4: Samuel Saunders-HeroName_5: Roger Robin-baseHP: 50-extraHeroes: 0-firstDeathEnds: False--[macros]-; TODO: the following does not work yet:-; ; throw a dart at the closest monster-; t: asterisk Return t Return-; TODO: in gtk it could be implemented via unGetChan,-; unless we prefer an explicit command queue, with flushing, etc.-;-; NetHack compatibility-S: X-colon: slash-comma: g-; Angband compatibility-v: t--[monsters]-smellTimeout: 1000--[ui]-historyMax: 500