Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

The big, ugly, pending pull request #11

Closed
wants to merge 240 commits into from
This page is out of date. Refresh to see the latest.
Showing with 4,095 additions and 2,199 deletions.
  1. +1 −1  .gitignore
  2. +2 −1  CREDITS
  3. +18 −12 LambdaHack.cabal
  4. +0 −25 LambdaHack.config.example
  5. BIN  LambdaHack.scores
  6. +91 −49 PLAYING.markdown
  7. +15 −0 README.markdown
  8. BIN  scores
  9. +101 −40 src/Action.hs
  10. +454 −410 src/Actions.hs
  11. +0 −35 src/Actor.hs
  12. +119 −0 src/Color.hs
  13. +22 −13 src/Command.hs
  14. +80 −38 src/Config.hs
  15. +19 −0 src/ConfigDefault.hs
  16. +195 −4 src/Display.hs
  17. +87 −86 src/Display/Curses.hs
  18. +58 −100 src/Display/Gtk.hs
  19. +66 −34 src/Display/Vty.hs
  20. +0 −194 src/Display2.hs
  21. +69 −50 src/Dungeon.hs
  22. +40 −0 src/DungeonState.hs
  23. +41 −0 src/Effect.hs
  24. +327 −0 src/EffectAction.hs
  25. +4 −2 src/FOV.hs
  26. +2 −2 src/FOV/Digital.hs
  27. +5 −3 src/FOV/Permissive.hs
  28. +1 −1  src/FOV/Shadow.hs
  29. +47 −2 src/Geometry.hs
  30. +58 −0 src/GeometryRnd.hs
  31. +77 −49 src/Grammar.hs
  32. +45 −31 src/HighScores.hs
  33. +104 −168 src/Item.hs
  34. +319 −0 src/ItemAction.hs
  35. +169 −0 src/ItemKind.hs
  36. +0 −16 src/ItemState.hs
  37. +13 −12 src/Keybindings.hs
  38. +127 −3 src/Keys.hs
  39. +0 −79 src/LambdaHack.hs
  40. +58 −388 src/Level.hs
  41. +22 −21 src/LevelState.hs
  42. +45 −0 src/Main.hs
  43. +7 −5 src/Message.hs
  44. +0 −134 src/Monster.hs
  45. +83 −0 src/Movable.hs
  46. +108 −0 src/MovableAdd.hs
  47. +111 −0 src/MovableKind.hs
  48. +122 −0 src/MovableState.hs
  49. +8 −0 src/Multiline.hs
  50. +77 −19 src/Perception.hs
  51. +26 −0 src/Random.hs
  52. +25 −9 src/Save.hs
  53. +73 −29 src/State.hs
  54. +4 −3 src/Strategy.hs
  55. +164 −48 src/StrategyState.hs
  56. +234 −0 src/Terrain.hs
  57. +90 −80 src/Turn.hs
  58. +2 −3 src/Version.hs
  59. +60 −0 src/config.default
View
2  .gitignore
@@ -1,4 +1,4 @@
-LambdaHack.save
+save
dist/
*~
*.swp
View
3  CREDITS
@@ -1,4 +1,5 @@
-Developers who have contributed significantly to LambdaHack:
+All kinds of contributions to LambdaHack are gratefully welcome!
+Some of the contributors are listed below, in chronological order.
Andres Loeh
Mikolaj Konarski
View
30 LambdaHack.cabal
@@ -3,8 +3,9 @@ name: LambdaHack
version: 0.1.20110117
license: BSD3
license-file: LICENSE
+tested-with: GHC==7.0.3
data-files: LICENSE, CREDITS, DESIGN.markdown, PLAYING.markdown,
- README.markdown, LambdaHack.config.example
+ README.markdown, src/config.default, scores
author: Andres Loeh <mail@andres-loeh.de>
maintainer: Andres Loeh <mail@andres-loeh.de>
description: a small roguelike game
@@ -22,22 +23,27 @@ flag vty
default: False
executable LambdaHack
- main-is: LambdaHack.hs
+ main-is: Main.hs
hs-source-dirs:src
- other-modules: Actor, Action, Actions, Command, Display, Display2, Dungeon,
- File, FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,
- Frequency, Geometry, Item, ItemState,
- Keys, Keybindings, LambdaHack, Level, LevelState, Message,
- Monster, Perception, Random, Save, State, Strategy,
- StrategyState, Turn, Version, HighScores, Config,
- Grammar
- build-depends: base >= 4 && <5, containers >= 0.1 && < 1,
+ other-modules: Action, Actions, Color, Command, Config, ConfigDefault,
+ Display, Dungeon, DungeonState, Effect, EffectAction, File,
+ FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,
+ Frequency, Geometry, GeometryRnd, Grammar,
+ HighScores, Item, ItemKind, ItemAction,
+ Keys, Keybindings, Level, LevelState,
+ Main, Message, MovableAdd, MovableKind, Movable, MovableState,
+ Multiline, Perception, Random,
+ Save, State, Strategy, StrategyState,
+ Turn, Terrain, Version
+ build-depends: base >= 4 && < 5, containers >= 0.1 && < 1,
binary >= 0.4 && < 1,
random >= 1 && < 2, zlib >= 0.4 && < 1,
bytestring >= 0.9 && < 1, directory >= 1 && < 2,
mtl >= 1.1 && < 3, old-time, ConfigFile >= 1.0.6 && < 2,
- MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 1.2
- extensions: CPP, FlexibleContexts
+ MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 2,
+ template-haskell >= 2.5
+ extensions: CPP, FlexibleContexts, QuasiQuotes, MultiParamTypeClasses,
+ RankNTypes, BangPatterns
if flag(curses) {
other-modules: Display.Curses
build-depends: hscurses >= 1.3 && < 2
View
25 LambdaHack.config.example
@@ -1,25 +0,0 @@
-# LambdaHack looks for this file in ~/.LambdaHack/LambdaHack.config
-
-# If you contribute to LambdaHack, please create directory ~/.LambdaHack/
-# and move this example config file to ~/.LambdaHack/LambdaHack.config.
-# Optionally, also copy LambdaHack.scores to ~/.LambdaConfig/.
-# In this way, you won't accidentally commit your private high scores
-# (nor your save files) to LambdaHack git repository.
-
-# paths to various game files; relative to ~/.LambdaHack/
-# (or analogous prefixes for other OSes, see getAppUserDataDirectory)
-[files]
-savegame: LambdaHack.save
-highscores: LambdaHack.scores
-
-[engine]
-fov_mode: shadow
-#fov_mode: digital
-#fov_mode: permissive
-fov_radius: 40
-
-[dungeon]
-depth: 10
-level3: bigroom
-level10: noiseroom
-#level1: noiseroom
View
BIN  LambdaHack.scores
Binary file not shown
View
140 PLAYING.markdown
@@ -1,58 +1,71 @@
Playing LambdaHack
==================
-Playing the game consist of walking around the dungeon and bumping
-into things (doors, monsters, treasure). Once the few basic command keys
-and on-screen symbols are learned, mastery and enjoyment of the game
-is the matter of tactical skill and literary imagination.
+Playing LambdaHack involves walking around the dungeon,
+alone or in a party of fearless adventurers, jumping between levels,
+bumping into monsters, doors and walls, gathering magical treasure
+and making creative use of it. The bloodthirsty monsters do the same,
+intelligence allowing, while tirelessly chasing the noble heroes
+by smell and night-sight.
-To be honest, right now you need a lot of imagination, since the game
-is very basic, though playable and winnable. Contributions welcome.
+Once the few basic command keys and on-screen symbols are learned,
+mastery and enjoyment of the game is the matter of tactical skill
+and literary imagination. To be honest, you need a lot of imagination
+right now, since the game is still quite basic, though playable and winnable.
+Contributions welcome.
Dungeon
-------
-The goal of the hero is to explore the dungeon from top to the very bottom
-(and grab lots of shiny treasure and gear on the way).
+The goal of the hero is to explore the dungeon, battle the horrors within,
+gather as much gold and gems as possible, and escape to tell the tale.
The dungeon consists of 10 levels and each level consists of 80 by 21 tiles.
-The basic tiles tiles are as follows:
+The basic tiles are as follows.
dungeon terrain type on-screen symbol
floor .
wall (horizontal and vertical) - and |
+ pillar wall O
corridor #
stairs (up and down) < and >
closed door +
+ open door | and -
rock blank
-The game world is persistent, i.e., every time the hero visits a level
-during one game, the level should look the same.
+The game world is persistent, i. e., every time a hero visits a level
+during a single game, the level layout looks the same. Some items
+aid in dungeon exploration, e.g., a ring of searching improves the speed
+of finding hidden doors by heroes and monsters. The higher the magical
+bonus displayed for this and other dungeon items, the more effective it is.
+Only the best item carried in a hero's or monster's inventory counts.
+You can throw the rest away, but beware that your adversaries may pick it up
+and use it against you.
Keys
----
-Here are a few keys you can use in the game:
+Below are the basic default keys.
key command
+ . wait
+ < ascend a level
+ > descend a level
+ ? display help
+ Q quit without saving
+ X save and exit the game
c close a door
d drop an object
+ g get an object
i display inventory
- o open a door
- s search for secret doors
+ o open a door (alternatively, you can bump into a door)
q quaff a potion
- M display previous messages
- S save and quit the game
- Q quit without saving
- . wait
- , pick up an object
- : look around
- < ascend a level
- > descend a level
+ r read a scroll
+ s search for secret doors (or you can bump into a wall)
One of the ways of moving throughout the level is with the vi text editor keys
-(also known as "Rogue-like keys"):
+(also known as "Rogue-like keys").
key command
k up
@@ -67,45 +80,74 @@ One of the ways of moving throughout the level is with the vi text editor keys
Pressing a capital letter corresponding to a direction key will have
the hero run in that direction until something interesting occurs.
-It's also possible to move using the numerical keypad, with Shift for running
-and the middle '5' key for resting. (If you are using the curses frontend,
+It is also possible to move using the numerical keypad, with Shift for running
+and the middle '5' key for waiting. (If you are using the curses frontend,
numerical keypad may not work correctly for terminals with broken terminfo,
-e.g., gnome terminal tends to have problems, while xterm works fine.)
+e.g., gnome terminal has problems, while xterm works fine.)
-Below are also some debug and cheat keys. Use at your peril!
+To make a distance attack, you need to set your target first.
+The targeting commands are listed below, together with all the other
+less common player commands.
+
+ key command
+ 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
- v display the version of the game
O toggle "omniscience"
- I display level meta-data
- R toggle smell display
- T toggle level generation sequence
- V toggle field of vision display
+ I inform about level meta-data
+ R rotate display modes
+ T cycle among level terrain generation stages
Monsters
--------
-The hero is not alone in the dungeon. Monsters roam the game world, too.
-Monsters inhabit specific locations on the game map, and can be seen
-if the tile they are on can be seen by the hero.
-Every monster gets a turn per move of the hero. Monster moves
-are restricted in the same way as hero moves, i.e., they cannot move
-into obstacles like walls or rock. Some monsters
-ignore the hero, others chase him only when they see him
-and the especially dangerous kind is able to smell the hero.
-
-When the hero moves into a monster or a monster bumps into the hero,
-combat occurs. Whenever combat occurs, the attacked party may lose some health.
-If the hero dies, the game ends.
+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
--------------------
-If you happen to die, you are free to start again from the first level
-of the dungeon, but all your treasure is gone and the dungeon will look
-different this time.
+You win the game if you escape the dungeon alive. Your score is
+the sum of all gold you've plundered plus 100gp for each gem.
+Only the loot in possession of the party members on level 1 counts
+(the rest is considered MIA).
-You win the game if you escape the dungeon alive with treasure and valuable
-items --- the more the better!
+If all heroes die, your score is halved and only the treasure carried
+by the last standing hero counts. You are free to start again
+from the first level of the dungeon, but all your wealth and items
+are gone and the dungeon and it's treasure look differently.
View
15 README.markdown
@@ -2,6 +2,10 @@ 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 AI independent
+of monster, item and terrain definitions.
Compilation and installation
@@ -23,6 +27,17 @@ or you may try one of the terminal frontends with
cabal install -fvty
+Savegame directory
+------------------
+
+If you don't want LambdaHack to write to the current directory,
+create a personal savegame directory (on Linux it's ~/.LambdaHack/).
+and copy the scores file there. You may also want to
+copy the configuration file src/config.default to
+~/.LambdaHack/config and modify it, but be careful changing
+gameplay options --- they can easily unbalance or break the game.
+
+
Further information
-------------------
View
BIN  scores
Binary file not shown
View
141 src/Action.hs
@@ -3,23 +3,30 @@ 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 Display2 hiding (display)
+import Display hiding (display)
import Message
import State
+import Level
+import Movable
+import MovableState
+import MovableKind
+import qualified Save
newtype Action a = Action
{ runAction ::
forall r .
Session ->
- IO r -> -- shutdown cont
- Perception -> -- cached perception
- (State -> Message -> a -> IO r) -> -- continuation
- IO r -> -- failure/reset cont
- State -> -- current state
- Message -> -- current message
+ IO r -> -- shutdown cont
+ Perceptions -> -- cached perception
+ (State -> Message -> a -> IO r) -> -- continuation
+ IO r -> -- failure/reset cont
+ State -> -- current state
+ Message -> -- current message
IO r
}
@@ -51,7 +58,7 @@ handlerToIO :: Session -> State -> Message -> Action () -> IO ()
handlerToIO session state msg h =
runAction h
session
- (shutdown session) -- get out of the game
+ (Save.rmBkp (sconfig state) >> shutdown session) -- get out of the game
(perception_ state) -- cached perception
(\ _ _ x -> return x) -- final continuation returns result
(ioError $ userError "unhandled abort")
@@ -68,19 +75,23 @@ sessionIO f = Action (\ s e p k a st ms -> f s >>= k st ms)
-- | Display the current level, without any message.
displayWithoutMessage :: Action Bool
-displayWithoutMessage = Action (\ s e p k a st ms -> displayLevel s p st "" Nothing >>= k st ms)
+displayWithoutMessage = Action (\ s e p k a st ms -> displayLevel False s p st "" Nothing >>= k st ms)
-- | Display the current level, with the current message.
display :: Action Bool
-display = Action (\ s e p k a st ms -> displayLevel s p st ms Nothing >>= k st ms)
+display = Action (\ s e p k a st ms -> displayLevel False s p st ms Nothing >>= k st ms)
+
+-- | Display the current level in black and white, and the current message,
+displayBW :: Action Bool
+displayBW = Action (\ s e p k a st ms -> displayLevel True s p st ms Nothing >>= k st ms)
-- | Display an overlay on top of the current screen.
overlay :: String -> Action Bool
-overlay txt = Action (\ s e p k a st ms -> displayLevel s p st ms (Just txt) >>= k st ms)
+overlay txt = Action (\ s e p k a st ms -> displayLevel False s p st ms (Just txt) >>= k st ms)
-- | Set the current message.
-message :: Message -> Action ()
-message nm = Action (\ s e p k a st ms -> k st nm ())
+messageWipeAndSet :: Message -> Action ()
+messageWipeAndSet nm = Action (\ s e p k a st ms -> k st nm ())
@kosmikus Owner

I think the name is too long.

@Mikolaj Owner
Mikolaj added a note

implemented in a6e2b80

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
-- | Add to the current message.
messageAdd :: Message -> Action ()
@@ -103,6 +114,18 @@ end = Action (\ s e p k a st ms -> e)
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 ()
@@ -127,33 +150,37 @@ debug x = return () -- liftIO $ hPutStrLn stderr x
-- | Print the given message, then abort.
abortWith :: Message -> Action a
-abortWith msg =
- do
- message msg
- display
- abort
+abortWith msg = do
+ messageWipeAndSet msg
+ display
+ abort
+
+neverMind :: Bool -> Action a
+neverMind b = abortIfWith b "never mind"
-- | Abort, and print the given message if the condition is true.
abortIfWith :: Bool -> Message -> Action a
-abortIfWith True = abortWith
-abortIfWith False = const abort
+abortIfWith True msg = abortWith msg
+abortIfWith False _ = abortWith ""
--- | Print message, await confirmation. Return value indicates if the
--- player tried to abort/escape.
-messageMoreConfirm :: Message -> Action Bool
-messageMoreConfirm msg =
- do
- message (msg ++ more)
- display
- session getConfirm
+-- | Print message, await confirmation. Return value indicates
+-- if the player tried to abort/escape.
+messageMoreConfirm :: Bool -> Message -> Action Bool
+messageMoreConfirm blackAndWhite msg = do
+ messageAdd (msg ++ more)
+ if blackAndWhite then displayBW else display
@kosmikus Owner

This indicates that it'd be better to have one function

 display :: Bool -> ...

that takes the BW mode, and just pass the argument through.

@Mikolaj Owner
Mikolaj added a note

implemented in 7f49100

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ session getConfirm
+
+-- | Print message, await confirmation, ignore confirmation.
+messageMore :: Message -> Action ()
+messageMore msg = resetMessage >> messageMoreConfirm False msg >> return ()
-- | Print a yes/no question and return the player's answer.
messageYesNo :: Message -> Action Bool
-messageYesNo msg =
- do
- message (msg ++ yesno)
- display
- session getYesNo
+messageYesNo msg = do
+ messageWipeAndSet (msg ++ yesno)
+ displayBW -- turn player's attention to the choice
+ session getYesNo
-- | Print a message and an overlay, await confirmation. Return value
-- indicates if the player tried to abort/escape.
@@ -170,7 +197,7 @@ messageOverlaysConfirm msg [] =
return True
messageOverlaysConfirm msg (x:xs) =
do
- message msg
+ messageWipeAndSet msg
b <- overlay (x ++ more)
if b
then do
@@ -181,11 +208,10 @@ messageOverlaysConfirm msg (x:xs) =
else stop
else stop
where
- stop =
- do
- resetMessage
- display
- return False
+ stop = do
+ resetMessage
+ display
+ return False
-- | Update the cached perception for the given computation.
withPerception :: Action () -> Action ()
@@ -193,6 +219,41 @@ 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 Perception
+currentPerception :: Action Perceptions
currentPerception = Action (\ s e p k a st ms -> k st ms p)
+-- | If in targeting mode, check if the current level is the same
+-- as player level and refuse performing the action otherwise.
+checkCursor :: Action () -> Action ()
+checkCursor h = do
+ cursor <- gets scursor
+ level <- gets slevel
+ if creturnLn cursor == lname level
+ then h
+ else abortWith "this command does not work on remote levels"
+
+updateAnyActor :: Actor -> (Movable -> Movable) -> Action ()
@kosmikus Owner

Why not rename Movable to Actor, and Actor to ActorId?

@Mikolaj Owner
Mikolaj added a note

implemented in a72f566 and 22d6553

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+updateAnyActor actor f = modify (updateAnyActorBody actor f)
+
+updatePlayerBody :: (Movable -> Movable) -> Action ()
+updatePlayerBody f = do
+ pl <- gets splayer
+ updateAnyActor pl f
+
+-- | Advance the move time for the given actor.
+advanceTime :: Actor -> Action ()
+advanceTime actor = do
+ time <- gets stime
+ let upd m = m { mtime = time + (nspeed (mkind m)) }
+ -- A hack to synchronize the whole party:
+ pl <- gets splayer
+ if (actor == pl || isAHero actor)
+ then do
+ modify (updateLevel (updateHeroes (IM.map upd)))
+ when (not $ isAHero pl) $ updatePlayerBody upd
+ else updateAnyActor actor upd
+
+playerAdvanceTime :: Action ()
+playerAdvanceTime = do
+ pl <- gets splayer
+ advanceTime pl
View
864 src/Actions.hs
@@ -5,27 +5,38 @@ 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 Actor hiding (updateActor)
-import Display2 hiding (display)
+import Display hiding (display)
import Dungeon
import Geometry
import Grammar
import qualified HighScores as H
import Item
+import qualified ItemKind
import qualified Keys as K
import Level
import LevelState
import Message
-import Monster
+import Movable
+import MovableState
+import MovableKind
+import MovableAdd
import Perception
import Random
-import qualified Save as S
import State
+import qualified Config
+import qualified Save
+import Terrain
+import qualified Effect
+import EffectAction
+
+-- The Action stuff that is independent from ItemAction.hs.
+-- (Both depend on EffectAction.hs).
displayHistory :: Action ()
displayHistory =
@@ -34,6 +45,14 @@ displayHistory =
messageOverlayConfirm "" (unlines hst)
abort
+dumpConfig :: Action ()
+dumpConfig =
+ do
+ config <- gets sconfig
+ let fn = "config.dump"
+ liftIO $ Config.dump fn config
+ abortWith $ "Current configuration dumped to file " ++ fn ++ "."
+
saveGame :: Action ()
saveGame =
do
@@ -42,9 +61,12 @@ saveGame =
then do
-- Save the game state
st <- get
- liftIO $ S.saveGame st
- let total = calculateTotal (splayer st)
- handleScores False False False total
+ liftIO $ Save.saveGame st
+ ln <- gets (lname . slevel)
+ let total = calculateTotal st
+ status = H.Camping ln
+ go <- handleScores False status total
+ when go $ messageMore "See you soon, stronger and braver!"
end
else abortWith "Game resumed."
@@ -53,17 +75,83 @@ quitGame =
do
b <- messageYesNo "Really quit?"
if b
- then end -- TODO: why no highscore?
+ then end -- TODO: why no highscore? no display, because the user may be in a hurry, since he quits the game instead of getting himself killed properly? no score recording, not to polute the scores list with games that the player didn't even want to end honourably?
else abortWith "Game resumed."
+-- | End targeting mode, accepting the current location or not.
+endTargeting :: Bool -> Action ()
+endTargeting accept = do
+ returnLn <- gets (creturnLn . scursor)
+ target <- gets (mtarget . getPlayerBody)
+ cloc <- gets (clocation . scursor)
+ lvlSwitch returnLn -- return to the original level of the player
+ modify (updateCursor (\ c -> c { ctargeting = False }))
+ let isEnemy = case target of TEnemy _ _ -> True ; _ -> False
+ when (not isEnemy) $
+ if accept
+ then updatePlayerBody (\ p -> p { mtarget = TLoc cloc })
+ else updatePlayerBody (\ p -> p { mtarget = TCursor })
+ endTargetingMsg
+
+endTargetingMsg :: Action ()
+endTargetingMsg = do
+ pkind <- gets (mkind . getPlayerBody)
+ target <- gets (mtarget . getPlayerBody)
+ state <- get
+ let verb = "target"
+ targetMsg = case target of
+ TEnemy a _ll ->
+ case findActorAnyLevel a state of
+ Just (_, m) -> objectMovable (mkind m)
+ Nothing -> "a long gone adversary"
+ TLoc loc -> "location " ++ show loc
+ TCursor -> "current cursor position continuously"
+ messageAdd $ subjectMovableVerb pkind verb ++ " " ++ targetMsg ++ "."
+
+-- | Cancel something, e.g., targeting mode, resetting the cursor
+-- to the position of the player. Chosen target is not invalidated.
+cancelCurrent :: Action ()
+cancelCurrent = do
+ targeting <- gets (ctargeting . scursor)
+ if targeting
+ then endTargeting False
+ else abortWith "Press Q to quit."
+
+-- | Accept something, e.g., targeting mode, keeping cursor where it was.
+-- Or perform the default action, if nothing needs accepting.
+acceptCurrent :: Action () -> Action ()
+acceptCurrent h = do
+ targeting <- gets (ctargeting . scursor)
+ if targeting
+ then endTargeting True
+ else h -- nothing to accept right now
+
+moveCursor :: Dir -> Int -> Action ()
+moveCursor dir n = do
+ (sy, sx) <- gets (lsize . slevel)
+ let upd cursor =
+ let (ny, nx) = iterate (`shift` dir) (clocation cursor) !! n
+ cloc = (max 1 $ min ny (sy-1), max 1 $ min nx (sx-1))
+ in cursor { clocation = cloc }
+ modify (updateCursor upd)
+ doLook
+
move :: Dir -> Action ()
-move = moveOrAttack True True APlayer
+move dir = do
+ pl <- gets splayer
+ targeting <- gets (ctargeting . scursor)
+ if targeting then moveCursor dir 1 else moveOrAttack True True pl dir
run :: Dir -> Action ()
-run dir =
- do
- modify (updatePlayer (\ p -> p { mdir = Just dir }))
- moveOrAttack False False APlayer dir -- attacks and opening doors disallowed while running
+run dir = do
+ pl <- gets splayer
+ targeting <- gets (ctargeting . scursor)
+ if targeting
@kosmikus Owner

Think about doing the mode dispatch elsewhere.

@Mikolaj Owner
Mikolaj added a note

Noted as a TODO comment in the code; extended a bit.

@Mikolaj Owner
Mikolaj added a note

Implemented in 1e7daa2. Done in the simplest way. There are better ways, for sure (as the message aggregation proopsed in TODO inside the changed code), but I'd need some more complex messages to evaluate (e.g., missed blows, criticals).

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ then moveCursor dir 10
+ else do
+ updatePlayerBody (\ p -> p { mdir = Just dir })
+ -- attacks and opening doors disallowed while running
+ moveOrAttack False False pl dir
-- | This function implements the actual "logic" of running. It checks if we
-- have to stop running because something interested happened, and it checks
@@ -72,25 +160,34 @@ continueRun :: Dir -> Action ()
continueRun dir =
do
state <- get
- let lvl @(Level { lmonsters = ms, lmap = lmap }) = slevel state
- let player@(Monster { mloc = loc }) = splayer state
- let mslocs = S.fromList (L.map mloc ms)
- let t = lmap `at` loc -- tile at current location
- per <- currentPerception
- msg <- currentMessage
- let monstersVisible = not (S.null (mslocs `S.intersection` pvisible per))
- let newsReported = not (L.null msg)
- let itemsHere = not (L.null (titems t))
- let dirOK = accessible lmap loc (loc `shift` dir)
+ loc <- gets (mloc . getPlayerBody)
+ per <- currentPerception
+ msg <- currentMessage
+ ms <- gets (lmonsters . slevel)
+ hs <- gets (lheroes . slevel)
+ lmap <- gets (lmap . slevel)
+ pl <- gets splayer
+ let dms = case pl of
+ AMonster n -> IM.delete n ms -- don't be afraid of yourself
+ AHero _ -> ms
+ mslocs = S.fromList (L.map mloc (IM.elems dms))
+ monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per))
+ newsReported = not (L.null msg)
+ t = lmap `at` loc -- tile at current location
+ itemsHere = not (L.null (titems t))
+ heroThere = L.elem (loc `shift` dir) (L.map mloc (IM.elems hs))
+ dirOK = accessible lmap loc (loc `shift` dir)
-- What happens next is mostly depending on the terrain we're currently on.
let exit (Stairs {}) = True
exit (Opening {}) = True
exit (Door {}) = True
exit _ = False
let hop t
- | monstersVisible || newsReported || itemsHere || exit t = abort
+ | monstersVisible || heroThere
+ || newsReported || itemsHere || exit t = abort
hop Corridor =
-- in corridors, explore all corners and stop at all crossings
+ -- TODO: even in corridors, stop if you run past an exit (rare)
let ns = L.filter (\ x -> distance (neg dir, x) > 1
&& accessible lmap loc (loc `shift` x))
moves
@@ -109,64 +206,35 @@ continueRun dir =
let ns = L.filter (\ x -> x /= dir && distance (neg dir, x) > 1) moves
ls = L.map (loc `shift`) ns
as = L.filter (\ x -> accessible lmap loc x
- || openable 0 lmap x) ls
+ || openable 1 lmap x) ls
ts = L.map (tterrain . (lmap `at`)) as
in if L.any exit ts then abort else run dir
hop (tterrain t)
-stopRunning :: Action ()
-stopRunning = modify (updatePlayer (\ p -> p { mdir = Nothing }))
-
ifRunning :: (Dir -> Action a) -> Action a -> Action a
ifRunning t e =
do
- mdir <- gets (mdir . splayer)
+ mdir <- gets (mdir . getPlayerBody)
maybe e t mdir
--- | Store current message in the history and reset current message.
-history :: Action ()
-history =
- do
- msg <- resetMessage
- unless (L.null msg) $
- modify (updateHistory (take 500 . ((msg ++ " "):)))
- -- TODO: make history max configurable
-
-- | Update player memory.
remember :: Action ()
remember =
do
per <- currentPerception
- let vis = S.toList (pvisible per)
+ let vis = S.toList (ptvisible per)
let rememberLoc = M.update (\ (t,_) -> Just (t,t))
- modify (updateLevel (updateLMap (\ lmap -> foldr rememberLoc lmap vis)))
-
-checkHeroDeath :: Action ()
-checkHeroDeath =
- do
- player <- gets splayer
- let php = mhp player
- when (php <= 0) $ do
- messageAdd more
- display
- session getConfirm
- go <- messageMoreConfirm "You die."
- when go $ do
- let total = calculateTotal player
- handleScores True True False total
- end
-
-neverMind :: Bool -> Action a
-neverMind b = abortIfWith b "never mind"
+ modify (updateLevel (updateLMap (\ lmap -> L.foldr rememberLoc lmap vis)))
-- | Open and close doors
openclose :: Bool -> Action ()
openclose o =
do
- message "direction?"
+ messageWipeAndSet "direction?"
display
- e <- session nextCommand
- handleDirection e (actorOpenClose APlayer True o) (neverMind True)
+ e <- session nextCommand
+ pl <- gets splayer
+ K.handleDirection e (actorOpenClose pl True o) (neverMind True)
actorOpenClose :: Actor ->
Bool -> -- ^ verbose?
@@ -174,323 +242,266 @@ actorOpenClose :: Actor ->
Dir -> Action ()
actorOpenClose actor v o dir =
do
- let txt = if o then "open" else "closed"
state <- get
- let lvl@Level { lmonsters = ms, lmap = lmap } = slevel state
- let loc = mloc (getActor state actor)
- let isPlayer = actor == APlayer
+ lmap <- gets (lmap . slevel)
+ pl <- gets splayer
+ body <- gets (getActor actor)
+ let txt = if o then "open" else "closed"
+ let hms = levelHeroList state ++ levelMonsterList state
+ let loc = mloc body
+ let isPlayer = actor == pl
let isVerbose = v && isPlayer
let dloc = shift loc dir -- location we act upon
+ let openPower = case strongestItem (mitems body) "ring" of
+ Just i -> niq (mkind body) + ipower i
+ Nothing -> niq (mkind body)
in case lmap `at` dloc of
Tile d@(Door hv o') []
- | secret o' && isPlayer-> -- door is secret, cannot be opened or closed by hero
+ | secret o' && isPlayer -> -- door is secret, cannot be opened or closed by the player
neverMind isVerbose
- | toOpen (not o) /= o' -> -- door is in unsuitable state
+ | maybe o ((|| not o) . (>= openPower)) o' ->
+ -- door is in unsuitable state
abortIfWith isVerbose ("already " ++ txt)
- | not (unoccupied ms lmap dloc) ->
- -- door is blocked by a monster
+ | not (unoccupied hms dloc) ->
+ -- door is blocked by a movable
abortIfWith isVerbose "blocked"
| otherwise -> -- door can be opened / closed
-- TODO: print message if action performed by monster and perceived
- let nt = Tile (Door hv (toOpen o)) []
- clmap = M.adjust (\ (_, mt) -> (nt, mt)) dloc lmap
- in modify (updateLevel (const (updateLMap (const clmap) lvl)))
+ let nt = Tile (Door hv (toOpen o)) []
+ adj = M.adjust (\ (_, mt) -> (nt, mt)) dloc
+ in modify (updateLevel (updateLMap adj))
Tile d@(Door hv o') _ -> -- door is jammed by items
abortIfWith isVerbose "jammed"
_ -> -- there is no door here
neverMind isVerbose
+ advanceTime actor
--- | Perform a level change -- will quit the game if the player leaves
--- the dungeon.
-lvlchange :: VDir -> Action ()
-lvlchange vdir =
+ -- | Attempt a level switch to k levels deeper.
+-- TODO: perhaps set up some level name arithmetics in Level.hs
+-- and hide there the fact levels are now essentially Ints.
+lvlDescend :: Int -> Action ()
+lvlDescend k =
do
state <- get
- let lvl @(Level { lmap = lmap }) = slevel state
- let player@(Monster { mloc = ploc }) = splayer state
- case lmap `at` ploc of
+ let n = levelNumber (lname (slevel state))
+ nln = n + k
+ when (nln < 1 || nln > sizeDungeon (sdungeon state) + 1) $
+ abortWith "no more levels in this direction"
+ assertTrue $ liftM (k == 0 ||) (lvlSwitch (LambdaCave nln))
+
+-- | Attempt a level change via up level and down level keys.
+-- Will quit the game if the player leaves the dungeon.
+lvlChange :: VDir -> Action ()
+lvlChange vdir =
+ do
+ cursor <- gets scursor
+ targeting <- gets (ctargeting . scursor)
+ pbody <- gets getPlayerBody
+ pl <- gets splayer
+ map <- gets (lmap . slevel)
+ let loc = if targeting then clocation cursor else mloc pbody
+ case map `at` loc of
Tile (Stairs _ vdir' next) is
| vdir == vdir' -> -- stairs are in the right direction
case next of
Nothing ->
-- we are at the "end" of the dungeon
- fleeDungeon
- Just (nln, nloc) ->
- -- perform level change
- do
- -- put back current level
- -- (first put back, then get, in case we change to the same level!)
- let full = putDungeonLevel lvl (sdungeon state)
- -- get new level
- let (new, ndng) = getDungeonLevel nln full
- modify (\ s -> s { sdungeon = ndng, slevel = new })
- modify (updatePlayer (\ p -> p { mloc = nloc }))
+ if targeting
+ then abortWith "cannot escape dungeon in targeting mode"
+ else do
+ b <- messageYesNo "Really escape the dungeon?"
+ if b
+ then fleeDungeon
+ else abortWith "Game resumed."
+ Just (nln, nloc) -> do
+ if targeting
+ then do
+ -- this assertion says no stairs go back to the same level
+ assertTrue $ lvlSwitch nln
+ -- do not freely reveal the other end of the stairs
+ map <- gets (lmap . slevel) -- lvlSwitch modifies map
+ let upd cursor =
+ let cloc = if Level.isUnknown (rememberAt map nloc)
+ then loc
+ else nloc
+ in cursor { clocation = cloc, clocLn = nln }
+ modify (updateCursor upd)
+ doLook
+ else tryWith (abortWith "somebody blocks the staircase") $ do
+ -- Remove the player from the old level.
+ modify (deleteActor pl)
+ -- At this place the invariant that the player exists fails.
+ -- Change to the new level (invariant not needed).
+ assertTrue $ lvlSwitch nln
+ -- Add the player to the new level.
+ modify (insertActor pl pbody)
+ -- At this place the invariant is restored again.
+ -- Land the player at the other end of the stairs.
+ updatePlayerBody (\ p -> p { mloc = nloc })
+ -- Change the level of the player recorded in cursor.
+ modify (updateCursor (\ c -> c { creturnLn = nln }))
+ -- Bail out if anybody blocks the staircase.
+ inhabitants <- gets (locToActors nloc)
+ when (length inhabitants > 1) abort
+ -- The invariant "at most one movable on a tile" restored.
+ -- Create a backup of the savegame.
+ state <- get
+ liftIO $ Save.saveGame state >> Save.mvBkp (sconfig state)
+ playerAdvanceTime
_ -> -- no stairs
- do
+ if targeting
+ then do
+ lvlDescend (if vdir == Up then -1 else 1)
+ ln <- gets (lname . slevel)
+ let upd cursor = cursor { clocLn = ln }
+ modify (updateCursor upd)
+ doLook
+ else
let txt = if vdir == Up then "up" else "down"
- abortWith ("no stairs " ++ txt)
+ in abortWith ("no stairs " ++ txt)
-- | Hero has left the dungeon.
fleeDungeon :: Action ()
fleeDungeon =
do
- player@(Monster { mitems = items }) <- gets splayer
- let total = calculateTotal player
+ state <- get
+ let total = calculateTotal state
+ items = L.concatMap mitems (levelHeroList state)
if total == 0
then do
- messageMoreConfirm "Coward!"
- messageMoreConfirm "Next time try to grab some loot before you flee!"
+ go <- resetMessage >> messageMoreConfirm False "Coward!"
+ when go $
+ messageMore "Next time try to grab some loot before escape!"
end
else do
let winMsg = "Congratulations, you won! Your loot, worth " ++
show total ++ " gold, is:"
displayItems winMsg True items
go <- session getConfirm
- when go $ handleScores True False True total
+ when go $ do
+ go <- handleScores True H.Victor total
+ when go $ messageMore "Can it be done better, though?"
end
--- | Calculate loot's worth. TODO: move to another module, and refine significantly.
-calculateTotal :: Player -> Int
-calculateTotal player = L.sum $ L.map price $ mitems player
- where
- price i = if iletter i == Just '$' then icount i else 10 * icount i
-
--- | Handle current score and display it with the high scores. TODO: simplify. Scores
--- should not be shown during the game, because ultimately the worth of items might give
--- information about the nature of the items.
-handleScores :: Bool -> Bool -> Bool -> Int -> Action ()
-handleScores write killed victor total =
- unless (total == 0) $ do
- nm <- gets (lname . slevel)
- cfg <- gets sconfig
- time <- gets stime
- let points = if killed then (total + 1) `div` 2 else total
- let current = levelNumber nm -- TODO: rather use name of level
- curDate <- liftIO getClockTime
- let score = H.ScoreRecord
- points (-time) curDate current killed victor
- (placeMsg, slideshow) <- liftIO $ H.register cfg write score
- messageOverlaysConfirm placeMsg slideshow
- return ()
+-- | Switches current hero to the next hero on the level, if any, wrapping.
+cycleHero :: Action ()
+cycleHero =
+ do
+ pl <- gets splayer
+ hs <- gets (lheroes . slevel)
+ let i = case pl of AHero n -> n ; _ -> -1
+ (lt, gt) = IM.split i hs
+ case IM.keys gt ++ IM.keys lt of
+ [] -> abortWith "Cannot select another hero on this level."
+ ni : _ -> assertTrue $ selectPlayer (AHero ni)
-- | Search for secret doors
search :: Action ()
search =
do
- Level { lmap = lmap } <- gets slevel
- Monster { mloc = ploc } <- gets splayer
- let searchTile (Tile (Door hv (Just n)) x,t') = Just (Tile (Door hv (Just (max (n - 1) 0))) x, t')
- searchTile t = Just t
- slmap = foldl (\ l m -> update searchTile (shift ploc m) l) lmap moves
+ lmap <- gets (lmap . slevel)
+ ploc <- gets (mloc . getPlayerBody)
+ pitems <- gets (mitems . 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)))
-
--- | Look around at current location
-lookAround :: Action a
-lookAround =
+ playerAdvanceTime
+
+-- | Start the floor targeting mode or reset the cursor location to the player.
+targetFloor :: Action ()
+targetFloor = do
+ ploc <- gets (mloc . getPlayerBody)
+ target <- gets (mtarget . getPlayerBody)
+ targeting <- gets (ctargeting . scursor)
+ let tgt = case target of
+ _ | targeting -> TLoc ploc -- double key press: reset cursor
+ TEnemy _ _ -> TCursor -- forget enemy target, keep the cursor
+ t -> t -- keep the target from previous targeting session
+ updatePlayerBody (\ p -> p { mtarget = tgt })
+ setCursor tgt
+
+-- | Start the monster targeting mode. Cycle between monster targets.
+-- TODO: also target a monster by moving the cursor, if in target monster mode.
+-- TODO: sort monsters by distance to the player.
+targetMonster :: Action ()
+targetMonster = do
+ pl <- gets splayer
+ ms <- gets (lmonsters . slevel)
+ per <- currentPerception
+ target <- gets (mtarget . getPlayerBody)
+ targeting <- gets (ctargeting . scursor)
+ let i = case target of
+ TEnemy (AMonster n) _ | targeting -> n -- try next monster
+ TEnemy (AMonster n) _ -> n - 1 -- try to retarget old monster
+ _ -> -1 -- try to target first monster (e.g., number 0)
+ dms = case pl of
+ AMonster n -> IM.delete n ms -- don't target yourself
+ AHero _ -> ms
+ (lt, gt) = IM.split i dms
+ gtlt = IM.assocs gt ++ IM.assocs lt
+ lf = L.filter (\ (_, m) -> actorSeesLoc pl (mloc m) per (Just pl)) gtlt
+ tgt = case lf of
+ [] -> target -- no monsters in sight, stick to last target
+ (ni, nm) : _ -> TEnemy (AMonster ni) (mloc nm) -- pick the next
+ updatePlayerBody (\ p -> p { mtarget = tgt })
+ setCursor tgt
+
+-- | Set, activate and display cursor information.
+setCursor :: Target -> Action ()
+setCursor tgt = do
+ state <- get
+ per <- currentPerception
+ ploc <- gets (mloc . getPlayerBody)
+ ln <- gets (lname . slevel)
+ let upd cursor =
+ let cloc = case targetToLoc (ptvisible per) state of
+ Nothing -> ploc
+ Just l -> l
+ in cursor { ctargeting = True, clocation = cloc, clocLn = ln }
+ modify (updateCursor upd)
+ doLook
+
+-- | Perform look around in the current location of the cursor.
+-- TODO: depending on tgt, show extra info about tile or monster or both
+doLook :: Action ()
+doLook =
do
- state <- get
- let lvl@(Level { lmap = lmap }) = slevel state
- let Monster { mloc = ploc } = splayer state
- -- general info about current loc
- let lookMsg = lookAt True state lmap ploc
- -- check if there's something lying around at current loc
- let t = lmap `at` ploc
+ loc <- gets (clocation . scursor)
+ state <- get
+ lmap <- gets (lmap . slevel)
+ per <- currentPerception
+ target <- gets (mtarget . getPlayerBody)
+ let canSee = S.member loc (ptvisible per)
+ monsterMsg =
+ if canSee
+ then case L.find (\ m -> mloc m == loc) (levelMonsterList state) of
+ Just m -> subjectMovable (mkind m) ++ " is here. "
+ Nothing -> ""
+ else ""
+ mode = case target of
+ TEnemy _ _ -> "[targeting monster] "
+ TLoc _ -> "[targeting location] "
+ TCursor -> "[targeting current] "
+ -- general info about current loc
+ lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg
+ -- check if there's something lying around at current loc
+ t = lmap `at` loc
if length (titems t) <= 2
then do
- abortWith lookMsg
+ messageAdd lookMsg
else do
displayItems lookMsg False (titems t)
session getConfirm
- abortWith ""
+ messageAdd ""
--- | Display inventory
-inventory :: Action a
-inventory =
- do
- player <- gets splayer
- if L.null (mitems player)
- then abortWith "You are not carrying anything"
- else do
- displayItems "This is what you are carrying:" True (mitems player)
- session getConfirm
- abortWith ""
-
--- | Given item is now known to the player.
-discover :: Item -> Action ()
-discover i = modify (updateDiscoveries (S.insert (itype i)))
-
-drinkPotion :: Action ()
-drinkPotion =
- do
- state <- get
- let lvl @(Level { lmap = lmap }) = slevel state
- let player@(Monster { mloc = ploc }) = splayer state
- if L.null (mitems player)
- then abortWith "You are not carrying anything."
- else do
- i <- getPotion "What to drink?" (mitems player) "inventory"
- case i of
- Just i'@(Item { itype = Potion ptype }) ->
- do
- -- only one potion is consumed even if several are joined in the inventory
- let consumed = i' { icount = 1 }
- removeFromInventory consumed
- message (subjectVerbIObject state player "drink" consumed "")
- -- the potion is identified after drinking
- discover i'
- case ptype of
- PotionWater -> messageAdd "Tastes like water."
- PotionHealing -> do
- messageAdd "You feel better."
- modify (updatePlayer (\ p -> p { mhp = min (mhpmax p) (mhp p + playerHP `div` 4) }))
- Just _ -> abortWith "you cannot drink that"
- Nothing -> neverMind True
-
-dropItem :: Action ()
-dropItem =
- do
- state <- get
- let player@(Monster { mloc = ploc }) = splayer state
- if L.null (mitems player)
- then abortWith "You are not carrying anything."
- else do
- i <- getAnyItem "What to drop?" (mitems player) "inventory"
- case i of
- Just i' ->
- do
- removeFromInventory i'
- message (subjectVerbIObject state player "drop" i' "")
- dropItemsAt [i'] ploc
- Nothing -> neverMind True
-
-dropItemsAt :: [Item] -> Loc -> Action ()
-dropItemsAt is loc = modify (updateLevel (scatterItems is loc))
-
--- | Remove given item from the hero's inventory.
-removeFromInventory :: Item -> Action ()
-removeFromInventory i =
- modify (updatePlayer (\ p -> p { mitems = removeItemByLetter i (mitems p) }))
-
--- | Remove given item from the given location.
-removeFromLoc :: Item -> Loc -> Action ()
-removeFromLoc i loc =
- modify (updateLevel (\ l -> l { lmap = M.adjust (\ (t, rt) -> (update t, rt)) loc (lmap l) }))
- where
- update t = t { titems = removeItemByType i (titems t) }
-
--- | Let the player choose any potion. Note that this does not guarantee a potion to be chosen,
--- as the player can override the choice.
-getPotion :: String -> -- prompt
- [Item] -> -- all objects in question
- String -> -- how to refer to the collection of objects, e.g. "in your inventory"
- Action (Maybe Item)
-getPotion prompt is isn = getItem prompt (\ i -> case itype i of Potion {} -> True; _ -> False)
- "Potions" is isn
-
-actorPickupItem :: Actor -> Action ()
-actorPickupItem actor =
- do
- state <- get
- per <- currentPerception
- let lvl@(Level { lmap = lmap }) = slevel state
- let monster = getActor state actor
- let loc = mloc monster
- let t = lmap `at` loc -- the map tile in question
- let perceived = loc `S.member` pvisible per
- let isPlayer = actor == APlayer
- -- check if something is here to pick up
- case titems t of
- [] -> abortIfWith isPlayer "nothing here"
- (i:rs) -> -- pick up first item; TODO: let player select item; not for monsters
- case assignLetter (iletter i) (mletter monster) (mitems monster) of
- Just l ->
- do
- let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems monster)
- -- message is dependent on who picks up and if the hero can perceive it
- if isPlayer
- then message (letterLabel (iletter ni) ++ objectItem state (icount ni) (itype ni))
- else when perceived $
- message $ subjectCompoundVerbIObject state monster "pick" "up" i ""
- removeFromLoc i loc
- -- add item to actor's inventory:
- updateActor actor $ \ m ->
- m { mitems = nitems, mletter = maxLetter l (mletter monster) }
- Nothing -> abortIfWith isPlayer "you cannot carry any more"
-
--- | Replaces the version in Actor module
-updateActor :: Actor -> -- ^ who to update
- (Monster -> Monster) -> -- ^ the update
- Action ()
-updateActor (AMonster n) f =
- do
- monsters <- gets (lmonsters . slevel)
- let (m, ms) = updateMonster f n monsters
- modify (updateLevel (updateMonsters (const ms)))
-updateActor APlayer f =
- modify (updatePlayer f)
-
-pickupItem :: Action ()
-pickupItem = actorPickupItem APlayer
-
--- TODO: I think that player handlers should be wrappers around more general actor handlers, but
--- the actor handlers should be performing specific actions, i.e., already specify the item to be
--- picked up. It doesn't make sense to invoke dialogues for arbitrary actors, and most likely the
--- decision for a monster is based on perceiving a particular item to be present, so it's already
--- known. In actor handlers we should make sure that messages are printed to the player only if the
--- hero can perceive the action.
-
--- | Let the player choose any item from a list of items.
-getAnyItem :: String -> -- prompt
- [Item] -> -- all objects in question
- String -> -- how to refer to the collection of objects, e.g. "in your inventory"
- Action (Maybe Item)
-getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn
-
--- | Let the player choose a single item from a list of items.
-getItem :: String -> -- prompt message
- (Item -> Bool) -> -- which items to consider suitable
- String -> -- how to describe suitable objects
- [Item] -> -- all objects in question
- String -> -- how to refer to the collection of objects, e.g. "in your inventory"
- Action (Maybe Item)
-getItem prompt p ptext is0 isn =
- let is = L.filter p is0
- choice | L.null is = "[*]"
- | otherwise = "[" ++ letterRange (concatMap (maybeToList . iletter) is) ++ " or ?*]"
- r = do
- message (prompt ++ " " ++ choice)
- display
- let h = session nextCommand >>= h'
- h' e = case e of
- K.Char '?' -> do
- -- filter for supposedly suitable objects
- b <- displayItems (ptext ++ " " ++ isn) True is
- if b then session (getOptionalConfirm (const r) h')
- else r
- K.Char '*' -> do
- -- show all objects
- b <- displayItems ("Objects " ++ isn) True is0
- if b then session (getOptionalConfirm (const r) h')
- else r
- K.Char l -> return (find (\ i -> maybe False (== l) (iletter i)) is0)
- _ -> return Nothing
- h
- in r
-
-displayItems :: Message -> Bool -> [Item] -> Action Bool
-displayItems msg sorted is =
- do
- state <- get
- let inv = unlines $
- L.map (\ (Item { icount = c, iletter = l, itype = t }) ->
- letterLabel l ++ objectItem state c t ++ " ")
- ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)
- let ovl = inv ++ more
- message msg
- overlay ovl
-
--- | This function performs a move (or attack) by any actor, i.e., it can handle
--- both monsters and the player.
+-- | This function performs a move (or attack) by any actor,
+-- i.e., it can handle monsters, heroes and both.
moveOrAttack :: Bool -> -- allow attacks?
Bool -> -- auto-open doors on move
Actor -> -- who's moving?
@@ -498,96 +509,129 @@ moveOrAttack :: Bool -> -- allow attacks?
Action ()
moveOrAttack allowAttacks autoOpen actor dir
| dir == (0,0) =
- -- Moving with no direction is a noop. We include it currently to prevent that
+ -- Moving with no direction is a noop.
+ -- We include it currently to prevent that
-- monsters attack themselves by accident.
- return ()
- | otherwise =
- do
+ advanceTime actor
+ | otherwise = do
-- We start by looking at the target position.
state <- get
- let lvl@(Level { lmap = lmap }) = slevel state
- let player = splayer state
- let monster = getActor state actor
- let loc = mloc monster -- current location
- let s = lmap `at` loc -- tile at current location
- let nloc = loc `shift` dir -- target location
- let t = lmap `at` nloc -- tile at target location
- let attackedPlayer = [ APlayer | mloc player == nloc ]
- let attackedMonsters = L.map AMonster $
- findIndices (\ m -> mloc m == nloc) (lmonsters lvl)
- let attacked :: [Actor]
- attacked = attackedPlayer ++ attackedMonsters
- -- At the moment, we check whether there is a monster before checking accessibility
- -- i.e., we can attack a monster on a blocked location. For instance,
- -- a monster on an open door can be attacked diagonally, and a
- -- monster capable of moving through walls can be attacked from an
- -- adjacent position.
- if not (L.null attacked)
- then if not allowAttacks then abort else do
- -- perform the attack
- mapM_ (actorAttackActor actor) attacked
- else if accessible lmap loc nloc then do
- -- perform the move
- updateActor actor (\ m -> m { mloc = nloc })
- when (actor == APlayer) $ message $ lookAt False state lmap nloc
- -- TODO: seems somewhat dubious to do this here, but perhaps it's ok
- else if autoOpen then
- -- try to check if there's a door we can open
- actorOpenClose actor False True dir
- else abort -- nothing useful we can do
-
+ pl <- gets splayer
+ lmap <- gets (lmap . slevel)
+ sm <- gets (getActor actor)
+ let sloc = mloc sm -- source location
+ tloc = sloc `shift` dir -- target location
+ tgt <- gets (locToActor tloc)
+ case tgt of
+ Just target ->
+ if allowAttacks then
+ -- Attacking does not require full access, adjacency is enough.
+ actorAttackActor actor target
+ else if accessible lmap sloc tloc then do
+ -- Switching positions requires full access.
+ actorRunActor actor target
+ when (actor == pl) $
+ messageAdd $ lookAt False True state lmap tloc ""
+ else abortWith ""
+ Nothing ->
+ if accessible lmap sloc tloc then do
+ -- perform the move
+ updateAnyActor actor $ \ m -> m { mloc = tloc }
+ when (actor == pl) $
+ messageAdd $ lookAt False True state lmap tloc ""
+ advanceTime actor
+ else if allowAttacks && actor == pl
+ && canBeDoor (lmap `rememberAt` tloc) then do
+ messageAdd "You search your surroundings." -- TODO: proper msg
+ search
+ else if autoOpen then
+ -- try to open a door
+ actorOpenClose actor False True dir
+ else abortWith ""
+
+-- | Resolves the result of an actor moving into another. Usually this
+-- involves melee attack, but with two heroes it just changes focus.
+-- Movables on blocked locations can be attacked without any restrictions.
+-- For instance, a movable on an open door can be attacked diagonally,
+-- and a movable capable of moving through walls can be attacked from an
+-- adjacent position.
+-- This function is analogous to zapGroupItem, but for melee
+-- and not using up the weapon.
actorAttackActor :: Actor -> Actor -> Action ()
-actorAttackActor source target =
- do
- debug "actorAttackActor"
- state <- get
- let sm = getActor state source
- let tm = getActor state target
- -- determine the weapon used for the attack
- let sword = strongestSword (mitems sm)
- -- damage the target
- let newHp = mhp tm - 3 - sword
- let killed = newHp <= 0
- updateActor target $ \ m ->
- if killed
- then m { mhp = 0, mtime = 0 } -- grant an immediate move to die
- -- TODO: is there a good reason not to let the monster die just here?
- else m { mhp = newHp }
- -- determine how the hero perceives the event; TODO: we have to be more
- -- precise and treat cases where two monsters fight, but only one is visible
- let combatVerb = if killed && target /= APlayer then "kill" else "hit"
- let swordMsg = if sword == 0 then "" else
- " with a (+" ++ show sword ++ ") sword" -- TODO: generate proper message
- let combatMsg = subjectVerbMObject state sm combatVerb tm swordMsg
- per <- currentPerception
- let perceived = mloc sm `S.member` pvisible per
- messageAdd $
- if perceived
- then combatMsg
- else "You hear some noises."
+actorAttackActor (AHero _) target@(AHero _) =
+ -- Select adjacent hero by bumping into him. Takes no time.
+ assertTrue $ selectPlayer target
+actorAttackActor source target = do
+ state <- get
+ sm <- gets (getActor source)
+ tm <- gets (getActor target)
+ per <- currentPerception
+ let groupName = "sword"
+ verb = attackToVerb groupName
+ sloc = mloc sm
+ swordKindIndex = fromJust $ L.elemIndex ItemKind.sword ItemKind.loot
+ -- The hand-to-hand "weapon", equivalent to +0 sword.
+ h2h = Item swordKindIndex 0 Nothing 1
+ str = strongestItem (mitems sm) groupName
+ stack = fromMaybe h2h str
+ single = stack { icount = 1 }
+ -- The message describes the source part of the action.
+ -- TODO: right now it also describes the victim and weapon;
+ -- perhaps, when a weapon is equipped, just say "you hit" or "you miss"
+ -- and then "nose dies" or "nose yells in pain".
+ msg = subjectVerbMObject sm verb tm $
+ if isJust str then " with " ++ objectItem state single else ""
@kosmikus Owner

Make combat messages less verbose.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
+ when (sloc `S.member` ptvisible per) $ messageAdd msg
+ -- Messages inside itemEffectAction describe the target part.
+ itemEffectAction source target single
+ advanceTime source
+
+attackToVerb :: String -> String
+attackToVerb "sword" = "hit" -- TODO: "slash"? "pierce"? "swing"?
+attackToVerb "mace" = "bludgeon"
+attackToVerb _ = "hit"
+
+-- | Resolves the result of an actor running into another.
+-- This involves switching positions of the two movables.
+actorRunActor :: Actor -> Actor -> Action ()
+actorRunActor source target = do
+ pl <- gets splayer
+ sloc <- gets (mloc . getActor source) -- source location
+ tloc <- gets (mloc . getActor target) -- target location
+ updateAnyActor source $ \ m -> m { mloc = tloc }
+ updateAnyActor target $ \ m -> m { mloc = sloc }
+ if source == pl
+ then stopRunning -- do not switch positions repeatedly
+ else if isAMonster source
+ then focusIfAHero target
+ else return ()
+ advanceTime source
-- | Generate a monster, possibly.
generateMonster :: Action ()
generateMonster =
+ do -- TODO: simplify
+ state <- get
+ nstate <- liftIO $ rndToIO $ rollMonster state
+ modify (const nstate)
+
+-- | Possibly regenerate HP for all movables on the current level.
+regenerateLevelHP :: Action ()
+regenerateLevelHP =
do
- lvl <- gets slevel
- player <- gets splayer
- nlvl <- liftIO $ rndToIO $ addMonster lvl player
- modify (updateLevel (const nlvl))
-
--- | Advance the move time for the given actor.
-advanceTime :: Actor -> Action ()
-advanceTime actor =
- do
- time <- gets stime
- updateActor actor (\ m -> m { mtime = time + mspeed m })
-
--- | Possibly regenerate HP for the given actor.
-regenerate :: Actor -> Action ()
-regenerate actor =
- do
- time <- gets stime
- -- TODO: remove hardcoded time interval, regeneration should be an attribute of the monster
- when (time `mod` 1500 == 0) $
- updateActor actor (\ m -> m { mhp = min (mhpmax m) (mhp m + 1) })
-
+ time <- gets stime
+ let upd m =
+ let regen = nregen (mkind m) `div`
+ case strongestItem (mitems m) "amulet" of
+ Just i -> ipower i
+ Nothing -> 1
+ in if time `mod` regen /= 0
+ then m
+ else m { mhp = min (nhpMax (mkind m)) (mhp m + 1) }
+ -- We really want hero selection to be a purely UI distinction,
+ -- so all heroes need to regenerate, not just the player.
+ -- Only the heroes on the current level regenerate (others are frozen
+ -- in time together with their level). This prevents cheating
+ -- via sending one hero to a safe level and waiting there.
+ modify (updateLevel (updateHeroes (IM.map upd)))
+ modify (updateLevel (updateMonsters (IM.map upd)))
View
35 src/Actor.hs
@@ -1,35 +0,0 @@
-module Actor where
-
-import Level
-import Monster
-import State
-
-data Actor = AMonster Int -- offset in monster list
- | APlayer
- deriving (Show, Eq)
-
-getActor :: State -> Actor -> Monster
-getActor (State { slevel = lvl, splayer = p }) a =
- case a of
- AMonster n -> lmonsters lvl !! n
- APlayer -> p
-
-updateActor :: (Monster -> Monster) -> -- the update
- (Monster -> State -> IO a) -> -- continuation
- Actor -> -- who to update
- State -> IO a -- transformed continuation
-updateActor f k (AMonster n) state@(State { slevel = lvl, splayer = p }) =
- let (m,ms) = updateMonster f n (lmonsters lvl)
- in k m (updateLevel (updateMonsters (const ms)) state)
-updateActor f k APlayer state@(State { slevel = lvl, splayer = p }) =
- k p (updatePlayer f state)
-
-updateMonster :: (Monster -> Monster) -> Int -> [Monster] ->
- (Monster, [Monster])
-updateMonster f n ms =
- case splitAt n ms of
- (pre, x : post) -> let m = f x
- mtimeChanged = mtime x /= mtime m
- in (m, if mtimeChanged then snd (insertMonster m (pre ++ post))
- else pre ++ [m] ++ post)
- xs -> error "updateMonster"
View
119 src/Color.hs
@@ -0,0 +1,119 @@
+module Color where
+
+import Control.Monad
+import qualified Data.Binary as Binary
+
+data Color =
+ Black
+ | Red
+ | Green
+ | Yellow
+ | Blue
+ | Magenta
+ | Cyan
+ | White
+ | BrBlack
+ | BrRed
+ | BrGreen
+ | BrYellow
+ | BrBlue
+ | BrMagenta
+ | BrCyan
+ | BrWhite
+ deriving (Show, Eq, Ord, Enum, Bounded)
+
+instance Binary.Binary Color where
+ put = Binary.putWord8 . fromIntegral . fromEnum
+ get = liftM (toEnum . fromIntegral) Binary.getWord8
+
+defBG, defFG :: Color
+defBG = Black
+defFG = White
+
+type Attr = (Color.Color, Color.Color)
+defaultAttr :: Attr
+defaultAttr = (Color.defFG, Color.defBG)
+
+isBright :: Color -> Bool
+isBright c = fromEnum c > 7 -- for terminals that display bright via bold
+
+-- | Due to limitation of curses, only these are legal backgrounds.
+legalBG :: [Color]
+legalBG = [Black, White, Blue, Magenta]
+
+-- Heavily modified Linux console colors.
+colorToRGB :: Color -> String
+colorToRGB Black = "#000000"
+colorToRGB Red = "#D50000"
+colorToRGB Green = "#00AA00"
+colorToRGB Yellow = "#AA5500" -- brown
+colorToRGB Blue = "#203AF0"
+colorToRGB Magenta = "#AA00AA"
+colorToRGB Cyan = "#00AAAA"
+colorToRGB White = "#BEBABA"
+colorToRGB BrBlack = "#6A6565"
+colorToRGB BrRed = "#FF5555"
+colorToRGB BrGreen = "#75FF45"
+colorToRGB BrYellow = "#FFE855"
+colorToRGB BrBlue = "#4090FF"
+colorToRGB BrMagenta = "#FF77FF"
+colorToRGB BrCyan = "#60FFF0"
+colorToRGB BrWhite = "#FFFFFF"
+
+-- For reference, the original Linux console colors.
+-- Good old retro feel and more useful than xterm (e.g. brown).
+colorToRGB' :: Color -> String
+colorToRGB' Black = "#000000"
+colorToRGB' Red = "#AA0000"
+colorToRGB' Green = "#00AA00"
+colorToRGB' Yellow = "#AA5500" -- brown
+colorToRGB' Blue = "#0000AA"
+colorToRGB' Magenta = "#AA00AA"
+colorToRGB' Cyan = "#00AAAA"
+colorToRGB' White = "#AAAAAA"
+colorToRGB' BrBlack = "#555555"
+colorToRGB' BrRed = "#FF5555"
+colorToRGB' BrGreen = "#55FF55"
+colorToRGB' BrYellow = "#FFFF55"
+colorToRGB' BrBlue = "#5555FF"
+colorToRGB' BrMagenta = "#FF55FF"
+colorToRGB' BrCyan = "#55FFFF"
+colorToRGB' BrWhite = "#FFFFFF"
+
+-- Human-readable names, for item descriptions. The simple set.
+colorToName :: Color -> String
+colorToName Black = "black"
+colorToName Red = "red"
+colorToName Green = "green"
+colorToName Yellow = "brown"
+colorToName Blue = "blue"
+colorToName Magenta = "purple"
+colorToName Cyan = "cyan"
+colorToName White = "ivory"
+colorToName BrBlack = "gray"
+colorToName BrRed = "coral"
+colorToName BrGreen = "lime"
+colorToName BrYellow = "yellow"
+colorToName BrBlue = "azure"
+colorToName BrMagenta = "pink"
+colorToName BrCyan = "aquamarine"
+colorToName BrWhite = "white"
+
+-- The fancy set.
+colorToName' :: Color -> String
+colorToName' Black = "smoky black"
+colorToName' Red = "apple red"
+colorToName' Green = "forest green"
+colorToName' Yellow = "mahogany"
+colorToName' Blue = "royal blue"
+colorToName' Magenta = "indigo"
+colorToName' Cyan = "teal"
+colorToName' White = "silver gray"
+colorToName' BrBlack = "charcoal"
+colorToName' BrRed = "salmon"
+colorToName' BrGreen = "emerald"
+colorToName' BrYellow = "amber"
+colorToName' BrBlue = "sky blue"
+colorToName' BrMagenta = "magenta"
+colorToName' BrCyan = "turquoise"
+colorToName' BrWhite = "ghost white"
View
35 src/Command.hs
@@ -2,9 +2,10 @@ module Command where
import Action
import Actions
+import ItemAction
import Geometry
-import qualified Keys as K
import Level
+import Version
data Described a = Described { chelp :: String, caction :: a }
| Undescribed { caction :: a }
@@ -12,21 +13,29 @@ data Described a = Described { chelp :: String, caction :: a }
type Command = Described (Action ())
type DirCommand = Described (Dir -> Action ())
-closeCommand = Described "close a door" (openclose False)
-openCommand = Described "open a door" (openclose True)
-pickupCommand = Described "pick up an object" pickupItem
-dropCommand = Described "drop an object" dropItem
+closeCommand = Described "close a door" (checkCursor (openclose False))
+openCommand = Described "open a door (or bump into a door)" (checkCursor (openclose True))
+pickupCommand = Described "get an object" (checkCursor pickupItem)
+dropCommand = Described "drop an object" (checkCursor dropItem)
inventoryCommand = Described "display inventory" inventory
-searchCommand = Described "search for secret doors" search
-ascendCommand = Described "ascend a level" (lvlchange Up)
-descendCommand = Described "descend a level" (lvlchange Down)
-lookCommand = Described "look around" lookAround
-drinkCommand = Described "quaff a potion" drinkPotion
-waitCommand = Described "wait" (return () :: Action ())
-saveCommand = Described "save and quit the game" saveGame
+searchCommand = Described "search for secret doors (or bump)" (checkCursor search)
+ascendCommand = Described "ascend a level" (lvlChange Up)
+descendCommand = Described "descend a level" (lvlChange Down)
+floorCommand = Described "target location" targetFloor
+monsterCommand = Described "target monster" (checkCursor targetMonster)
+quaffCommand = Described "quaff a potion" (checkCursor quaffPotion)
+readCommand = Described "read a scroll" (checkCursor readScroll)
+throwCommand = Described "throw a weapon" (checkCursor throwItem)
+aimCommand = Described "aim a wand" (checkCursor aimItem)
+waitCommand = Described "wait" playerAdvanceTime
+saveCommand = Described "save and exit the game" saveGame
quitCommand = Described "quit without saving" quitGame
+cancelCommand = Described "cancel action" cancelCurrent
+acceptCommand h = Described "accept choice" (acceptCurrent h)
historyCommand = Described "display previous messages" displayHistory
+dumpCommand = Described "dump current configuration" dumpConfig
+heroCommand = Described "cycle among heroes on level" cycleHero
+versionCommand = Described "display game version" (abortWith version)
moveDirCommand = Described "move in direction" move
runDirCommand = Described "run in direction" run
-
View
118 src/Config.hs
@@ -1,71 +1,113 @@
-module Config where
+module Config
+ (CP, defaultCP, config, getOption, getItems, get, getFile, dump) where
import System.Directory
import System.FilePath
+import System.IO
import Control.Monad.Error
-import Data.ConfigFile
+import qualified Data.ConfigFile as CF
import Data.Either.Utils
import Data.Maybe
-import qualified Data.Binary as B
+import qualified Data.Binary as Binary
-newtype CP = CP ConfigParser
+import qualified ConfigDefault
-instance B.Binary CP where
- put (CP config) = B.put $ to_string config
+newtype CP = CP CF.ConfigParser
+
+instance Binary.Binary CP where
+ put (CP config) = Binary.put $ CF.to_string config
get = do
- string <- B.get
- let parsed = readstring emptyCP string
- return $ CP $ forceEither $ parsed
+ string <- Binary.get
+ -- use config in case savegame is from older version and lacks some options
+ let c = CF.readstring defCF string
+ return $ toCP $ forceEither c
instance Show CP where
- show (CP config) = show $ to_string config
+ show (CP config) = show $ CF.to_string config
+
+-- | 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
--- | Underscore in the name to avoid name clash.
-empty_CP :: CP
-empty_CP = CP emptyCP
+toCP :: CF.ConfigParser -> CP
+toCP cp = CP $ toSensitive cp
--- | Path to the main configuration file.
-file :: IO String
+defaultCP :: CP
+defaultCP = toCP defCF
+
+-- | Path to the user configuration file.
+file :: IO FilePath
file =
do
appData <- getAppUserDataDirectory "LambdaHack"
- return $ combine appData "LambdaHack.config"
+ return $ combine appData "config"
--- | The configuration read from the main configuration file.
--- If no such file, generate empty configuration.
+-- | The configuration read from the user configuration file.
+-- The default configuration file provides underlying defaults
+-- in case some options, or the whole file, are missing.
config :: IO CP
config =
+ -- evaluate, to catch config errors ASAP
+ defCF `seq`
do
f <- file
b <- doesFileExist f
if not b
- then return $ empty_CP
+ then return $ toCP $ defCF
else do
- c <- readfile emptyCP f
- return $ CP (forceEither c)
+ c <- CF.readfile defCF f
+ return $ toCP $ forceEither c
-- | A simplified access to an option in a given section,
-- with simple error reporting (no error is caught and hidden).
-- If there is no config file or no such option, gives Nothing.
-getOption :: Get_C a => CP -> SectionSpec -> OptionSpec ->
- Maybe a
+getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a
getOption (CP config) s o =
- do
- if has_option config s o
- then let val = get config s o
- valForced = forceEither val
- in Just valForced
- else Nothing
-
--- | Looks up a file path in the config file, faling back to the default path.
--- The path from the config file is taken relative to the home directory
--- and the default is taken relative to the current directory. In any case,
--- the returned path is absolute.
-getFile :: CP -> FilePath -> SectionSpec -> OptionSpec -> IO FilePath
-getFile config dflt s o =
+ 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 = getOption config s o
- return $ maybe (combine current dflt) (combine appData) path
+ let path = get config s o
+ appPath = combine appData path
+ curPath = combine current path
+ b <- doesDirectoryExist appData
+ return $ if b then appPath else curPath
+
+dump :: FilePath -> CP -> IO ()
+dump fn (CP config) =
+ do
+ current <- getCurrentDirectory
+ let path = combine current fn
+ dump = CF.to_string config
+ writeFile path dump
View
19 src/ConfigDefault.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP, QuasiQuotes #-}
+
+module ConfigDefault (configDefault) where
+
+import Multiline
+
+-- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?)
+-- as soon as the config file grows very big.
+
+-- | The string containing the default configuration
+-- included from file src/config.default.
+-- Warning: cabal does not detect that the default config is changed,
+-- so touching this file is needed to reinclude config and recompile.
+configDefault :: String
+configDefault = [$multiline|
+
+#include "config.default"
+
+|]
View
199 src/Display.hs
@@ -1,14 +1,205 @@
{-# LANGUAGE CPP #-}
-module Display (module D) where
+module Display where
-- wrapper for selected Display frontend
#ifdef CURSES
-import Display.Curses as D
+import qualified Display.Curses as D
#elif GTK
-import Display.Gtk as D
+import qualified Display.Gtk as D
#else
-import Display.Vty as D
+import qualified Display.Vty as D
#endif
+-- Display routines that are independent of the selected display frontend.
+
+import qualified Data.Char as Char
+import Data.Set as S
+import Data.List as L
+import Data.Map as M
+import qualified Data.IntMap as IM
+import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2
+import Data.Maybe
+
+import Message
+import qualified Color
+import State
+import Geometry
+import Level
+import LevelState
+import Dungeon
+import Perception
+import Movable
+import MovableState
+import MovableKind
+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)
+
+displayLevel ::
+ Bool -> Session -> Perceptions -> State -> Message -> Maybe String -> IO Bool
+displayLevel
+ blackAndWhite session per
+ (state@(State { scursor = cursor,
+ stime = time,
+ sassocs = assocs,
+ slevel = Level ln _ (sy, sx) _ smap lmap _ }))
+ msg moverlay =
+ let Movable { mkind = MovableKind { nhpMax = xhp },
+ mhp = php, mloc = ploc, mitems = pitems } = getPlayerBody state
+ reachable = ptreachable per
+ visible = ptvisible per
+ overlay = fromMaybe "" moverlay
+ (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed
+ sSml = ssensory state == Smell
+ sVis = case ssensory state of Vision _ -> True; _ -> False
+ sOmn = sdisplay state == Omniscient
+ 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
+ viewMovable loc (Movable { mkind = mk })
+ | loc == ploc && ln == creturnLn cursor =
+ (nsymbol mk, Color.defBG) -- highlight player
+ | otherwise = (nsymbol mk, ncolor mk)
+ viewSmell :: Int -> Char
+ viewSmell n
+ | n > 9 = '*'
+ | n < 0 = '-'
+ | otherwise = Char.intToDigit n
+ rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1)
+ (char, fg) =
+ case L.find (\ m -> loc == mloc m) (hs ++ ms) of
+ _ | sTer > 0 -> Terrain.viewTerrain sTer False (tterrain tile)
+ Just m | sOmn || vis -> viewMovable loc m
+ _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc)
+ | otherwise -> viewTile vis tile assocs
+ vis = S.member loc visible
+ rea = S.member loc reachable
+ bg = if ctargeting cursor && loc == clocation cursor
+ then Color.defFG -- highlight targeting cursor
+ else sVisBG vis rea -- FOV debug
+ reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)
+ optVisually (fg, bg) =
+ if fg == Color.defBG
+ then reverseVideo
+ else if bg == Color.defFG && fg == Color.defFG
+ then reverseVideo
+ else (fg, bg)
+ a = if blackAndWhite
+ then Color.defaultAttr
+ else optVisually (fg, bg)
+ in case over (loc `shift` ((sy+1) * n, 0)) of
+ Just c -> (Color.defaultAttr, c)
+ _ -> (a, char)
+ status =
+ take 30 (levelName ln ++ repeat ' ') ++
+ take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') ++
+ take 10 ("$: " ++ show wealth ++ repeat ' ') ++
+ take 10 ("Dmg: " ++ show damage ++ repeat ' ') ++
+ take 20</