diff --git a/Allure.cabal b/Allure.cabal new file mode 100644 --- /dev/null +++ b/Allure.cabal @@ -0,0 +1,69 @@ +cabal-version: >= 1.6 +name: Allure +version: 0.4.1 +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.0.3 +data-files: LICENSE, CREDITS, PLAYING.markdown, + README.markdown, src/config.default, scores +author: Andres Loeh, Mikolaj Konarski and others +maintainer: Mikolaj Konarski +description: This is an alpha prerelease of Allure of the Stars, + a near-future Sci-Fi roguelike and tactical squad game. + Long term goals are high replayability and auto-balancing + through procedural content generation and persistent content + modification based on player behaviour. + The game is based on the LambdaHack roguelike game engine, +synopsis: Near-future roguelike game in early development +homepage: http://github.com/Mikolaj/Allure +category: Game +build-type: Simple + +flag curses + description: enable curses support + default: False + +flag vty + description: enable vty support + default: False + +executable Allure + main-is: Main.hs + hs-source-dirs:src + other-modules: Action, Actions, Color, Command, Config, ConfigDefault, + Display, Dungeon, DungeonState, Effect, EffectAction, File, + FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow, + Frequency, Geometry, GeometryRnd, Grammar, + HighScores, Item, ItemKind, ItemAction, + Keys, Keybindings, Level, LevelState, + Main, Message, MovableAdd, MovableKind, Movable, MovableState, + Multiline, Perception, Random, + Save, State, Strategy, StrategyState, + Tile, Turn, Terrain, Version, WorldLoc + build-depends: base >= 4 && < 5, containers >= 0.1 && < 1, + binary >= 0.4 && < 1, + random >= 1 && < 2, zlib >= 0.4 && < 1, + bytestring >= 0.9 && < 1, directory >= 1 && < 2, + mtl >= 1.1 && < 3, old-time, ConfigFile >= 1.0.6 && < 2, + MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 2, + template-haskell >= 2.5 + extensions: CPP, FlexibleContexts, QuasiQuotes, MultiParamTypeClasses, + RankNTypes, BangPatterns + if flag(curses) { + other-modules: Display.Curses + build-depends: hscurses >= 1.3 && < 2 + cpp-options: -DCURSES + extra-libraries: curses + } else { if flag(vty) { + other-modules: Display.Vty + build-depends: vty >= 4.4 + } else { + other-modules: Display.Gtk + build-depends: gtk >= 0.11 && < 0.13 + cpp-options: -DGTK + ghc-options: -threaded + } } + +Source-repository head + type: git + location: git://github.com/Mikolaj/Allure.git diff --git a/CREDITS b/CREDITS new file mode 100644 --- /dev/null +++ b/CREDITS @@ -0,0 +1,6 @@ +All kinds of contributions to Allure of the Stars are gratefully welcome! +Some of the contributors are listed below, in chronological order. + +Andres Loeh +Mikolaj Konarski +Krzysztof Pławski diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2008--2011 Andres Loeh +Copyright (c) 2010--2011 Mikolaj Konarski + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/PLAYING.markdown b/PLAYING.markdown new file mode 100644 --- /dev/null +++ b/PLAYING.markdown @@ -0,0 +1,152 @@ +Playing Allure of the Stars +=========================== + +Playing Allure of the Stars involves walking around the dungeon +(err, a Solar System space-ship that incidentally closely resembles +a fantasy dungeon, in this prerelease version of the game), +alone or in a party of fearless adventurers, jumping between levels, +bumping into monsters, doors and walls, gathering magical treasure +and making creative use of it. The bloodthirsty monsters do the same, +intelligence allowing, while tirelessly chasing the noble heroes +by smell and night-sight. + +Once the few basic command keys and on-screen symbols are learned, +mastery and enjoyment of the game is the matter of tactical skill +and literary imagination. To be honest, you need a lot of imagination +right now, since the game is still quite basic, though playable and winnable. +Contributions welcome. + + +Dungeon +------- + +The goal of the hero is to explore the dungeon, battle the horrors within, +gather as much gold and gems as possible, and escape to tell the tale. +The dungeon consists of 10 levels and each level consists of 80 by 21 tiles. +The basic tiles are as follows. + + dungeon terrain type on-screen symbol + floor . + wall # + stairs up < + stairs down > + open door ' + closed door + + +The game world is persistent, i. e., every time a hero visits a level +during a single game, the level layout looks the same. Some items +aid in dungeon exploration, e.g., a ring of searching improves the speed +of finding hidden doors by heroes and monsters. The higher the magical +bonus displayed for this and other dungeon items, the more effective it is. +Only the best item carried in a hero's or monster's inventory counts. +You can throw the rest away, but beware that your adversaries may pick it up +and use it against you. + + +Keys +---- + +Below are the basic default keys. + + key command + . wait + < ascend a level + > descend a level + ? display help + Q quit without saving + X save and exit the game + c close a door + d drop an object + g get an object + i display inventory + o open a door (alternatively, you can bump into a door) + q quaff a potion + r read a scroll + s search for secret doors (or you can bump into a wall) + +One of the ways of moving throughout the level is with the vi text editor keys +(also known as "Rogue-like keys"). + + key command + k up + j down + h left + l right + y up-left + u up-right + b down-left + n down-right + +Pressing a capital letter corresponding to a direction key will have +the hero run in that direction until something interesting occurs. + +It is also possible to move using the numerical keypad, with Shift for running +and the middle '5' key for waiting. (If you are using the curses frontend, +numerical keypad may not work correctly for terminals with broken terminfo, +e.g., gnome terminal has problems, while xterm works fine.) + +To make a distance attack, you need to set your target first. +The targeting commands are listed below, together with all the other +less common player commands. + + key command + ESC cancel action + RET accept choice + TAB cycle among heroes on level + 0--9 select a hero anywhere in the dungeon (gtk only) + * target monster + / target location + D dump current configuration + P display previous messages + V display game version + a aim a wand + t throw a weapon + +There are also some debug and cheat keys. Use at your peril! + + key command + O toggle "omniscience" + I inform about level meta-data + R rotate display modes + + +Monsters +-------- + +The hero is not alone in the dungeon. Monsters roam the dark caves +and crawl from damp holes day and night. While heroes pay attention +to all other party members and take moves sequentially, one after another, +monsters don't care about each other and all move at once, +sometimes brutally colliding by mistake. + +When the hero bumps into a monster or a monster attacks the hero, +melee combat occurs. The best weapon carried by each opponent +is taken into account for calculating bonus damage. The total damage +the current hero can potentially inflict is displayed at the bottom +of the screen. The total damage potential of a monster may change +as it finds and picks up new weapons. Heroes and monsters running +into another (with the Shift key) do not inflict damage, but change places. +This gives the opponent a free blow, but can improve the tactical situation +or aid escape. + +Throwing weapons at targets wounds them, consuming the weapon in the process. +You can target a monster with the '*' key from the top row or numpad. +You may throw any object in your possession +(press '*' for a non-standard choice) or on the floor (press '-'), +though only objects of a few kinds inflict any damage. +Whenever a monster or a hero hit points reach zero, the combatant dies. +When the last hero dies, the game ends. + + +On Winning and Dying +-------------------- + +You win the game if you escape the dungeon alive. Your score is +the sum of all gold you've plundered plus 100gp for each gem. +Only the loot in possession of the party members on level 1 counts +(the rest is considered MIA). + +If all heroes die, your score is halved and only the treasure carried +by the last standing hero counts. You are free to start again +from the first level of the dungeon, but all your wealth and items +are gone and the dungeon and it's treasure look differently. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,58 @@ +Allure of the Stars +=================== + +This is an alpha prerelease of Allure of the Stars, +a near-future Sci-Fi [roguelike] [1] and tactical squad game. +Long term goals are high replayability and auto-balancing +through procedural content generation and persistent content +modification based on player behaviour. +The game is written in [Haskell] [2] and based +on the [LambdaHack roguelike engine] [3], + + +Compilation and installation +---------------------------- + +The game is best compiled and installed via Cabal, which also takes care +of all dependencies. The latest official version of the game can be downloaded +automatically by Cabal from [Hackage] [4] as follows + + cabal install Allure + +For a more current snapshot, download the source from [github] [5] +and run Cabal from the main directory + + cabal install + +The best frontend (keyboard support and colours) is gtk, +but if needed, you may try one of the terminal frontends with, e.g, + + cabal install -fvty + + +Savegame directory +------------------ + +If you don't want Allure of the Stars to write to the current directory, +create a personal savegame directory (on Linux it's ~/.Allure/). +and copy the scores file there. You may also want to +copy the configuration file src/config.default to +~/.Allure/config and modify it, but be careful changing +gameplay options --- they can easily unbalance or break the game. + + +Further information +------------------- + +For more information, visit the wiki at https://github.com/Mikolaj/Allure/wiki +and see the files PLAYING.markdown, CREDITS and LICENSE. + +Have fun! + + + +[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation +[2]: http://www.haskell.org/ +[3]: http://github.com/kosmikus/LambdaHack +[4]: http://hackage.haskell.org/package/Allure +[5]: http://github.com/Mikolaj/Allure diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/scores b/scores new file mode 100644 Binary files /dev/null and b/scores differ diff --git a/src/Action.hs b/src/Action.hs new file mode 100644 --- /dev/null +++ b/src/Action.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-} +module Action where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.List as L +import qualified Data.IntMap as IM +-- import System.IO (hPutStrLn, stderr) -- just for debugging + +import Perception +import Display hiding (display) +import Message +import State +import Level +import Movable +import MovableState +import MovableKind +import qualified Save + +newtype Action a = Action + { runAction :: + forall r . + Session -> + IO r -> -- shutdown cont + Perceptions -> -- cached perception + (State -> Message -> a -> IO r) -> -- continuation + IO r -> -- failure/reset cont + State -> -- current state + Message -> -- current message + IO r + } + +instance Monad Action where + return = returnAction + (>>=) = bindAction + +-- | Invokes the continuation. +returnAction :: a -> Action a +returnAction x = Action (\ s e p k a st m -> k st m x) + +-- | Distributes the session and shutdown continuation, +-- threads the state and message. +bindAction :: Action a -> (a -> Action b) -> Action b +bindAction m f = Action (\ s e p k a st ms -> + let next nst nm x = + runAction (f x) s e p k a nst nm + in runAction m s e p next a st ms) + +instance MonadIO Action where + liftIO x = Action (\ s e p k a st ms -> x >>= k st ms) + +instance MonadState State Action where + get = Action (\ s e p k a st ms -> k st ms st) + put nst = Action (\ s e p k a st ms -> k nst ms ()) + +-- | Exported function to run the monad. +handlerToIO :: Session -> State -> Message -> Action () -> IO () +handlerToIO session state msg h = + runAction h + session + (Save.rmBkp (sconfig state) >> shutdown session) -- get out of the game + (perception_ state) -- cached perception + (\ _ _ x -> return x) -- final continuation returns result + (ioError $ userError "unhandled abort") + state + msg + +-- | Invoking a session command. +session :: (Session -> Action a) -> Action a +session f = Action (\ s e p k a st ms -> runAction (f s) s e p k a st ms) + +-- | Invoking a session command. +sessionIO :: (Session -> IO a) -> Action a +sessionIO f = Action (\ s e p k a st ms -> f s >>= k st ms) + +-- | Display the current level, without any message. +displayWithoutMessage :: Action Bool +displayWithoutMessage = Action (\ s e p k a st ms -> displayLevel False s p st "" Nothing >>= k st ms) + +-- | Display the current level, with the current message. +display :: Action Bool +display = Action (\ s e p k a st ms -> displayLevel False s p st ms Nothing >>= k st ms) + +-- | Display the current level in black and white, and the current message, +displayBW :: Action Bool +displayBW = Action (\ s e p k a st ms -> displayLevel True s p st ms Nothing >>= k st ms) + +-- | Display an overlay on top of the current screen. +overlay :: String -> Action Bool +overlay txt = Action (\ s e p k a st ms -> displayLevel False s p st ms (Just txt) >>= k st ms) + +-- | Set the current message. +messageWipeAndSet :: Message -> Action () +messageWipeAndSet nm = Action (\ s e p k a st ms -> k st nm ()) + +-- | Add to the current message. +messageAdd :: Message -> Action () +messageAdd nm = Action (\ s e p k a st ms -> k st (addMsg ms nm) ()) + +-- | Clear the current message. +resetMessage :: Action Message +resetMessage = Action (\ s e p k a st ms -> k st "" ms) + +-- | Get the current message. +currentMessage :: Action Message +currentMessage = Action (\ s e p k a st ms -> k st ms ms) + +-- | End the game, i.e., invoke the shutdown continuation. +end :: Action () +end = Action (\ s e p k a st ms -> e) + +-- | Reset the state and resume from the last backup point, i.e., invoke +-- the failure continuation. +abort :: Action a +abort = Action (\ s e p k a st ms -> a) + +-- | Perform an action and signal an error if the result is False. +assertTrue :: Action Bool -> Action () +assertTrue h = do + b <- h + when (not b) $ error "assertTrue: failure" + +-- | Perform an action and signal an error if the result is True. +assertFalse :: Action Bool -> Action () +assertFalse h = do + b <- h + when b $ error "assertFalse: failure" + +-- | Set the current exception handler. First argument is the handler, +-- second is the computation the handler scopes over. +tryWith :: Action () -> Action () -> Action () +tryWith exc h = Action (\ s e p k a st ms -> runAction h s e p k (runAction exc s e p k a st ms) st ms) + +-- | Takes a handler and a computation. If the computation fails, the +-- handler is invoked and then the computation is retried. +tryRepeatedlyWith :: Action () -> Action () -> Action () +tryRepeatedlyWith exc h = tryWith (exc >> tryRepeatedlyWith exc h) h + +-- | Try the given computation and silently catch failure. +try :: Action () -> Action () +try = tryWith (return ()) + +-- | Try the given computation until it succeeds without failure. +tryRepeatedly :: Action () -> Action () +tryRepeatedly = tryRepeatedlyWith (return ()) + +-- | Print a debug message or ignore. +debug :: String -> Action () +debug x = return () -- liftIO $ hPutStrLn stderr x + +-- | Print the given message, then abort. +abortWith :: Message -> Action a +abortWith msg = do + messageWipeAndSet msg + display + abort + +neverMind :: Bool -> Action a +neverMind b = abortIfWith b "never mind" + +-- | Abort, and print the given message if the condition is true. +abortIfWith :: Bool -> Message -> Action a +abortIfWith True msg = abortWith msg +abortIfWith False _ = abortWith "" + +-- | Print message, await confirmation. Return value indicates +-- if the player tried to abort/escape. +messageMoreConfirm :: Bool -> Message -> Action Bool +messageMoreConfirm blackAndWhite msg = do + messageAdd (msg ++ more) + if blackAndWhite then displayBW else display + session getConfirm + +-- | Print message, await confirmation, ignore confirmation. +messageMore :: Message -> Action () +messageMore msg = resetMessage >> messageMoreConfirm False msg >> return () + +-- | Print a yes/no question and return the player's answer. +messageYesNo :: Message -> Action Bool +messageYesNo msg = do + messageWipeAndSet (msg ++ yesno) + displayBW -- turn player's attention to the choice + session getYesNo + +-- | Print a message and an overlay, await confirmation. Return value +-- indicates if the player tried to abort/escape. +messageOverlayConfirm :: Message -> String -> Action Bool +messageOverlayConfirm msg txt = messageOverlaysConfirm msg [txt] + +-- | Prints several overlays, one per page, and awaits confirmation. +-- Return value indicates if the player tried to abort/escape. +messageOverlaysConfirm :: Message -> [String] -> Action Bool +messageOverlaysConfirm msg [] = + do + resetMessage + display + return True +messageOverlaysConfirm msg (x:xs) = + do + messageWipeAndSet msg + b <- overlay (x ++ more) + if b + then do + b <- session getConfirm + if b + then do + messageOverlaysConfirm msg xs + else stop + else stop + where + stop = do + resetMessage + display + return False + +-- | Update the cached perception for the given computation. +withPerception :: Action () -> Action () +withPerception h = Action (\ s e _ k a st ms -> + runAction h s e (perception_ st) k a st ms) + +-- | Get the current perception. +currentPerception :: Action Perceptions +currentPerception = Action (\ s e p k a st ms -> k st ms p) + +-- | If in targeting mode, check if the current level is the same +-- as player level and refuse performing the action otherwise. +checkCursor :: Action () -> Action () +checkCursor h = do + cursor <- gets scursor + level <- gets slevel + if creturnLn cursor == lname level + then h + else abortWith "this command does not work on remote levels" + +updateAnyActor :: Actor -> (Movable -> Movable) -> Action () +updateAnyActor actor f = modify (updateAnyActorBody actor f) + +updatePlayerBody :: (Movable -> Movable) -> Action () +updatePlayerBody f = do + pl <- gets splayer + updateAnyActor pl f + +-- | Advance the move time for the given actor. +advanceTime :: Actor -> Action () +advanceTime actor = do + time <- gets stime + let upd m = m { mtime = time + (nspeed (mkind m)) } + -- A hack to synchronize the whole party: + pl <- gets splayer + if (actor == pl || isAHero actor) + then do + modify (updateLevel (updateHeroes (IM.map upd))) + when (not $ isAHero pl) $ updatePlayerBody upd + else updateAnyActor actor upd + +playerAdvanceTime :: Action () +playerAdvanceTime = do + pl <- gets splayer + advanceTime pl diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Actions.hs @@ -0,0 +1,634 @@ +module Actions where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.Function +import Data.List as L +import Data.Map as M +import qualified Data.IntMap as IM +import Data.Maybe +import Data.Set as S +import System.Time + +import Action +import Display hiding (display) +import Dungeon +import Geometry +import Grammar +import qualified HighScores as H +import Item +import qualified ItemKind +import qualified Keys as K +import Level +import LevelState +import Message +import Movable +import MovableState +import MovableKind +import MovableAdd +import Perception +import Random +import State +import qualified Config +import qualified Save +import qualified Terrain +import qualified Effect +import EffectAction +import WorldLoc +import Tile -- TODO: qualified + +-- The Action stuff that is independent from ItemAction.hs. +-- (Both depend on EffectAction.hs). + +displayHistory :: Action () +displayHistory = + do + hst <- gets shistory + messageOverlayConfirm "" (unlines hst) + abort + +dumpConfig :: Action () +dumpConfig = + do + config <- gets sconfig + let fn = "config.dump" + liftIO $ Config.dump fn config + abortWith $ "Current configuration dumped to file " ++ fn ++ "." + +saveGame :: Action () +saveGame = + do + b <- messageYesNo "Really save?" + if b + then do + -- Save the game state + st <- get + liftIO $ Save.saveGame st + ln <- gets (lname . slevel) + let total = calculateTotal st + status = H.Camping ln + go <- handleScores False status total + when go $ messageMore "See you soon, stronger and braver!" + end + else abortWith "Game resumed." + +quitGame :: Action () +quitGame = + do + b <- messageYesNo "Really quit?" + if b + then end -- no highscore display for quitters + else abortWith "Game resumed." + +-- | End targeting mode, accepting the current location or not. +endTargeting :: Bool -> Action () +endTargeting accept = do + returnLn <- gets (creturnLn . scursor) + target <- gets (mtarget . getPlayerBody) + cloc <- gets (clocation . scursor) + lvlSwitch returnLn -- return to the original level of the player + modify (updateCursor (\ c -> c { ctargeting = False })) + let isEnemy = case target of TEnemy _ _ -> True ; _ -> False + when (not isEnemy) $ + if accept + then updatePlayerBody (\ p -> p { mtarget = TLoc cloc }) + else updatePlayerBody (\ p -> p { mtarget = TCursor }) + endTargetingMsg + +endTargetingMsg :: Action () +endTargetingMsg = do + pkind <- gets (mkind . getPlayerBody) + target <- gets (mtarget . getPlayerBody) + state <- get + let verb = "target" + targetMsg = case target of + TEnemy a _ll -> + case findActorAnyLevel a state of + Just (_, m) -> objectMovable (mkind m) + Nothing -> "a long gone adversary" + TLoc loc -> "location " ++ show loc + TCursor -> "current cursor position continuously" + messageAdd $ subjectMovableVerb pkind verb ++ " " ++ targetMsg ++ "." + +-- | Cancel something, e.g., targeting mode, resetting the cursor +-- to the position of the player. Chosen target is not invalidated. +cancelCurrent :: Action () +cancelCurrent = do + targeting <- gets (ctargeting . scursor) + if targeting + then endTargeting False + else abortWith "Press Q to quit." + +-- | Accept something, e.g., targeting mode, keeping cursor where it was. +-- Or perform the default action, if nothing needs accepting. +acceptCurrent :: Action () -> Action () +acceptCurrent h = do + targeting <- gets (ctargeting . scursor) + if targeting + then endTargeting True + else h -- nothing to accept right now + +moveCursor :: Dir -> Int -> Action () +moveCursor dir n = do + (sy, sx) <- gets (lsize . slevel) + let upd cursor = + let (ny, nx) = iterate (`shift` dir) (clocation cursor) !! n + cloc = (max 1 $ min ny (sy-1), max 1 $ min nx (sx-1)) + in cursor { clocation = cloc } + modify (updateCursor upd) + doLook + +move :: Dir -> Action () +move dir = do + pl <- gets splayer + targeting <- gets (ctargeting . scursor) + if targeting then moveCursor dir 1 else moveOrAttack True True pl dir + +run :: Dir -> Action () +run dir = do + pl <- gets splayer + targeting <- gets (ctargeting . scursor) + if targeting + then moveCursor dir 10 + else do + updatePlayerBody (\ p -> p { mdir = Just dir }) + -- attacks and opening doors disallowed while running + moveOrAttack False False pl dir + +-- | This function implements the actual "logic" of running. It checks if we +-- have to stop running because something interested happened, and it checks +-- if we have to adjust the direction because we're in the corner of a corridor. +continueRun :: Dir -> Action () +continueRun dir = + do + state <- get + loc <- gets (mloc . getPlayerBody) + per <- currentPerception + msg <- currentMessage + ms <- gets (lmonsters . slevel) + hs <- gets (lheroes . slevel) + lmap <- gets (lmap . slevel) + pl <- gets splayer + let dms = case pl of + AMonster n -> IM.delete n ms -- don't be afraid of yourself + AHero _ -> ms + mslocs = S.fromList (L.map mloc (IM.elems dms)) + monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per)) + newsReported = not (L.null msg) + t = lmap `at` loc -- tile at current location + itemsHere = not (L.null (titems t)) + heroThere = L.elem (loc `shift` dir) (L.map mloc (IM.elems hs)) + dirOK = accessible lmap loc (loc `shift` dir) + -- What happens next is mostly depending on the terrain we're currently on. + let hop t + | monstersVisible || heroThere + || newsReported || itemsHere || Terrain.isExit t = abort + hop t | Terrain.isFloorDark t = + -- in corridors, explore all corners and stop at all crossings + -- TODO: even in corridors, stop if you run past an exit (rare) + let ns = L.filter (\ x -> distance (neg dir, x) > 1 + && accessible lmap loc (loc `shift` x)) + moves + allCloseTo main = L.all (\ d -> distance (main, d) <= 1) ns + in case ns of + [onlyDir] -> run onlyDir -- can be diagonal + _ -> + -- prefer orthogonal to diagonal dirs, for hero's safety + case L.filter (\ x -> not $ diagonal x) ns of + [ortoDir] + | allCloseTo ortoDir -> run ortoDir + _ -> abort + hop _ -- outside corridors, never change direction + | not dirOK = abort + hop _ = + let ns = L.filter (\ x -> x /= dir && distance (neg dir, x) > 1) moves + ls = L.map (loc `shift`) ns + as = L.filter (\ x -> accessible lmap loc x + || openable 1 lmap x) ls + ts = L.map (tterrain . (lmap `at`)) as + in if L.any Terrain.isExit ts then abort else run dir + hop (tterrain t) + +ifRunning :: (Dir -> Action a) -> Action a -> Action a +ifRunning t e = + do + mdir <- gets (mdir . getPlayerBody) + maybe e t mdir + +-- | Update player memory. +remember :: Action () +remember = + do + per <- currentPerception + let vis = S.toList (ptvisible per) + let rememberLoc = M.update (\ (t,_) -> Just (t,t)) + modify (updateLevel (updateLMap (\ lmap -> L.foldr rememberLoc lmap vis))) + +-- | Open and close doors +openclose :: Bool -> Action () +openclose o = + do + messageWipeAndSet "direction?" + display + e <- session nextCommand + pl <- gets splayer + K.handleDirection e (actorOpenClose pl True o) (neverMind True) + +actorOpenClose :: Actor -> + Bool -> -- ^ verbose? + Bool -> -- ^ open? + Dir -> Action () +actorOpenClose actor v o dir = + do + state <- get + lmap <- gets (lmap . slevel) + pl <- gets splayer + body <- gets (getActor actor) + let txt = if o then "open" else "closed" + let hms = levelHeroList state ++ levelMonsterList state + let loc = mloc body + let isPlayer = actor == pl + let isVerbose = v && isPlayer + let dloc = shift loc dir -- location we act upon + let openPower = case strongestItem (mitems body) "ring" of + Just i -> niq (mkind body) + ipower i + Nothing -> niq (mkind body) + in case lmap `at` dloc of + Tile (Terrain.Door o') [] + | secret o' && isPlayer -> -- door is secret, cannot be opened or closed by the player + neverMind isVerbose + | maybe o ((|| not o) . (>= openPower)) o' -> + -- door is in unsuitable state + abortIfWith isVerbose ("already " ++ txt) + | not (unoccupied hms dloc) -> + -- door is blocked by a movable + abortIfWith isVerbose "blocked" + | otherwise -> -- door can be opened / closed + -- TODO: print message if action performed by monster and perceived + let nt = Tile (Terrain.door (toOpen o)) [] + adj = M.adjust (\ (_, mt) -> (nt, mt)) dloc + in modify (updateLevel (updateLMap adj)) + Tile (Terrain.Door o') _ -> -- door is jammed by items + abortIfWith isVerbose "jammed" + _ -> -- there is no door here + neverMind isVerbose + advanceTime actor + +-- | Attempt a level switch to k levels deeper. +-- TODO: perhaps set up some level name arithmetics in Level.hs +-- and hide there the fact levels are now essentially Ints. +lvlDescend :: Int -> Action () +lvlDescend k = + do + state <- get + let n = levelNumber (lname (slevel state)) + nln = n + k + when (nln < 1 || nln > sizeDungeon (sdungeon state) + 1) $ + abortWith "no more levels in this direction" + assertTrue $ liftM (k == 0 ||) (lvlSwitch (LambdaCave nln)) + +-- | Attempt a level change via up level and down level keys. +-- Will quit the game if the player leaves the dungeon. +lvlChange :: VDir -> Action () +lvlChange vdir = + do + cursor <- gets scursor + targeting <- gets (ctargeting . scursor) + pbody <- gets getPlayerBody + pl <- gets splayer + map <- gets (lmap . slevel) + let loc = if targeting then clocation cursor else mloc pbody + case Terrain.deStairs $ tterrain $ map `at` loc of + Just (vdir', next) + | vdir == vdir' -> -- stairs are in the right direction + case next of + Nothing -> + -- we are at the "end" of the dungeon + if targeting + then abortWith "cannot escape dungeon in targeting mode" + else do + b <- messageYesNo "Really escape the dungeon?" + if b + then fleeDungeon + else abortWith "Game resumed." + Just (nln, nloc) -> do + if targeting + then do + -- this assertion says no stairs go back to the same level + assertTrue $ lvlSwitch nln + -- do not freely reveal the other end of the stairs + map <- gets (lmap . slevel) -- lvlSwitch modifies map + let upd cursor = + let cloc = if isUnknown (rememberAt map nloc) + then loc + else nloc + in cursor { clocation = cloc, clocLn = nln } + modify (updateCursor upd) + doLook + else tryWith (abortWith "somebody blocks the staircase") $ do + -- Remove the player from the old level. + modify (deleteActor pl) + -- At this place the invariant that the player exists fails. + -- Change to the new level (invariant not needed). + assertTrue $ lvlSwitch nln + -- Add the player to the new level. + modify (insertActor pl pbody) + -- At this place the invariant is restored again. + -- Land the player at the other end of the stairs. + updatePlayerBody (\ p -> p { mloc = nloc }) + -- Change the level of the player recorded in cursor. + modify (updateCursor (\ c -> c { creturnLn = nln })) + -- Bail out if anybody blocks the staircase. + inhabitants <- gets (locToActors nloc) + when (length inhabitants > 1) abort + -- The invariant "at most one movable on a tile" restored. + -- Create a backup of the savegame. + state <- get + liftIO $ Save.saveGame state >> Save.mvBkp (sconfig state) + playerAdvanceTime + _ -> -- no stairs in the right direction + if targeting + then do + lvlDescend (if vdir == Up then -1 else 1) + ln <- gets (lname . slevel) + let upd cursor = cursor { clocLn = ln } + modify (updateCursor upd) + doLook + else + let txt = if vdir == Up then "up" else "down" + in abortWith ("no stairs " ++ txt) + +-- | Hero has left the dungeon. +fleeDungeon :: Action () +fleeDungeon = + do + state <- get + let total = calculateTotal state + items = L.concatMap mitems (levelHeroList state) + if total == 0 + then do + go <- resetMessage >> messageMoreConfirm False "Coward!" + when go $ + messageMore "Next time try to grab some loot before escape!" + end + else do + let winMsg = "Congratulations, you won! Your loot, worth " ++ + show total ++ " gold, is:" + displayItems winMsg True items + go <- session getConfirm + when go $ do + go <- handleScores True H.Victor total + when go $ messageMore "Can it be done better, though?" + end + +-- | Switches current hero to the next hero on the level, if any, wrapping. +cycleHero :: Action () +cycleHero = + do + pl <- gets splayer + hs <- gets (lheroes . slevel) + let i = case pl of AHero n -> n ; _ -> -1 + (lt, gt) = IM.split i hs + case IM.keys gt ++ IM.keys lt of + [] -> abortWith "Cannot select another hero on this level." + ni : _ -> assertTrue $ selectPlayer (AHero ni) + +-- | Search for secret doors +search :: Action () +search = + do + lmap <- gets (lmap . slevel) + ploc <- gets (mloc . getPlayerBody) + pitems <- gets (mitems . getPlayerBody) + let delta = case strongestItem pitems "ring" of + Just i -> 1 + ipower i + Nothing -> 1 + searchTile (Tile (Terrain.Door (Just n)) x, t') = + (Tile (Terrain.door (Just (max (n - delta) 0))) x, t') + searchTile t = t + f l m = M.adjust searchTile (shift ploc m) l + slmap = L.foldl' f lmap moves + modify (updateLevel (updateLMap (const slmap))) + playerAdvanceTime + +-- | Start the floor targeting mode or reset the cursor location to the player. +targetFloor :: Action () +targetFloor = do + ploc <- gets (mloc . getPlayerBody) + target <- gets (mtarget . getPlayerBody) + targeting <- gets (ctargeting . scursor) + let tgt = case target of + _ | targeting -> TLoc ploc -- double key press: reset cursor + TEnemy _ _ -> TCursor -- forget enemy target, keep the cursor + t -> t -- keep the target from previous targeting session + updatePlayerBody (\ p -> p { mtarget = tgt }) + setCursor tgt + +-- | Start the monster targeting mode. Cycle between monster targets. +-- TODO: also target a monster by moving the cursor, if in target monster mode. +-- TODO: sort monsters by distance to the player. +targetMonster :: Action () +targetMonster = do + pl <- gets splayer + ms <- gets (lmonsters . slevel) + per <- currentPerception + target <- gets (mtarget . getPlayerBody) + targeting <- gets (ctargeting . scursor) + let i = case target of + TEnemy (AMonster n) _ | targeting -> n -- try next monster + TEnemy (AMonster n) _ -> n - 1 -- try to retarget old monster + _ -> -1 -- try to target first monster (e.g., number 0) + dms = case pl of + AMonster n -> IM.delete n ms -- don't target yourself + AHero _ -> ms + (lt, gt) = IM.split i dms + gtlt = IM.assocs gt ++ IM.assocs lt + lf = L.filter (\ (_, m) -> actorSeesLoc pl (mloc m) per (Just pl)) gtlt + tgt = case lf of + [] -> target -- no monsters in sight, stick to last target + (ni, nm) : _ -> TEnemy (AMonster ni) (mloc nm) -- pick the next + updatePlayerBody (\ p -> p { mtarget = tgt }) + setCursor tgt + +-- | Set, activate and display cursor information. +setCursor :: Target -> Action () +setCursor tgt = do + state <- get + per <- currentPerception + ploc <- gets (mloc . getPlayerBody) + ln <- gets (lname . slevel) + let upd cursor = + let cloc = case targetToLoc (ptvisible per) state of + Nothing -> ploc + Just l -> l + in cursor { ctargeting = True, clocation = cloc, clocLn = ln } + modify (updateCursor upd) + doLook + +-- | Perform look around in the current location of the cursor. +-- TODO: depending on tgt, show extra info about tile or monster or both +doLook :: Action () +doLook = + do + loc <- gets (clocation . scursor) + state <- get + lmap <- gets (lmap . slevel) + per <- currentPerception + target <- gets (mtarget . getPlayerBody) + let canSee = S.member loc (ptvisible per) + monsterMsg = + if canSee + then case L.find (\ m -> mloc m == loc) (levelMonsterList state) of + Just m -> subjectMovable (mkind m) ++ " is here. " + Nothing -> "" + else "" + mode = case target of + TEnemy _ _ -> "[targeting monster] " + TLoc _ -> "[targeting location] " + TCursor -> "[targeting current] " + -- general info about current loc + lookMsg = mode ++ lookAt True canSee state lmap loc monsterMsg + -- check if there's something lying around at current loc + t = lmap `at` loc + if length (titems t) <= 2 + then do + messageAdd lookMsg + else do + displayItems lookMsg False (titems t) + session getConfirm + messageAdd "" + +-- | This function performs a move (or attack) by any actor, +-- i.e., it can handle monsters, heroes and both. +moveOrAttack :: Bool -> -- allow attacks? + Bool -> -- auto-open doors on move + Actor -> -- who's moving? + Dir -> + Action () +moveOrAttack allowAttacks autoOpen actor dir + | dir == (0,0) = + -- Moving with no direction is a noop. + -- We include it currently to prevent that + -- monsters attack themselves by accident. + advanceTime actor + | otherwise = do + -- We start by looking at the target position. + state <- get + pl <- gets splayer + lmap <- gets (lmap . slevel) + sm <- gets (getActor actor) + let sloc = mloc sm -- source location + tloc = sloc `shift` dir -- target location + tgt <- gets (locToActor tloc) + case tgt of + Just target -> + if allowAttacks then + -- Attacking does not require full access, adjacency is enough. + actorAttackActor actor target + else if accessible lmap sloc tloc then do + -- Switching positions requires full access. + actorRunActor actor target + when (actor == pl) $ + messageAdd $ lookAt False True state lmap tloc "" + else abortWith "" + Nothing -> + if accessible lmap sloc tloc then do + -- perform the move + updateAnyActor actor $ \ m -> m { mloc = tloc } + when (actor == pl) $ + messageAdd $ lookAt False True state lmap tloc "" + advanceTime actor + else if allowAttacks && actor == pl + && canBeDoor (lmap `rememberAt` tloc) then do + messageAdd "You search your surroundings." -- TODO: proper msg + search + else if autoOpen then + -- try to open a door + actorOpenClose actor False True dir + else abortWith "" + +-- | Resolves the result of an actor moving into another. Usually this +-- involves melee attack, but with two heroes it just changes focus. +-- Movables on blocked locations can be attacked without any restrictions. +-- For instance, a movable capable of moving through walls +-- can be attacked from an adjacent position. +-- This function is analogous to zapGroupItem, but for melee +-- and not using up the weapon. +actorAttackActor :: Actor -> Actor -> Action () +actorAttackActor (AHero _) target@(AHero _) = + -- Select adjacent hero by bumping into him. Takes no time. + assertTrue $ selectPlayer target +actorAttackActor source target = do + state <- get + sm <- gets (getActor source) + tm <- gets (getActor target) + per <- currentPerception + let groupName = "sword" + verb = attackToVerb groupName + sloc = mloc sm + swordKindIndex = fromJust $ L.elemIndex ItemKind.sword ItemKind.loot + -- The hand-to-hand "weapon", equivalent to +0 sword. + h2h = Item swordKindIndex 0 Nothing 1 + str = strongestItem (mitems sm) groupName + stack = fromMaybe h2h str + single = stack { icount = 1 } + -- The message describes the source part of the action. + -- TODO: right now it also describes the victim and weapon; + -- perhaps, when a weapon is equipped, just say "you hit" or "you miss" + -- and then "nose dies" or "nose yells in pain". + msg = subjectVerbMObject sm verb tm $ + if isJust str then " with " ++ objectItem state single else "" + when (sloc `S.member` ptvisible per) $ messageAdd msg + -- Messages inside itemEffectAction describe the target part. + itemEffectAction source target single + advanceTime source + +attackToVerb :: String -> String +attackToVerb "sword" = "hit" -- TODO: "slash"? "pierce"? "swing"? +attackToVerb "mace" = "bludgeon" +attackToVerb _ = "hit" + +-- | Resolves the result of an actor running into another. +-- This involves switching positions of the two movables. +actorRunActor :: Actor -> Actor -> Action () +actorRunActor source target = do + pl <- gets splayer + sloc <- gets (mloc . getActor source) -- source location + tloc <- gets (mloc . getActor target) -- target location + updateAnyActor source $ \ m -> m { mloc = tloc } + updateAnyActor target $ \ m -> m { mloc = sloc } + if source == pl + then stopRunning -- do not switch positions repeatedly + else if isAMonster source + then focusIfAHero target + else return () + advanceTime source + +-- | Generate a monster, possibly. +generateMonster :: Action () +generateMonster = + do -- TODO: simplify + state <- get + nstate <- liftIO $ rndToIO $ rollMonster state + modify (const nstate) + +-- | Possibly regenerate HP for all movables on the current level. +regenerateLevelHP :: Action () +regenerateLevelHP = + do + time <- gets stime + let upd m = + let regen = nregen (mkind m) `div` + case strongestItem (mitems m) "amulet" of + Just i -> ipower i + Nothing -> 1 + in if time `mod` regen /= 0 + then m + else m { mhp = min (nhpMax (mkind m)) (mhp m + 1) } + -- We really want hero selection to be a purely UI distinction, + -- so all heroes need to regenerate, not just the player. + -- Only the heroes on the current level regenerate (others are frozen + -- in time together with their level). This prevents cheating + -- via sending one hero to a safe level and waiting there. + modify (updateLevel (updateHeroes (IM.map upd))) + modify (updateLevel (updateMonsters (IM.map upd))) diff --git a/src/Color.hs b/src/Color.hs new file mode 100644 --- /dev/null +++ b/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" diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 --- /dev/null +++ b/src/Command.hs @@ -0,0 +1,41 @@ +module Command where + +import Action +import Actions +import ItemAction +import Geometry +import Level +import Version + +data Described a = Described { chelp :: String, caction :: a } + | Undescribed { caction :: a } + +type Command = Described (Action ()) +type DirCommand = Described (Dir -> Action ()) + +closeCommand = Described "close a door" (checkCursor (openclose False)) +openCommand = Described "open a door (or bump into a door)" (checkCursor (openclose True)) +pickupCommand = Described "get an object" (checkCursor pickupItem) +dropCommand = Described "drop an object" (checkCursor dropItem) +inventoryCommand = Described "display inventory" inventory +searchCommand = Described "search for secret doors (or bump)" (checkCursor search) +ascendCommand = Described "ascend a level" (lvlChange Up) +descendCommand = Described "descend a level" (lvlChange Down) +floorCommand = Described "target location" targetFloor +monsterCommand = Described "target monster" (checkCursor targetMonster) +quaffCommand = Described "quaff a potion" (checkCursor quaffPotion) +readCommand = Described "read a scroll" (checkCursor readScroll) +throwCommand = Described "throw a weapon" (checkCursor throwItem) +aimCommand = Described "aim a wand" (checkCursor aimItem) +waitCommand = Described "wait" playerAdvanceTime +saveCommand = Described "save and exit the game" saveGame +quitCommand = Described "quit without saving" quitGame +cancelCommand = Described "cancel action" cancelCurrent +acceptCommand h = Described "accept choice" (acceptCurrent h) +historyCommand = Described "display previous messages" displayHistory +dumpCommand = Described "dump current configuration" dumpConfig +heroCommand = Described "cycle among heroes on level" cycleHero +versionCommand = Described "display game version" (abortWith version) + +moveDirCommand = Described "move in direction" move +runDirCommand = Described "run in direction" run diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,113 @@ +module Config + (CP, defaultCP, config, getOption, getItems, get, getFile, dump) where + +import System.Directory +import System.FilePath +import System.IO +import Control.Monad.Error + +import qualified Data.ConfigFile as CF +import Data.Either.Utils +import Data.Maybe +import qualified Data.Binary as Binary + +import qualified ConfigDefault + +newtype CP = CP CF.ConfigParser + +instance Binary.Binary CP where + put (CP config) = Binary.put $ CF.to_string config + get = do + string <- Binary.get + -- use config in case savegame is from older version and lacks some options + let c = CF.readstring defCF string + return $ toCP $ forceEither c + +instance Show CP where + show (CP config) = show $ CF.to_string config + +-- | Switches all names to case sensitive (unlike by default in ConfigFile). +toSensitive :: CF.ConfigParser -> CF.ConfigParser +toSensitive cp = cp {CF.optionxform = id} + +-- | The default configuration taken from the default configuration file +-- included via CPP in ConfigDefault.hs. +defCF :: CF.ConfigParser +defCF = + let c = CF.readstring CF.emptyCP ConfigDefault.configDefault + in toSensitive $ forceEither c + +toCP :: CF.ConfigParser -> CP +toCP cp = CP $ toSensitive cp + +defaultCP :: CP +defaultCP = toCP defCF + +-- | Path to the user configuration file. +file :: IO FilePath +file = + do + appData <- getAppUserDataDirectory "Allure" + return $ combine appData "config" + +-- | The configuration read from the user configuration file. +-- The default configuration file provides underlying defaults +-- in case some options, or the whole file, are missing. +config :: IO CP +config = + -- evaluate, to catch config errors ASAP + defCF `seq` + do + f <- file + b <- doesFileExist f + if not b + then return $ toCP $ defCF + else do + c <- CF.readfile defCF f + return $ toCP $ forceEither c + +-- | A simplified access to an option in a given section, +-- with simple error reporting (no error is caught and hidden). +-- If there is no config file or no such option, gives Nothing. +getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a +getOption (CP config) s o = + if CF.has_option config s o + then Just $ forceEither $ CF.get config s o + else Nothing + +-- | A simplified access to an option in a given section. +get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a +get (CP config) s o = + if CF.has_option config s o + then forceEither $ CF.get config s o + else error $ "unknown config option: " ++ s ++ "." ++ o + +-- | An association list corresponding to a section. +getItems :: CP -> CF.SectionSpec -> [(String, String)] +getItems (CP config) s = + if CF.has_section config s + then forceEither $ CF.items config s + else error $ "unknown config section: " ++ s + +-- | Looks up a file path in the config file and makes it absolute. +-- If the game's configuration directory exists, +-- the path is appended to it; otherwise, it's appended +-- to the current directory. +getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath +getFile config s o = + do + current <- getCurrentDirectory + appData <- getAppUserDataDirectory "Allure" + let path = get config s o + appPath = combine appData path + curPath = combine current path + b <- doesDirectoryExist appData + return $ if b then appPath else curPath + +dump :: FilePath -> CP -> IO () +dump fn (CP config) = + do + current <- getCurrentDirectory + let path = combine current fn + dump = CF.to_string config + writeFile path dump diff --git a/src/ConfigDefault.hs b/src/ConfigDefault.hs new file mode 100644 --- /dev/null +++ b/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" + +|] diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} + +module Display where + +-- wrapper for selected Display frontend + +#ifdef CURSES +import qualified Display.Curses as D +#elif GTK +import qualified Display.Gtk as D +#else +import qualified Display.Vty as D +#endif + +-- Display routines that are independent of the selected display frontend. + +import qualified Data.Char as Char +import Data.Set as S +import Data.List as L +import Data.Map as M +import qualified Data.IntMap as IM +import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2 +import Data.Maybe + +import Message +import qualified Color +import State +import Geometry +import Level +import LevelState +import Dungeon +import Perception +import Movable +import MovableState +import MovableKind +import Item +import qualified Keys as K +import WorldLoc + +-- Re-exported from the display frontend, with an extra slot for function +-- for translating keys to a canonical form. +type InternalSession = D.Session +type Session = (InternalSession, M.Map K.Key K.Key) +display area = D.display area . fst +startup = D.startup +shutdown = D.shutdown . fst +displayId = D.displayId + +-- | Next event translated to a canonical form. +nextCommand :: MonadIO m => Session -> m K.Key +nextCommand session = + do + e <- liftIO $ D.nextEvent (fst session) + return $ + case M.lookup e (snd session) of + Just key -> key + Nothing -> K.canonMoveKey e + +-- | Displays a message on a blank screen. Waits for confirmation. +displayBlankConfirm :: Session -> String -> IO Bool +displayBlankConfirm session txt = + let x = txt ++ more + doBlank = const (Color.defaultAttr, ' ') + in do + display ((0, 0), normalLevelSize) session doBlank x "" + getConfirm session + +-- | Waits for a space or return or '?' or '*'. The last two act this way, +-- to let keys that request information toggle display the information off. +getConfirm :: MonadIO m => Session -> m Bool +getConfirm session = + getOptionalConfirm return (const $ getConfirm session) session + +getOptionalConfirm :: MonadIO m => + (Bool -> m a) -> (K.Key -> m a) -> Session -> m a +getOptionalConfirm h k session = + do + e <- liftIO $ nextCommand session + case e of + K.Char ' ' -> h True + K.Char '?' -> h True + K.Char '*' -> h True + K.Return -> h True + K.Esc -> h False + _ -> k e + +-- | A yes-no confirmation. +getYesNo :: MonadIO m => Session -> m Bool +getYesNo session = + do + e <- liftIO $ nextCommand session + case e of + K.Char 'y' -> return True + K.Char 'n' -> return False + K.Esc -> return False + _ -> getYesNo session + +splitOverlay :: Int -> String -> [[String]] +splitOverlay s xs = splitOverlay' (lines xs) + where + splitOverlay' ls + | length ls <= s = [ls] -- everything fits on one screen + | otherwise = let (pre,post) = splitAt (s - 1) ls + in (pre ++ [more]) : splitOverlay' post + +-- | Returns a function that looks up the characters in the +-- string by location. Takes the height of the display plus +-- the string. Returns also the number of screens required +-- to display all of the string. +stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char) +stringByLocation sy xs = + let + ls = splitOverlay sy xs + m = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls))) + k = length ls + in + (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n) + +displayLevel :: + Bool -> Session -> Perceptions -> State -> Message -> Maybe String -> IO Bool +displayLevel + blackAndWhite session per + (state@(State { scursor = cursor, + stime = time, + sassocs = assocs, + slevel = Level ln _ (sy, sx) _ smap lmap _ })) + msg moverlay = + let Movable { mkind = MovableKind { nhpMax = xhp }, + mhp = php, mloc = ploc, mitems = pitems } = getPlayerBody state + reachable = ptreachable per + visible = ptvisible per + overlay = fromMaybe "" moverlay + (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed + sSml = ssensory state == Smell + sVis = case ssensory state of Vision _ -> True; _ -> False + sOmn = sdisplay state == Omniscient + lAt = if sOmn then at else rememberAt + sVisBG = if sVis + then \ vis rea -> if vis + then Color.Blue + else if rea + then Color.Magenta + else Color.defBG + else \ vis rea -> Color.defBG + wealth = L.sum $ L.map itemPrice pitems + damage = case strongestItem pitems "sword" of + Just sw -> 3 + ipower sw + Nothing -> 3 + hs = levelHeroList state + ms = levelMonsterList state + dis n loc = + let tile = lmap `lAt` loc + sml = ((smap ! loc) - time) `div` 100 + viewMovable loc (Movable { mkind = mk }) + | loc == ploc && ln == creturnLn cursor = + (nsymbol mk, Color.defBG) -- highlight player + | otherwise = (nsymbol mk, ncolor mk) + viewSmell :: Int -> Char + viewSmell n + | n > 9 = '*' + | n < 0 = '-' + | otherwise = Char.intToDigit n + rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1) + (char, fg) = + case L.find (\ m -> loc == mloc m) (hs ++ ms) of + Just m | sOmn || vis -> viewMovable loc m + _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc) + | otherwise -> viewTile vis tile assocs + vis = S.member loc visible + rea = S.member loc reachable + bg = if ctargeting cursor && loc == clocation cursor + then Color.defFG -- highlight targeting cursor + else sVisBG vis rea -- FOV debug + reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr) + optVisually (fg, bg) = + if fg == Color.defBG + then reverseVideo + else if bg == Color.defFG && fg == Color.defFG + then reverseVideo + else (fg, bg) + a = if blackAndWhite + then Color.defaultAttr + else optVisually (fg, bg) + in case over (loc `shift` ((sy+1) * n, 0)) of + Just c -> (Color.defaultAttr, c) + _ -> (a, char) + status = + take 30 (levelName ln ++ repeat ' ') ++ + take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') ++ + take 10 ("$: " ++ show wealth ++ repeat ' ') ++ + take 10 ("Dmg: " ++ show damage ++ repeat ' ') ++ + take 20 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ') + disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg status + msgs = splitMsg sx msg + perf k [] = perfo k "" + perf k [xs] = perfo k xs + perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b -> + if b then perf k xs else return False + perfo k xs + | k < n - 1 = disp k xs >> getConfirm session >>= \ b -> + if b then perfo (k+1) xs else return False + | otherwise = disp k xs >> return True + in perf 0 msgs diff --git a/src/Display/Curses.hs b/src/Display/Curses.hs new file mode 100644 --- /dev/null +++ b/src/Display/Curses.hs @@ -0,0 +1,126 @@ +module Display.Curses + (displayId, startup, shutdown, display, nextEvent, Session) where + +import UI.HSCurses.Curses as C +import qualified UI.HSCurses.CursesHelper as C +import Data.List as L +import Data.Map as M +import Data.Char +import qualified Data.ByteString.Char8 as BS +import Control.Monad + +import Geometry +import qualified Keys as K (Key(..)) +import qualified Color + +displayId = "curses" + +data Session = + Session + { win :: Window, + styles :: Map (Color.Color, Color.Color) C.CursesStyle } + +startup :: (Session -> IO ()) -> IO () +startup k = + do + C.start + cursSet CursorInvisible + let s = [ ((f, b), C.Style (toFColor f) (toBColor b)) + | f <- [minBound..maxBound], + -- No more color combinations possible: 16*4, 64 is max. + b <- Color.legalBG ] + nr <- colorPairs + when (nr < L.length s) $ + C.end >> + error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.") + let (ks, vs) = unzip s + ws <- C.convertStyles vs + let styleMap = M.fromList (zip ks ws) + k (Session C.stdScr styleMap) + +shutdown :: Session -> IO () +shutdown w = C.end + +display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String + -> IO () +display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status = + do + -- let defaultStyle = C.defaultCursesStyle + -- Terminals with white background require this: + let defaultStyle = s ! Color.defaultAttr + C.erase + C.setStyle defaultStyle + mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg) -- TODO: BS as in vty + mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status) + sequence_ [ C.setStyle (findWithDefault defaultStyle a s) + >> mvWAddStr w (y+1) x [c] + | x <- [x0..x1], y <- [y0..y1], let (a, c) = f (y, x) ] + refresh + +toWidth :: Int -> String -> String +toWidth n x = take n (x ++ repeat ' ') + +keyTranslate :: C.Key -> K.Key +keyTranslate e = + case e of + C.KeyChar '\ESC' -> K.Esc + C.KeyExit -> K.Esc + C.KeyChar '\n' -> K.Return + C.KeyChar '\r' -> K.Return + C.KeyEnter -> K.Return + C.KeyChar '\t' -> K.Tab + C.KeyUp -> K.Up + C.KeyDown -> K.Down + C.KeyLeft -> K.Left + C.KeyRight -> K.Right + C.KeyHome -> K.Home + C.KeyPPage -> K.PgUp + C.KeyEnd -> K.End + C.KeyNPage -> K.PgDn + C.KeyBeg -> K.Begin + C.KeyB2 -> K.Begin + C.KeyClear -> K.Begin + -- No KP_ keys in hscurses and they do not seem actively maintained. + -- For now, movement keys are more important than hero selection: + C.KeyChar c + | c `elem` ['1'..'9'] -> K.KP c + | otherwise -> K.Char c + _ -> K.Unknown (show e) + +nextEvent :: Session -> IO K.Key +nextEvent session = + do + e <- C.getKey refresh + return (keyTranslate e) +-- case keyTranslate e of +-- Unknown _ -> nextEvent session +-- k -> return k + +toFColor :: Color.Color -> C.ForegroundColor +toFColor Color.Black = C.BlackF +toFColor Color.Red = C.DarkRedF +toFColor Color.Green = C.DarkGreenF +toFColor Color.Yellow = C.BrownF +toFColor Color.Blue = C.DarkBlueF +toFColor Color.Magenta = C.PurpleF +toFColor Color.Cyan = C.DarkCyanF +toFColor Color.White = C.WhiteF +toFColor Color.BrBlack = C.GreyF +toFColor Color.BrRed = C.RedF +toFColor Color.BrGreen = C.GreenF +toFColor Color.BrYellow = C.YellowF +toFColor Color.BrBlue = C.BlueF +toFColor Color.BrMagenta = C.MagentaF +toFColor Color.BrCyan = C.CyanF +toFColor Color.BrWhite = C.BrightWhiteF + +toBColor :: Color.Color -> C.BackgroundColor +toBColor Color.Black = C.BlackB +toBColor Color.Red = C.DarkRedB +toBColor Color.Green = C.DarkGreenB +toBColor Color.Yellow = C.BrownB +toBColor Color.Blue = C.DarkBlueB +toBColor Color.Magenta = C.PurpleB +toBColor Color.Cyan = C.DarkCyanB +toBColor Color.White = C.WhiteB +toBColor _ = C.BlackB -- a limitation of curses diff --git a/src/Display/Gtk.hs b/src/Display/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Display/Gtk.hs @@ -0,0 +1,172 @@ +module Display.Gtk + (displayId, startup, shutdown, display, nextEvent, Session) where + +import qualified Data.Binary +import Control.Monad +import Control.Concurrent +import Graphics.UI.Gtk.Gdk.Events -- TODO: replace, deprecated +import Graphics.UI.Gtk +import Data.List as L +import Data.IORef +import Data.Map as M +import qualified Data.ByteString.Char8 as BS + +import Geometry +import qualified Keys as K (Key(..), keyTranslate) +import qualified Color + +displayId = "gtk" + +data Session = + Session { + schan :: Chan String, + stags :: Map Color.Attr TextTag, + sview :: TextView } + +startup :: (Session -> IO ()) -> IO () +startup k = + do + -- initGUI + unsafeInitGUIForThreadedRTS + w <- windowNew + + ttt <- textTagTableNew + -- text attributes + tts <- fmap M.fromList $ + mapM (\ ak -> do + tt <- textTagNew Nothing + textTagTableAdd ttt tt + doAttr tt ak + return (ak, tt)) + [ (f, b) | f <- [minBound..maxBound], b <- Color.legalBG ] + + -- text buffer + tb <- textBufferNew (Just ttt) + textBufferSetText tb (unlines (replicate 25 (replicate 80 ' '))) + + -- create text view + tv <- textViewNewWithBuffer tb + containerAdd w tv + textViewSetEditable tv False + textViewSetCursorVisible tv False + + -- font + f <- fontDescriptionNew + fontDescriptionSetFamily f "Monospace" + fontDescriptionSetSize f 12 + widgetModifyFont tv (Just f) + currentfont <- newIORef f + onButtonPress tv (\ e -> case e of + Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } -> + do + fsd <- fontSelectionDialogNew "Choose font" + cf <- readIORef currentfont + fd <- fontDescriptionToString cf + fontSelectionDialogSetFontName fsd fd + fontSelectionDialogSetPreviewText fsd "+##@##-...|" + response <- dialogRun fsd + when (response == ResponseOk) $ + do + fn <- fontSelectionDialogGetFontName fsd + case fn of + Just fn' -> do + fd <- fontDescriptionFromString fn' + writeIORef currentfont fd + widgetModifyFont tv (Just fd) + Nothing -> return () + widgetDestroy fsd + return True + _ -> return False) + + let black = Color minBound minBound minBound -- Color.defBG == Color.Black + white = Color 0xAAAA 0xAAAA 0xAAAA -- Color.defFG == Color.White + widgetModifyBase tv StateNormal black + widgetModifyText tv StateNormal white + + ec <- newChan + forkIO $ k (Session ec tts tv) + + onKeyPress tv (\ e -> postGUIAsync (writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)) >> return True) + + onDestroy w mainQuit -- set quit handler + widgetShowAll w + yield + mainGUI + +shutdown _ = mainQuit + +display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String + -> IO () +display ((y0,x0), (y1,x1)) session f msg status = + postGUIAsync $ + do + tb <- textViewGetBuffer (sview session) + let fLine y = let (as, cs) = unzip [ f (y, x) | x <- [x0..x1] ] + in ((y, as), BS.pack cs) + memo = L.map fLine [y0..y1] + attrs = L.map fst memo + chars = L.map snd memo + bs = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status] + textBufferSetByteString tb (BS.concat bs) + mapM_ (setTo tb (stags session) x0) attrs + +setTo :: TextBuffer -> Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) -> IO () +setTo tb tts lx (ly, []) = return () +setTo tb tts lx (ly, a:as) = do + ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx + ie <- textIterCopy ib + let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO () + setIter previous repetitions [] = do + textIterForwardChars ie repetitions + when (previous /= Color.defaultAttr) $ + textBufferApplyTag tb (tts ! previous) ib ie + setIter previous repetitions (a:as) + | a == previous = + setIter a (repetitions + 1) as + | otherwise = do + textIterForwardChars ie repetitions + when (previous /= Color.defaultAttr) $ + textBufferApplyTag tb (tts ! previous) ib ie + textIterForwardChars ib repetitions + setIter a 1 as + setIter a 1 as + +-- | reads until a non-dead key encountered +readUndeadChan :: Chan String -> IO String +readUndeadChan ch = + do + x <- readChan ch + if dead x then readUndeadChan ch else return x + where + dead x = + case x of + "Shift_R" -> True + "Shift_L" -> True + "Control_L" -> True + "Control_R" -> True + "Super_L" -> True + "Super_R" -> True + "Menu" -> True + "Alt_L" -> True + "Alt_R" -> True + "ISO_Level2_Shift" -> True + "ISO_Level3_Shift" -> True + "ISO_Level2_Latch" -> True + "ISO_Level3_Latch" -> True + "Num_Lock" -> True + "Caps_Lock" -> True + _ -> False + +nextEvent :: Session -> IO K.Key +nextEvent session = + do + e <- readUndeadChan (schan session) + return (K.keyTranslate e) + +doAttr :: TextTag -> Color.Attr -> IO () +doAttr tt (fg, bg) + | (fg, bg) == Color.defaultAttr = return () + | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg] + | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg] + | otherwise = set tt [textTagForeground := Color.colorToRGB fg, + textTagBackground := Color.colorToRGB bg] diff --git a/src/Display/Vty.hs b/src/Display/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Display/Vty.hs @@ -0,0 +1,96 @@ +module Display.Vty + (displayId, startup, shutdown, display, nextEvent, Session) where + +import Graphics.Vty as V +import Data.List as L +import Data.Char +import qualified Data.ByteString.Char8 as BS + +import Geometry +import qualified Keys as K (Key(..)) +import qualified Color + +displayId = "vty" + +type Session = V.Vty + +startup :: (Session -> IO ()) -> IO () +startup k = V.mkVty >>= k + +display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String + -> IO () +display ((y0,x0),(y1,x1)) vty f msg status = + let img = (foldr (<->) V.empty_image . + L.map (foldr (<|>) V.empty_image . + L.map (\ (x,y) -> let (a, c) = f (y, x) + in char (setAttr a) c))) + [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ] + in V.update vty (pic_for_image + (utf8_bytestring (setAttr Color.defaultAttr) + (BS.pack (toWidth (x1 - x0 + 1) msg)) <-> + img <-> + utf8_bytestring (setAttr Color.defaultAttr) + (BS.pack (toWidth (x1 - x0 + 1) status)))) + +toWidth :: Int -> String -> String +toWidth n x = take n (x ++ repeat ' ') + +keyTranslate :: V.Event -> K.Key +keyTranslate e = + case e of + V.EvKey KEsc [] -> K.Esc + V.EvKey KEnter [] -> K.Return + V.EvKey (KASCII '\t') [] -> K.Tab + V.EvKey KUp [] -> K.Up + V.EvKey KDown [] -> K.Down + V.EvKey KLeft [] -> K.Left + V.EvKey KRight [] -> K.Right + V.EvKey KHome [] -> K.Home + V.EvKey KPageUp [] -> K.PgUp + V.EvKey KEnd [] -> K.End + V.EvKey KPageDown [] -> K.PgDn + V.EvKey KBegin [] -> K.Begin + -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8 + -- For now, movement keys are more important than hero selection: + V.EvKey (KASCII c) [] + | c `elem` ['1'..'9'] -> K.KP c + | otherwise -> K.Char c + _ -> K.Unknown (show e) + +nextEvent :: Session -> IO K.Key +nextEvent session = + do + e <- V.next_event session + return (keyTranslate e) + +-- A hack to get bright colors via the bold attribute. Depending on terminal +-- settings this is needed or not and the characters really get bold or not. +-- HCurses does this by default, but vty refuses to get crazy. +hack c a = if Color.isBright c then with_style a bold else a + +setAttr (fg, bg) = +-- This optimization breaks display for white background terminals: +-- if (fg, bg) == Color.defaultAttr +-- then def_attr +-- else + hack fg $ hack bg $ + def_attr { attr_fore_color = SetTo (aToc fg), + attr_back_color = SetTo (aToc bg) } + +aToc :: Color.Color -> Color +aToc Color.Black = black +aToc Color.Red = red +aToc Color.Green = green +aToc Color.Yellow = yellow +aToc Color.Blue = blue +aToc Color.Magenta = magenta +aToc Color.Cyan = cyan +aToc Color.White = white +aToc Color.BrBlack = bright_black +aToc Color.BrRed = bright_red +aToc Color.BrGreen = bright_green +aToc Color.BrYellow = bright_yellow +aToc Color.BrBlue = bright_blue +aToc Color.BrMagenta = bright_magenta +aToc Color.BrCyan = bright_cyan +aToc Color.BrWhite = bright_white diff --git a/src/Dungeon.hs b/src/Dungeon.hs new file mode 100644 --- /dev/null +++ b/src/Dungeon.hs @@ -0,0 +1,379 @@ +module Dungeon where + +import Prelude hiding (floor) +import Control.Monad +import qualified System.Random as R + +import Data.Binary +import Data.Map as M +import Data.List as L +import Data.Ratio +import Data.Maybe + +import Geometry +import GeometryRnd +import Level +import Item +import Random +import qualified Terrain +import qualified ItemKind +import WorldLoc +import Tile -- TODO: qualified + +-- | The complete dungeon is a map from level names to levels. +-- We usually store all but the current level in this data structure. +newtype Dungeon = Dungeon (M.Map LevelId Level) + deriving Show + +instance Binary Dungeon where + put (Dungeon dng) = put (M.elems dng) + get = liftM dungeon get + +-- | Create a dungeon from a list of levels. +dungeon :: [Level] -> Dungeon +dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l)) + +-- | Extract a level from a dungeon. +getDungeonLevel :: LevelId -> Dungeon -> (Level, Dungeon) +getDungeonLevel ln (Dungeon dng) = (dng ! ln, Dungeon (M.delete ln dng)) + +-- | Put a level into a dungeon. +putDungeonLevel :: Level -> Dungeon -> Dungeon +putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng) + +sizeDungeon :: Dungeon -> Int +sizeDungeon (Dungeon dng) = M.size dng + +type Corridor = [(Y,X)] +type Room = Area + +-- | Create a random room according to given parameters. +mkRoom :: Int -> -- ^ border columns + (Y,X) -> -- ^ minimum size + Area -> -- ^ this is an area, not the room itself + Rnd Room -- ^ this is the upper-left and lower-right corner of the room +mkRoom bd (ym,xm) ((y0,x0),(y1,x1)) = + do + (ry0,rx0) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd - ym + 1,x1 - bd - xm + 1)) + (ry1,rx1) <- locInArea ((ry0 + ym - 1,rx0 + xm - 1),(y1 - bd,x1 - bd)) + return ((ry0,rx0),(ry1,rx1)) + +-- | Create a no-room, i.e., a single corridor field. +mkNoRoom :: Int -> -- ^ border columns + Area -> -- ^ this is an area, not the room itself + Rnd Room -- ^ this is the upper-left and lower-right corner of the room +mkNoRoom bd ((y0,x0),(y1,x1)) = + do + (ry,rx) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd,x1 - bd)) + return ((ry,rx),(ry,rx)) + +data HV = Horiz | Vert + deriving (Eq, Show, Bounded) + +fromHV Horiz = True +fromHV Vert = False + +toHV True = Horiz +toHV False = Vert + +instance R.Random HV where + randomR (a,b) g = case R.randomR (fromHV a, fromHV b) g of + (b, g') -> (toHV b, g') + random g = R.randomR (minBound, maxBound) g + +-- | Create a corridor, either horizontal or vertical, with +-- a possible intermediate part that is in the opposite direction. +mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -} +mkCorridor hv ((y0,x0),(y1,x1)) b = + do + (ry,rx) <- findLocInArea b (const True) + -- (ry,rx) is intermediate point the path crosses + -- hv decides whether we start in horizontal or vertical direction + case hv of + Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)] + Vert -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)] + +-- | Try to connect two rooms with a corridor. +-- The condition passed to mkCorridor is tricky; there might not always +-- exist a suitable intermediate point if the rooms are allowed to be close +-- together ... +connectRooms :: Area -> Area -> Rnd [Loc] +connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) = + do + (sy,sx) <- locInArea sa + (ty,tx) <- locInArea ta + let xok = sx1 < tx0 - 3 + let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2)) + let yok = sy1 < ty0 - 3 + let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx)) + let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-2)) + (hv,area) <- if xok && yok then fmap (\ hv -> (hv,xyarea)) (binaryChoice Horiz Vert) + else if xok then return (Horiz,xarea) + else return (Vert,yarea) + mkCorridor hv ((sy,sx),(ty,tx)) area + +digCorridors :: Corridor -> LMap +digCorridors (p1:p2:ps) = + M.union corPos (digCorridors (p2:ps)) + where + corLoc = fromTo p1 p2 + corPos = M.fromList $ L.zip corLoc (repeat $ newTile Terrain.floorDark) +digCorridors _ = M.empty + +mergeCorridor :: (Tile, Tile) -> (Tile, Tile) -> (Tile, Tile) +mergeCorridor _ (Tile t is, u) | Terrain.isRock t = (Tile Terrain.opening is, u) +mergeCorridor _ (Tile t is, u) | Terrain.isOpening t = (Tile Terrain.opening is, u) +mergeCorridor _ (Tile t is, u) | Terrain.isFloor t = (Tile t is, u) +mergeCorridor (x, u) _ = (x, u) + +-- | Create a new tile. +newTile :: Terrain.Terrain -> (Tile, Tile) +newTile t = (Tile t [], Tile Terrain.unknown []) + +-- | Create a level consisting of only one room. Optionally, insert some walls. +emptyRoom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig -> + LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) +emptyRoom addRocksRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm = + do + let lmap = digRoom Terrain.Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx)) + let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ] + let lvl = Level nm emptyParty (sy,sx) emptyParty smap lmap "" + -- locations of the stairs + su <- findLoc lvl (const floor) + sd <- findLoc lvl (\ l t -> floor t + && distance (su,l) > minStairsDistance cfg) + is <- rollItems cfg lvl su + addRocks <- addRocksRnd lvl + let addItem lmap (l,it) = + M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l lmap + flmap lu ld = + addRocks $ + maybe id (\ l -> M.insert su (newTile (Terrain.stairs Terrain.Light Up l))) lu $ + maybe id (\ l -> M.insert sd (newTile (Terrain.stairs Terrain.Light Down l))) ld $ + (\lmap -> L.foldl' addItem lmap is) $ + lmap + level lu ld = Level nm emptyParty (sy,sx) emptyParty smap (flmap lu ld) "bigroom" + return (level, su, sd) + +-- | For a bigroom level: Create a level consisting of only one, empty room. +bigRoom :: LevelConfig -> + LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) +bigRoom = emptyRoom (\ lvl -> return id) + +-- | For a noiseroom level: Create a level consisting of only one room +-- with randomly distributed pillars. +noiseRoom :: LevelConfig -> + LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) +noiseRoom cfg = + let addRocks lvl = do + rs <- rollPillars cfg lvl + let insertRock lmap l = + case lmap `at` l of + Tile t [] | Terrain.isFloor t -> M.insert l (newTile Terrain.rock) lmap + _ -> lmap + return $ \ lmap -> L.foldl' insertRock lmap rs + in emptyRoom addRocks cfg + +data LevelConfig = + LevelConfig { + levelGrid :: Rnd (Y,X), + minRoomSize :: Rnd (Y,X), + darkRoomChance :: Rnd Bool, + border :: Int, -- must be at least 2! + levelSize :: (Y,X), -- lower right point + extraConnects :: (Y,X) -> Int, + -- relative to grid (in fact a range, because of duplicate connects) + noRooms :: (Y,X) -> Rnd Int, -- range, relative to grid + minStairsDistance :: Int, -- must not be too large + doorChance :: Rnd Bool, + doorOpenChance :: Rnd Bool, + doorSecretChance :: Rnd Bool, + doorSecretMax :: Int, + nrItems :: Rnd Int, -- range + depth :: Int -- general indicator of difficulty + } + +normalLevelSize :: (Y,X) +normalLevelSize = (22,79) + +defaultLevelConfig :: Int -> LevelConfig +defaultLevelConfig d = + LevelConfig { + levelGrid = do + y <- randomR (2,4) + x <- randomR (3,5) + return (y,x), + minRoomSize = return (2,2), + darkRoomChance = chance $ 1%((22 - (2 * fromIntegral d)) `max` 2), + border = 2, + levelSize = normalLevelSize, + extraConnects = \ (y,x) -> (y*x) `div` 3, + noRooms = \ (y,x) -> randomR (0,(y*x) `div` 3), + minStairsDistance = 676, + doorChance = chance $ 2%3, + doorOpenChance = chance $ 1%10, + doorSecretChance = chance $ 1%4, + doorSecretMax = 15, + nrItems = randomR (5,10), + depth = d + } + +largeLevelConfig :: Int -> LevelConfig +largeLevelConfig d = + (defaultLevelConfig d) { + levelGrid = return (7,10), + levelSize = (77,231), + extraConnects = const 10 + } + +-- | Create a "normal" dungeon level. Takes a configuration in order +-- to tweak all sorts of data. + +{- +Leve is generated by an algorithm inspired by the original Rogue, +as follows: + + * The available area is divided into a 3 by 3 grid + where each of the 9 grid cells has approximately the same size. + + * In each of the 9 grid cells one room is placed at a random location. + The minimum size of a room is 2 by 2 floor tiles. A room is surrounded + by walls, and the walls still have to fit into the assigned grid cells. + + * Rooms that are on horizontally or vertically adjacent grid cells + may be connected by a corridor. Corridors consist of 3 segments of straight + lines (either "horizontal, vertical, horizontal" or "vertical, horizontal, + vertical"). They end in openings in the walls of the room they connect. + It is possible that one or two of the 3 segments have length 0, such that + the resulting corridor is L-shaped or even a single straight line. + + * Corridors are generated randomly in such a way that at least every room + on the grid is connected, and a few more might be. It is not sufficient + to always connect all adjacent rooms. + + * Stairs up and down are placed. Stairs are always located in two different + randomly chosen rooms. +-} + +rogueRoom :: LevelConfig -> + LevelId -> + Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> + Level, Loc, Loc) +rogueRoom cfg nm = + do + lgrid <- levelGrid cfg + lminroom <- minRoomSize cfg + let gs = grid lgrid ((0, 0), levelSize cfg) + -- grid locations of "no-rooms" + nrnr <- noRooms cfg lgrid + nr <- replicateM nrnr (do + let (y,x) = lgrid + yg <- randomR (0,y-1) + xg <- randomR (0,x-1) + return (yg,xg)) + rs0 <- mapM (\ (i,r) -> do + r' <- if i `elem` nr + then mkNoRoom (border cfg) r + else mkRoom (border cfg) lminroom r + return (i,r')) gs + let rooms :: [(Loc, Loc)] + rooms = L.map snd rs0 + dlrooms <- (mapM (\ r -> darkRoomChance cfg >>= \ c -> return (r, Terrain.toDL (not c))) rooms) :: Rnd [((Loc, Loc), Terrain.DL)] + let rs = M.fromList rs0 + connects <- connectGrid lgrid + addedConnects <- replicateM (extraConnects cfg lgrid) (randomConnection lgrid) + let allConnects = L.nub (addedConnects ++ connects) + cs <- mapM + (\ (p0,p1) -> do + let r0 = rs ! p0 + r1 = rs ! p1 + connectRooms r0 r1) allConnects + let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg, + y <- [0..sy], x <- [0..sx] ] + let lrooms = L.foldr (\ (r, dl) m -> digRoom dl r m) M.empty dlrooms + lcorridors = M.unions (L.map digCorridors cs) + lrocks = emptyLMap (levelSize cfg) + lmap = M.union (M.unionWith mergeCorridor lcorridors lrooms) lrocks + let lvl = Level nm emptyParty (levelSize cfg) emptyParty smap lmap "" + -- convert openings into doors + dlmap <- fmap M.fromList . mapM + (\ o@((y,x),(t,r)) -> + case t of + Tile t _ | Terrain.isOpening t -> + do + -- openings have a certain chance to be doors; + -- doors have a certain chance to be open; and + -- closed doors have a certain chance to be + -- secret + rb <- doorChance cfg + ro <- doorOpenChance cfg + rs <- if ro then return Nothing + else do rsc <- doorSecretChance cfg + fmap Just + (if rsc then randomR (doorSecretMax cfg `div` 2, doorSecretMax cfg) + else return 0) + if rb + then return ((y,x),newTile (Terrain.door rs)) + else return o + _ -> return o) . + M.toList $ lmap + -- locations of the stairs + su <- findLoc lvl (const floor) + sd <- findLocTry 1000 lvl + (const floor) + (\ l t -> distance (su,l) > minStairsDistance cfg) + -- determine number of items, items and locations for the items + is <- rollItems cfg lvl su + -- generate map and level from the data + let meta = show allConnects + return (\ lu ld -> + let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Up l)) su) lu $ + maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Down l)) sd) ld $ + L.foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is + dlmap + in Level nm emptyParty (levelSize cfg) emptyParty smap flmap meta, su, sd) + +rollItems :: LevelConfig -> Level -> Loc -> Rnd [(Loc, Item)] +rollItems cfg lvl ploc = + do + nri <- nrItems cfg + replicateM nri $ + do + t <- newItem (depth cfg) + l <- case ItemKind.jname (ItemKind.getIK (ikind t)) of + "sword" -> + -- swords generated close to monsters; MUAHAHAHA + findLocTry 200 lvl + (const floor) + (\ l t -> distance (ploc, l) > 400) + _ -> findLoc lvl (const floor) + return (l,t) + +rollPillars :: LevelConfig -> Level -> Rnd [Loc] +rollPillars cfg lvl = + do + nri <- 100 *~ nrItems cfg + replicateM nri $ + do + l <- findLoc lvl (const floor) + return l + +emptyLMap :: (Y, X) -> LMap +emptyLMap (my, mx) = + M.fromList [ ((y, x), newTile Terrain.rock) | x <- [0..mx], y <- [0..my] ] + +-- | If the room has size 1, it is assumed to be a no-room, and a single +-- corridor field will be dug instead of a room. +digRoom :: Terrain.DL -> Room -> LMap -> LMap +digRoom dl ((y0, x0), (y1, x1)) l + | y0 == y1 && x0 == x1 = + M.insert (y0, x0) (newTile Terrain.floorDark) l + | otherwise = + let floorDL = if dl == Terrain.Light then Terrain.floorLight else Terrain.floorDark + rm = + [ ((y, x), newTile floorDL) | x <- [x0..x1], y <- [y0..y1] ] + ++ [ ((y, x), newTile Terrain.rock) + | x <- [x0-1, x1+1], y <- [y0..y1] ] + ++ [ ((y, x), newTile Terrain.rock) + | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] + in M.unionWith const (M.fromList rm) l diff --git a/src/DungeonState.hs b/src/DungeonState.hs new file mode 100644 --- /dev/null +++ b/src/DungeonState.hs @@ -0,0 +1,41 @@ +module DungeonState where + +import Data.Map as M + +import Geometry +import Level +import Dungeon +import Random +import qualified Config +import WorldLoc + +connect :: + Maybe (Maybe WorldLoc) -> + [(Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc)] -> + [Level] +connect au [(x,_,_)] = [x au Nothing] +connect au ((x,_,d):ys@((_,u,_):_)) = + let (z:zs) = connect (Just (Just (lname x',d))) ys + x' = x au (Just (Just (lname z,u))) + in x' : z : zs + +matchGenerator n Nothing = rogueRoom -- the default +matchGenerator n (Just "bigRoom") = bigRoom +matchGenerator n (Just "noiseRoom") = noiseRoom +matchGenerator n (Just "rogueRoom") = rogueRoom +matchGenerator n (Just s) = + error $ "matchGenerator: unknown: " ++ show n ++ ", " ++ s + +findGenerator config n = + let ln = "LambdaCave_" ++ show n + genName = Config.getOption config "dungeon" ln + in matchGenerator n genName (defaultLevelConfig n) (LambdaCave n) + +-- | Generate the dungeon for a new game. +generate :: Config.CP -> Rnd (Loc, Level, Dungeon) +generate config = do + let depth = Config.get config "dungeon" "depth" + levels <- mapM (findGenerator config) [1..depth] + let lvls = connect (Just Nothing) levels + ploc = ((\ (_,x,_) -> x) (head levels)) + return $ (ploc, head lvls, dungeon (tail lvls)) diff --git a/src/Effect.hs b/src/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Effect.hs @@ -0,0 +1,45 @@ +module Effect where + +import Random +import WorldLoc + +data Effect = + NoEffect + | Heal -- healing strength in ipower + | Wound RollDice -- base damage, to-dam bonus in ipower + | Dominate + | SummonFriend + | SummonEnemy + | ApplyPerfume + | Regneration + | Searching + | Teleport WorldLoc + deriving (Show, Eq, Ord) + +effectToName :: Effect -> String +effectToName NoEffect = "" +effectToName Heal = "of healing" +effectToName (Wound (a, b)) = if a == 0 && b == 0 + then "of wounding" + else "(" ++ show a ++ "d" ++ show b ++ ")" +effectToName Dominate = "of domination" +effectToName SummonFriend = "of aid calling" +effectToName SummonEnemy = "of summoning" +effectToName ApplyPerfume = "of rose water" +effectToName Regneration = "of regeneration" +effectToName Searching = "of searching" +effectToName (Teleport _) = "of teleport" + +-- | How much AI benefits from applying the effect. Multipllied by item power. +-- Negative means harm to the enemy when thrown. Zero won't ever be used. +effectToBenefit :: Effect -> Int +effectToBenefit NoEffect = 0 +effectToBenefit Heal = 10 -- TODO: depends on (maxhp - hp) +effectToBenefit (Wound _) = -10 -- TODO: dice ignored for now +effectToBenefit Dominate = 0 -- AI can't use this +effectToBenefit SummonFriend = 100 +effectToBenefit SummonEnemy = 0 +effectToBenefit ApplyPerfume = 0 +effectToBenefit Regneration = 0 -- much more benefit from carrying around +effectToBenefit Searching = 0 -- AI does not need to search +effectToBenefit (Teleport _) = 0 -- AI does not know when to teleport diff --git a/src/EffectAction.hs b/src/EffectAction.hs new file mode 100644 --- /dev/null +++ b/src/EffectAction.hs @@ -0,0 +1,328 @@ +module EffectAction where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.Function +import Data.List as L +import Data.Map as M +import qualified Data.IntMap as IM +import Data.Maybe +import Data.Set as S +import System.Time +import Control.Exception (assert) + +import Action +import Display hiding (display) +import Dungeon +import Geometry +import Grammar +import qualified HighScores as H +import Item +import qualified ItemKind +import qualified Keys as K +import Level +import LevelState +import Message +import Movable +import MovableState +import MovableKind +import MovableAdd +import Perception +import Random +import State +import qualified Config +import qualified Save +import qualified Effect +import WorldLoc + +-- The effectToAction function and all it depends on. +-- This file should not depend on Action.hs nor ItemAction.hs. + +-- | The source actor affects the target actor, with a given effect and power. +-- Both actors are on the current level and can be the same actor. +-- The bool result indicates if the actors identify the effect. +-- TODO: separately define messages for the case when source == target +-- and for the other case; then use the messages outside of effectToAction, +-- depending on the returned bool, perception and identity of the actors. +effectToAction :: Effect.Effect -> Actor -> Actor -> Int -> + Action (Bool, String) +effectToAction Effect.NoEffect source target power = nullEffect +effectToAction Effect.Heal _source target power = do + tm <- gets (getActor target) + if mhp tm >= nhpMax (mkind tm) || power <= 0 + then nullEffect + else do + focusIfAHero target + let upd m = m { mhp = min (nhpMax (mkind m)) (mhp m + power) } + updateAnyActor target upd + return (True, subjectMovableVerb (mkind tm) "feel" ++ " better.") +effectToAction (Effect.Wound nDm) source target power = do + n <- liftIO $ rndToIO $ rollDice nDm + if (n + power <= 0) then nullEffect else do + focusIfAHero target + tm <- gets (getActor target) + let newHP = mhp tm - n - power + killed = newHP <= 0 + msg = if source == target -- a potion of wounding, etc. + then subjectMovableVerb (mkind tm) "feel" + ++ if killed then " mortally" else "" + ++ " wounded." + else if killed + then if isAHero target + then "" + else subjectMovableVerb (mkind tm) "die" ++ "." + else if isAHero target + then subjectMovableVerb (mkind tm) "lose" + ++ " " ++ show (n + power) ++ "HP." + else subjectMovableVerb (mkind tm) "hiss" ++ " in pain." + updateAnyActor target $ \ m -> m { mhp = newHP } -- Damage the target. + when killed $ do + -- Place the actor's possessions on the map. + modify (updateLevel (dropItemsAt (mitems tm) (mloc tm))) + -- Clean bodies up. + pl <- gets splayer + if target == pl + then checkPartyDeath -- kills the player and checks game over + else modify (deleteActor target) -- kills the enemy + return (True, msg) +effectToAction Effect.Dominate source target power = + if isAMonster target -- Monsters have weaker will than heroes. + then do + assertTrue $ selectPlayer target + -- Prevent AI from getting a few free moves until new player ready. + updatePlayerBody (\ m -> m { mtime = 0}) + stopRunning + display + return (True, "") + else nullEffect +effectToAction Effect.SummonFriend source target power = do + tm <- gets (getActor target) + if isAHero source + then summonHeroes (1 + power) (mloc tm) + else summonMonsters (1 + power) (mloc tm) + return (True, "") +effectToAction Effect.SummonEnemy source target power = do + tm <- gets (getActor target) + if not $ isAHero source -- a trick: monster player will summon a hero + then summonHeroes (1 + power) (mloc tm) + else summonMonsters (1 + power) (mloc tm) + return (True, "") +effectToAction Effect.ApplyPerfume source target _ = + if source == target + then return (True, "Tastes like water, but with a strong rose scent.") + else do + let upd lvl = lvl { lsmell = M.map (const (-100)) (lsmell lvl) } + modify (updateLevel upd) + return (True, "The fragrance quells all scents in the vicinity.") +effectToAction Effect.Regneration source target power = + effectToAction Effect.Heal source target power +effectToAction Effect.Searching source target power = + return (True, "It gets lost and you search in vain.") + +nullEffect :: Action (Bool, String) +nullEffect = return (False, "Nothing happens.") + +-- | The source actor affects the target actor, with a given item. +-- If either actor is a hero, the item may get identified. +itemEffectAction :: Actor -> Actor -> Item -> Action Bool +itemEffectAction source target item = do + state <- get + pl <- gets splayer + tm <- gets (getActor target) + per <- currentPerception + let effect = ItemKind.jeffect $ ItemKind.getIK $ ikind item + -- The message describes the target part of the action. + (b, msg) <- effectToAction effect source target (ipower item) + -- Determine how the player perceives the event. + -- TODO: factor it out as a function messageActor + -- and messageActorVerb (incorporating subjectActorVerb). + if mloc tm `S.member` ptvisible per + then messageAdd msg + else if not b + then return () -- Victim is not seen, nothing interestng happens. + else messageAdd "You hear some noises." + -- If something happens, the item gets identified. + when (b && (isAHero source || isAHero target)) $ discover item + return b + +-- | Given item is now known to the player. +discover :: Item -> Action () +discover i = do + state <- get + let ik = ikind i + obj = unwords $ tail $ words $ objectItem state i + msg = "The " ++ obj ++ " turns out to be " + kind = ItemKind.getIK ik + alreadyIdentified = L.length (ItemKind.jflavour kind) == 1 || + ik `S.member` sdiscoveries state + if alreadyIdentified + then return () + else do + modify (updateDiscoveries (S.insert ik)) + state <- get + messageAdd $ msg ++ objectItem state i ++ "." + +-- | Selects a movable for the player, based on the actor. +-- Focuses on the hero if level changed. False, if nothing to do. +selectPlayer :: Actor -> Action Bool +selectPlayer actor = + do + pl <- gets splayer + if (actor == pl) + then return False -- already selected + else do + state <- get + case findActorAnyLevel actor state of + Nothing -> abortWith $ "No such member of the party." + Just (nln, pbody) -> do + -- Make the new actor the player-controlled actor. + modify (\ s -> s { splayer = actor }) + -- Record the original level of the new player. + modify (updateCursor (\ c -> c { creturnLn = nln })) + -- Switch to the level. + lvlSwitch nln + -- Set smell display, depending on player capabilities. + -- This also reset FOV mode. + modify (\ s -> s { ssensory = if MovableKind.nsmell (mkind pbody) + then Smell + else Implicit }) + -- Announce. + messageAdd $ subjectMovable (mkind pbody) ++ " selected." + return True + +focusIfAHero :: Actor -> Action () +focusIfAHero target = + if isAHero target + then do + -- Focus on the hero being wounded. + b <- selectPlayer target + -- Display status line for the new hero. + when b $ display >> return () + else return () + +summonHeroes :: Int -> Loc -> Action () +summonHeroes n loc = + assert (n > 0) $ do + newHeroIndex <- gets (fst . scounter) + modify (\ state -> iterate (addHero loc) state !! n) + assertTrue $ selectPlayer (AHero newHeroIndex) + -- Display status line for the new hero. + display >> return () + +summonMonsters :: Int -> Loc -> Action () +summonMonsters n loc = do + let fmk = Frequency $ L.zip (L.map nfreq dungeonMonsters) dungeonMonsters + mk <- liftIO $ rndToIO $ frequency fmk + modify (\ state -> iterate (addMonster mk (nhpMax mk) loc) state !! n) + +-- | Remove dead heroes, check if game over. +-- For now we only check the selected hero, but if poison, etc. +-- is implemented, we'd need to check all heroes on the level. +checkPartyDeath :: Action () +checkPartyDeath = + do + ahs <- gets allHeroesAnyLevel + pl <- gets splayer + pbody <- gets getPlayerBody + config <- gets sconfig + when (mhp pbody <= 0) $ do -- TODO: change to guard? define mzero? Why are the writes to to files performed when I call abort later? That probably breaks the laws of MonadPlus. + go <- messageMoreConfirm True $ + subjectMovableVerb (mkind pbody) "die" ++ "." + history -- Prevent the messages from being repeated. + let firstDeathEnds = Config.get config "heroes" "firstDeathEnds" + if firstDeathEnds + then gameOver go + else case L.filter (\ (actor, _) -> actor /= pl) ahs of + [] -> gameOver go + (actor, _nln) : _ -> do + messageAdd "The survivors carry on." + -- Remove the dead player. + modify (deleteActor pl) + -- At this place the invariant that the player exists fails. + -- Focus on the new hero (invariant not needed). + assertTrue $ selectPlayer actor + -- At this place the invariant is restored again. + +-- | End game, showing the ending screens, if requested. +gameOver :: Bool -> Action () +gameOver showEndingScreens = + do + when showEndingScreens $ do + state <- get + ln <- gets (lname . slevel) + let total = calculateTotal state + status = H.Killed ln + handleScores True status total + messageMore "Let's hope another party can save the day!" + end + +-- | Calculate loot's worth for heroes on the current level. +calculateTotal :: State -> Int +calculateTotal s = + L.sum $ L.map itemPrice $ L.concatMap mitems (levelHeroList s) + +-- | Handle current score and display it with the high scores. Scores +-- should not be shown during the game, +-- because ultimately the worth of items might give +-- information about the nature of the items. +-- False if display of the scores was void or interrupted by the user +handleScores :: Bool -> H.Status -> Int -> Action Bool +handleScores write status total = + if (total == 0) + then return False + else do + config <- gets sconfig + time <- gets stime + curDate <- liftIO getClockTime + let points = case status of + H.Killed _ -> (total + 1) `div` 2 + _ -> total + let score = H.ScoreRecord points (-time) curDate status + (placeMsg, slideshow) <- liftIO $ H.register config write score + messageOverlaysConfirm placeMsg slideshow + +-- | Perform a level switch to a given level. False, if nothing to do. +lvlSwitch :: LevelId -> Action Bool +lvlSwitch nln = + do + ln <- gets (lname . slevel) + if (nln == ln) + then return False + else do + level <- gets slevel + dungeon <- gets sdungeon + -- put back current level + -- (first put back, then get, in case we change to the same level!) + let full = putDungeonLevel level dungeon + -- get new level + let (new, ndng) = getDungeonLevel nln full + modify (\ s -> s { sdungeon = ndng, slevel = new }) + return True + +-- effectToAction does not depend on this function right now, but it might, +-- and I know no better place to put it. +displayItems :: Message -> Bool -> [Item] -> Action Bool +displayItems msg sorted is = do + state <- get + let inv = unlines $ + L.map (\ i -> letterLabel (iletter i) ++ objectItem state i ++ " ") + ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is) + let ovl = inv ++ more + messageWipeAndSet msg + overlay ovl + +stopRunning :: Action () +stopRunning = updatePlayerBody (\ p -> p { mdir = Nothing }) + +-- | Store current message in the history and reset current message. +history :: Action () +history = + do + (_, sx) <- gets (lsize . slevel) + msg <- resetMessage + config <- gets sconfig + let historyMax = Config.get config "ui" "historyMax" + -- TODO: not ideal, continuations of sentences are atop beginnings. + split = splitMsg sx (msg ++ " ") + unless (L.null msg) $ + modify (updateHistory (take historyMax . (L.reverse split ++))) diff --git a/src/FOV.hs b/src/FOV.hs new file mode 100644 --- /dev/null +++ b/src/FOV.hs @@ -0,0 +1,49 @@ +module FOV where + +import Data.Map as M +import Data.Set as S +import Data.List as L +import Data.Ratio +import Data.Maybe + +import FOV.Common +import FOV.Digital +import FOV.Permissive +import FOV.Shadow +import Geometry +import Level + +-- import Debug.Trace + +data FovMode = Shadow | Permissive Int | Digital Int | Blind + +-- Three Field of View algorithms. Press 'V' to cycle among them in the game. + +-- The main FOV function. + +-- | Perform a full scan for a given location. Returns the locations +-- that are currently in the field of view. +fullscan :: FovMode -> Loc -> LMap -> Set Loc +fullscan fovMode loc lmap = + case fovMode of + Shadow -> -- shadow casting with infinite range + S.unions $ + L.map (\ tr -> + scan (tr loc) lmap 1 (0,1)) -- was: scan (tr loc) lmap 0 (0,1); TODO: figure out what difference this makes + [tr0,tr1,tr2,tr3,tr4,tr5,tr6,tr7] + Permissive r -> -- permissive with range r + S.unions $ + L.map (\ tr -> + pscan r (tr loc) lmap 1 + (((B(1, 0), B(0, r+1)), [B(0, 1)]), + ((B(0, 1), B(r+1, 0)), [B(1, 0)]))) + [qtr0,qtr1,qtr2,qtr3] + Digital r -> -- digital with range r + S.unions $ + L.map (\ tr -> + dscan r (tr loc) lmap 1 + (((B(0, 1), B(r, -r)), [B(0, 0)]), + ((B(0, 0), B(r, r+1)), [B(0, 1)]))) + [qtr0,qtr1,qtr2,qtr3] + Blind -> -- only feeling out adjacent tiles by touch + S.empty diff --git a/src/FOV/Common.hs b/src/FOV/Common.hs new file mode 100644 --- /dev/null +++ b/src/FOV/Common.hs @@ -0,0 +1,58 @@ +module FOV.Common where + +import Data.List as L + +import Geometry + +type Interval = (Rational, Rational) +type Distance = Int +type Progress = Int +newtype Bump = B Loc deriving (Show) +type Line = (Bump, Bump) +type ConvexHull = [Bump] +type Edge = (Line, ConvexHull) +type EdgeInterval = (Edge, Edge) + +-- | The translation, rotation and symmetry functions for octants. +tr0 (oy,ox) (d,p) = (oy + d,ox + p) +tr1 (oy,ox) (d,p) = (oy + d,ox - p) +tr2 (oy,ox) (d,p) = (oy - d,ox + p) +tr3 (oy,ox) (d,p) = (oy - d,ox - p) +tr4 (oy,ox) (d,p) = (oy + p,ox + d) +tr5 (oy,ox) (d,p) = (oy + p,ox - d) +tr6 (oy,ox) (d,p) = (oy - p,ox + d) +tr7 (oy,ox) (d,p) = (oy - p,ox - d) + +-- | The translation and rotation functions for quadrants. +qtr0, qtr1, qtr2, qtr3 :: Loc -> Bump -> Loc +qtr0 (oy, ox) (B(y, x)) = (oy - y, ox + x) -- first quadrant +qtr1 (oy, ox) (B(y, x)) = (oy - x, ox - y) -- then rotated clockwise 90 degrees +qtr2 (oy, ox) (B(y, x)) = (oy + y, ox - x) +qtr3 (oy, ox) (B(y, x)) = (oy + x, ox + y) + +-- | Integer division, rounding up. +divUp n k = - (-n) `div` k + +-- | Maximal element of a non-empty list. Prefers elements from the rear, +-- which is essential for PFOV, to avoid ill-defined lines. +maximal :: (a -> a -> Bool) -> [a] -> a +maximal gte = L.foldl1' (\ acc x -> if gte x acc then x else acc) + +-- | Check if the line from the second point to the first is more steep +-- than the line from the third point to the first. This is related +-- to the formal notion of gradient (or angle), but hacked wrt signs +-- to work in this particular setup. Returns True for ill-defined lines. +steeper :: Bump -> Bump -> Bump -> Bool +steeper (B(yf, xf)) (B(y1, x1)) (B(y2, x2)) = + (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1) + +-- | Adds a bump to the convex hull of bumps represented as a list. +addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull +addHull gte b l = + case l of + x:y:zs -> + if gte x y + then addHull gte b (y:zs) + else b : l + _ -> b : l + diff --git a/src/FOV/Digital.hs b/src/FOV/Digital.hs new file mode 100644 --- /dev/null +++ b/src/FOV/Digital.hs @@ -0,0 +1,138 @@ +module FOV.Digital where + +import Data.Set as S + +import FOV.Common +import Geometry +import Level +import qualified Tile + +-- Digital FOV with a given range. + +-- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation, +-- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been +-- implemented before. The algorithm is based on the PFOV algorithm, +-- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View. +-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los +-- for some more context. + +-- | The current state of a scan is kept in Maybe (Line, ConvexHull). +-- If Just something, we're in a visible interval. If Nothing, we're in +-- a shadowed interval. +dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval -> + Set Loc +dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) = + -- trace (show (d,s,e,ps,pe)) $ + S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]]) + -- the scanned area is a square, which is a sphere in this metric; good + where + ps = let (n, k) = dintersect sl d -- minimal progress to check + in n `div` k + pe = let (n, k) = dintersect el d -- maximal progress to check + -- Corners obstruct view, so the steep line, constructed + -- from corners, is itself not a part of the view, + -- so if its intersection with the line of diagonals is only + -- at a corner, choose the diamond leading to a smaller view. + in -1 + n `divUp` k + outside + | d >= r = S.empty + | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe)) + | Tile.open (l `at` tr (B(d, ps))) = + dscan' (Just s) (ps+1) -- start in light, jump ahead + | otherwise = dscan' Nothing (ps+1) -- start in shadow, jump ahead + + dscan' :: Maybe Edge -> Progress -> Set Loc + dscan' (Just s@(_, sBumps)) ps + | ps > pe = dscan r tr l (d+1) (s, e) -- reached end, scan next + | Tile.closed (l `at` tr steepBump) = -- entering shadow + S.union + (dscan r tr l (d+1) (s, (dline nep steepBump, neBumps))) + (dscan' Nothing (ps+1)) + | otherwise = dscan' (Just s) (ps+1) -- continue in light + where + steepBump = B(d, ps) + gte = dsteeper steepBump + nep = maximal gte sBumps + neBumps = addHull gte steepBump eBumps + + dscan' Nothing ps + | ps > pe = S.empty -- reached end while in shadow + | Tile.open (l `at` tr shallowBump) = -- moving out of shadow + dscan' (Just (dline nsp shallowBump, nsBumps)) (ps+1) + | otherwise = dscan' Nothing (ps+1) -- continue in shadow + where + shallowBump = B(d, ps) + gte = flip $ dsteeper shallowBump + nsp = maximal gte eBumps + nsBumps = addHull gte shallowBump sBumps + + dline p1 p2 = + ddebugLine $ -- TODO: disable when it becomes a bottleneck + (p1, p2) + + dsteeper f p1 p2 = + ddebugSteeper f p1 p2 $ -- TODO: disable when it becomes a bottleneck + steeper f p1 p2 + +-- | The x coordinate, represented as a fraction, of the intersection of +-- a given line and the line of diagonals of diamonds at distance d from (0, 0). +dintersect :: Line -> Distance -> (Int, Int) +dintersect (B(y, x), B(yf, xf)) d = + ((d - y)*(xf - x) + x*(yf - y), yf - y) +{- +Derivation of the formula: +The intersection point (yt, xt) satisfies the following equalities: +yt = d +(yt - y) (xf - x) = (xt - x) (yf - y) +hence +(yt - y) (xf - x) = (xt - x) (yf - y) +(d - y) (xf - x) = (xt - x) (yf - y) +(d - y) (xf - x) + x (yf - y) = xt (yf - y) +xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y) + +General remarks: +A diamond is denoted by its left corner. Hero at (0,0). +Order of processing in the first quadrant rotated by 45 degrees is + 45678 + 123 + @ +so the first processed diamond is at (-1, 1). The order is similar +as for the shadow casting algorithm above and reversed wrt PFOV. +The line in the curent state of scan' is called the shallow line, +but it's the one that delimits the view from the left, while the steep +line is on the right, opposite to PFOV. We start scanning from the left. + +The Loc coordinates are cartesian, the Bump coordinates are cartesian, +translated so that the hero is at (0, 0) and rotated so that he always +looks at the first roatated quadrant, the (Distance, Progress) cordinates +coincide with the Bump coordinates, unlike in PFOV. +-} + +-- | Debug functions for DFOV: + +-- | Debug: calculate steeper for DFOV in another way and compare results. +ddebugSteeper :: Bump -> Bump -> Bump -> Bool -> Bool +ddebugSteeper f p1 p2 x = + let (n1, k1) = dintersect (p1, f) 0 + (n2, k2) = dintersect (p2, f) 0 + in if x == (n1 * k2 >= k1 * n2) + then x + else error $ "dsteeper: " ++ show (f, p1, p2, x) + +-- | Debug: check is a view border line for DFOV is legal. +ddebugLine :: Line -> Line +ddebugLine line@(B(y1, x1), B(y2, x2)) + | y1 == y2 && x1 == x2 = + error $ "ddebugLine: wrongly defined line " ++ show line + | y2 - y1 == 0 = + error $ "ddebugLine: horizontal line " ++ show line + | crossL0 = + error $ "ddebugLine: crosses the X axis below 0 " ++ show line + | crossG1 = + error $ "ddebugLine: crosses the X axis above 1 " ++ show line + | otherwise = line + where + (n, k) = dintersect line 0 + (q, r) = if k == 0 then (0, 0) else n `divMod` k + crossL0 = q < 0 -- q truncated toward negative infinity + crossG1 = q >= 1 && (q > 1 || r /= 0) diff --git a/src/FOV/Permissive.hs b/src/FOV/Permissive.hs new file mode 100644 --- /dev/null +++ b/src/FOV/Permissive.hs @@ -0,0 +1,151 @@ +module FOV.Permissive where + +import Data.Set as S + +import FOV.Common +import Geometry +import Level +import qualified Tile + +-- Permissive FOV with a given range. + +-- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View, +-- though the general structure is more influenced by recursive shadow casting, +-- as implemented in Shadow.hs. In the result, this algorithm is much faster +-- than the original algorithm on dense maps, since it does not scan +-- areas blocked by shadows. +-- See https://github.com/Mikolaj/LambdaHack/wiki/Fov-and-los +-- for some more context. + +-- TODO: Scanning squares on horizontal lines in octants, not squares +-- on diagonals in quadrants, may be much faster and a bit simpler. +-- Right now we build new view on each end of each visible wall tile +-- and this is necessary only for straight, thin, diagonal walls. + +-- | The current state of a scan is kept in Maybe (Line, ConvexHull). +-- If Just something, we're in a visible interval. If Nothing, we're in +-- a shadowed interval. +pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval -> + Set Loc +pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) = + -- trace (show (d,s,e,ps,pe)) $ + if illegal + then S.empty + else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]]) + -- the area is diagonal, which is incorrect, but looks good enough + where + (ns, ks) = pintersect sl d + (ne, ke) = pintersect el d + -- Corners are translucent, so they are invisible, so if intersection + -- is at a corner, choose pe that creates the smaller view. + (ps, pe) = (ns `div` ks, ne `divUp` ke - 1) -- progress interval to check + -- Single ray from an extremity, produces non-permissive digital lines. + illegal = let (n, k) = pintersect sl 0 + in ns*ke == ne*ks && (n == 0 || n == k) + outside + | d >= r = S.empty + | Tile.open (l `at` tr (d, ps)) = pscan' (Just s) ps -- start in light + | ps == ns `divUp` ks = pscan' (Just s) ps -- start in a corner + | otherwise = pscan' Nothing (ps+1) -- start in mid-wall + + dp2bump (d, p) = B(p, d - p) + bottomRight (d, p) = B(p, d - p + 1) + tr = ptr . dp2bump + + pscan' :: Maybe Edge -> Progress -> Set Loc + pscan' (Just s@(_, sBumps)) ps + | ps > pe = -- reached end, scan next + pscan r ptr l (d+1) (s, e) + | Tile.closed (l `at` tr (d, ps)) = -- entering shadow, steep bump + let steepBump = bottomRight (d, ps) + gte = flip $ psteeper steepBump + -- sBumps may contain steepBump, but maximal will ignore it + nep = maximal gte sBumps + neBumps = addHull gte steepBump eBumps + in S.union + (pscan r ptr l (d+1) (s, (pline nep steepBump, neBumps))) + (pscan' Nothing (ps+1)) + | otherwise = pscan' (Just s) (ps+1) -- continue in light + + pscan' Nothing ps + | ps > ne `div` ke = S.empty -- reached absolute end + | otherwise = -- out of shadow, shallow bump + -- the light can be just through a corner of diagonal walls + -- and the recursive call verifies that at the same ps coordinate + let shallowBump = bottomRight (d, ps) + gte = psteeper shallowBump + nsp = maximal gte eBumps + nsBumps = addHull gte shallowBump sBumps + in pscan' (Just (pline nsp shallowBump, nsBumps)) ps + + pline p1 p2 = + pdebugLine $ -- TODO: disable when it becomes a bottleneck + (p1, p2) + + psteeper f p1 p2 = + pdebugSteeper f p1 p2 $ -- TODO: disable when it becomes a bottleneck + steeper f p1 p2 + +-- | The y coordinate, represented as a fraction, of the intersection of +-- a given line and the line of diagonals of squares at distance d from (0, 0). +pintersect :: Line -> Distance -> (Int, Int) +pintersect (B(y, x), B(yf, xf)) d = + ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y)) +{- +Derivation of the formula: +The intersection point (yt, xt) satisfies the following equalities: +xt = 1 + d - yt +(yt - y) (xf - x) = (xt - x) (yf - y) +hence +(yt - y) (xf - x) = (xt - x) (yf - y) +yt (xf - x) - y xf = xt (yf - y) - x yf +yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf +yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf +yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y) + +General remarks: +A square is denoted by its bottom-left corner. Hero at (0,0). +Order of processing in the first quadrant is +9 +58 +247 +@136 +so the first processed square is at (0, 1). The order is reversed +wrt the shadow casting algorithm above. The line in the curent state +of scan' is not the steep line, but the shallow line, +and we start scanning from the bottom right. + +The Loc coordinates are cartesian, the Bump coordinates are cartesian, +translated so that the hero is at (0, 0) and rotated so that he always +looks at the first quadrant, the (Distance, Progress) cordinates +are mangled and not used for geometry. +-} + +-- | Debug functions for PFOV: + +-- | Debug: calculate steeper for PFOV in another way and compare results. +pdebugSteeper :: Bump -> Bump -> Bump -> Bool -> Bool +pdebugSteeper f p1 p2 x = + let (n1, k1) = pintersect (p1, f) 0 + (n2, k2) = pintersect (p2, f) 0 + in if x == (n1 * k2 <= k1 * n2) + then x + else error $ "psteeper: " ++ show (f, p1, p2, x) + +-- | Debug: checks postconditions of borderLine. +pdebugLine :: Line -> Line +pdebugLine line@(B(y1, x1), B(y2, x2)) + | y1 == y2 && x1 == x2 = + error $ "pdebugLine: wrongly defined line " ++ show line + | x2 - x1 == - (y2 - y1) = + error $ "pdebugLine: diagonal line " ++ show line + | crossL0 = + error $ "pdebugLine: crosses diagonal below 0 " ++ show line + | crossG1 = + error $ "pdebugLine: crosses diagonal above 1 " ++ show line + | otherwise = line + where + (n, k) = pintersect line 0 + (q, r) = if k == 0 then (0, 0) else n `divMod` k + crossL0 = q < 0 -- q truncated toward negative infinity + crossG1 = q >= 1 && (q > 1 || r /= 0) diff --git a/src/FOV/Shadow.hs b/src/FOV/Shadow.hs new file mode 100644 --- /dev/null +++ b/src/FOV/Shadow.hs @@ -0,0 +1,106 @@ +module FOV.Shadow where + +import Data.Ratio +import Data.Set as S + +import FOV.Common +import Geometry +import Level +import qualified Tile + +-- Recursive Shadow Casting. + +-- | A restrictive variant of Recursive Shadow Casting FOV with infinite range. +-- It's not designed for dungeons with diagonal walls, so they block visibility, +-- though they don't block movement. Such cases appear in the game only +-- when two corridors touch diagonally by accident and on the random pillars +-- levels. + +{- +Field Of View +------------- + +The algorithm used is a variant of Shadow Casting. We first compute +fields that are reachable (have unobstructed line of sight) from the hero's +position. Later, in Perception.hs, from this information we compute +the fields that are visible (not hidden in darkness, etc.). + +As input to the algorithm, we require information about fields that +block light. As output, we get information on the reachability of all fields. +We assume that the hero is located at position (0, 0) +and we only consider fields (line, row) where line >= 0 and 0 <= row <= line. +This is just about one eighth of the whole hero's surroundings, +but the other parts can be computed in the same fashion by mirroring +or rotating the given algorithm accordingly. + + fov (blocks, maxline) = + shadow := \empty_set + reachable (0, 0) := True + for l \in [ 1 .. maxline ] do + for r \in [ 0 .. l ] do + reachable (l, r) := ( \exists a. a \in interval (l, r) \and + a \not_in shadow) + if blocks (l, r) then + shadow := shadow \union interval (l, r) + end if + end for + end for + return reachable + + interval (l, r) = return [ angle (l + 0.5, r - 0.5), + angle (l - 0.5, r + 0.5) ] + angle (l, r) = return atan (r / l) + +The algorithm traverses the fields line by line, row by row. +At every moment, we keep in shadow the intervals which are in shadow, +measured by their angle. A square is reachable when any point +in it is not in shadow --- the algorithm is permissive in this respect. +We could also require that a certain fraction of the field is reachable, +or a specific point. Our choice has certain consequences. For instance, +a single blocking field throws a shadow, but the fields immediately behind +the blocking field are still visible. + +We can compute the interval of angles corresponding to one square field +by computing the angle of the line passing the upper left corner +and the angle of the line passing the lower right corner. +This is what interval and angle do. If a field is blocking, the interval +for the square is added to the shadow set. +-} + +-- | The current state of a scan is kept in a variable of Maybe Rational. +-- If Just something, we're in a visible interval. If Nothing, we're in +-- a shadowed interval. +scan :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc +scan tr l d (s,e) = + let ps = downBias (s * fromIntegral d) -- minimal progress to check + pe = upBias (e * fromIntegral d) -- maximal progress to check + st = if Tile.open (l `at` tr (d,ps)) then Just s -- start in light + else Nothing -- start in shadow + in + -- trace (show (d,s,e,ps,pe)) $ + S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe) + where + scan' :: Maybe Rational -> Progress -> Progress -> Set Loc + -- scan' st ps pe + -- | trace (show (st,ps,pe)) False = undefined + scan' (Just s) ps pe + | s >= e = S.empty -- empty interval + | ps > pe = scan tr l (d+1) (s,e) -- reached end, scan next + | Tile.closed (l `at` tr (d,ps)) = + let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2)) + in scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe + -- entering shadow + | otherwise = scan' (Just s) (ps+1) pe + -- continue in light + scan' Nothing ps pe + | ps > pe = S.empty -- reached end while in shadow + | Tile.open (l `at` tr (d,ps)) = + let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2)) + in scan' (Just ns) (ps+1) pe + -- moving out of shadow + | otherwise = scan' Nothing (ps+1) pe + -- continue in shadow + +downBias, upBias :: (Integral a, Integral b) => Ratio a -> b +downBias x = round (x - 1 % (denominator x * 3)) +upBias x = round (x + 1 % (denominator x * 3)) diff --git a/src/File.hs b/src/File.hs new file mode 100644 --- /dev/null +++ b/src/File.hs @@ -0,0 +1,22 @@ +module File where + +import System.IO +import Data.Binary +import qualified Data.ByteString.Lazy as LBS +import Codec.Compression.Zlib as Z + +strictReadCompressedFile :: FilePath -> IO LBS.ByteString +strictReadCompressedFile f = + do + h <- openBinaryFile f ReadMode + c <- LBS.hGetContents h + let d = Z.decompress c + LBS.length d `seq` return d + +strictDecodeCompressedFile :: Binary a => FilePath -> IO a +strictDecodeCompressedFile = fmap decode . strictReadCompressedFile + +encodeCompressedFile :: Binary a => FilePath -> a -> IO () +encodeCompressedFile f = LBS.writeFile f . Z.compress . encode + -- note that LBS.writeFile opens the file in binary mode + diff --git a/src/Frequency.hs b/src/Frequency.hs new file mode 100644 --- /dev/null +++ b/src/Frequency.hs @@ -0,0 +1,31 @@ +module Frequency where + +import Control.Monad + +newtype Frequency a = Frequency { runFrequency :: [(Int, a)] } + deriving Show + +instance Monad Frequency where + return x = Frequency [(1, x)] + m >>= f = Frequency + [(p * q, y) | (p, x) <- runFrequency m, + (q, y) <- runFrequency (f x) ] + fail "" = Frequency [] + +instance MonadPlus Frequency where + mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys) + mzero = Frequency [] + +instance Functor Frequency where + fmap f (Frequency xs) = Frequency (map (\ (p, x) -> (p, f x)) xs) + +-- only try the second possibility if the first fails +melse :: Frequency a -> Frequency a -> Frequency a +melse (Frequency []) y = y +melse x y = x + +scale :: Int -> Frequency a -> Frequency a +scale n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs) + +uniform :: [a] -> Frequency a +uniform = Frequency . map (\ x -> (1, x)) diff --git a/src/Geometry.hs b/src/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Geometry.hs @@ -0,0 +1,116 @@ +module Geometry where + +import Data.List as L + +-- | Game time in turns. (Placement in module Geometry is not ideal.) +type Time = Int + +-- | Vertical directions. +data VDir = Up | Down + deriving (Eq, Ord, Show, Enum, Bounded) + +type X = Int +type Y = Int + +type Loc = (Y,X) +type Dir = (Y,X) +type Area = ((Y,X),(Y,X)) + +-- | Given two locations, determine the direction in which one should +-- move from the first in order to get closer to the second. Does not +-- pay attention to obstacles at all. +towards :: (Loc,Loc) -> Dir +towards ((y0,x0),(y1,x1)) = + let dy = y1 - y0 + dx = x1 - x0 + angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2) + dir | angle <= -0.75 = (-1,0) + | angle <= -0.25 = (-1,1) + | angle <= 0.25 = (0,1) + | angle <= 0.75 = (1,1) + | angle <= 1.25 = (1,0) + | otherwise = (0,0) + in if dx >= 0 then dir else neg dir + +-- | Get the squared distance between two locations. +distance :: (Loc,Loc) -> Int +distance ((y0,x0),(y1,x1)) = (y1 - y0)^2 + (x1 - x0)^2 + +-- | Return whether two locations are adjacent on the map +-- (horizontally, vertically or diagonally). Currrently, a +-- position is also considered adjacent to itself. +adjacent :: Loc -> Loc -> Bool +adjacent s t = distance (s,t) <= 2 + +-- | Return the 8 surrounding locations of a given location. +surroundings :: Loc -> [Loc] +surroundings l = map (l `shift`) moves + +diagonal :: Dir -> Bool +diagonal (y,x) = y*x /= 0 + +-- | Move one square in the given direction. +shift :: Loc -> Dir -> Loc +shift (y0,x0) (y1,x1) = (y0+y1,x0+x1) + +-- | Invert a direction (vector). +neg :: Dir -> Dir +neg (y,x) = (-y,-x) + +-- | Get the vectors of all the moves, clockwise, starting north-west. +moves :: [Dir] +moves = [(-1,-1), (-1,0), (-1,1), (0,1), (1,1), (1,0), (1,-1), (0,-1)] + +up, down, left, right :: Dir +upleft, upright, downleft, downright :: Dir +upleft = up `shift` left +upright = up `shift` right +downleft = down `shift` left +downright = down `shift` right +up = (-1,0) +down = (1,0) +left = (0,-1) +right = (0,1) + +horiz, vert :: [Dir] +horiz = [left, right] +vert = [up, down] + +neighbors :: Area -> {- size limitation -} + Loc -> {- location to find neighbors of -} + [Loc] +neighbors area (y,x) = + let cs = [ (y + dy, x + dx) + | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ] + in L.filter (`inside` area) cs + +inside :: Loc -> Area -> Bool +inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0 + +fromTo :: Loc -> Loc -> [Loc] +fromTo (y0,x0) (y1,x1) + | y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1) + | x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1) + +fromTo1 :: X -> X -> [X] +fromTo1 x0 x1 + | x0 <= x1 = [x0..x1] + | otherwise = [x0,x0-1..x1] + +normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X)) +normalize (a,b) | a <= b = (a,b) + | otherwise = (b,a) + +normalizeArea :: Area -> Area +normalizeArea a@((y0,x0),(y1,x1)) = + ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1)) + +grid :: (Y,X) -> Area -> [((Y,X), Area)] +grid (ny,nx) ((y0,x0),(y1,x1)) = + let yd = y1 - y0 + xd = x1 - x0 + in [ ((y, x), ((y0 + (yd * y `div` ny), + x0 + (xd * x `div` nx)), + (y0 + (yd * (y + 1) `div` ny - 1), + x0 + (xd * (x + 1) `div` nx - 1)))) + | x <- [0..nx-1], y <- [0..ny-1] ] diff --git a/src/GeometryRnd.hs b/src/GeometryRnd.hs new file mode 100644 --- /dev/null +++ b/src/GeometryRnd.hs @@ -0,0 +1,58 @@ +module GeometryRnd where + +import Data.List as L +import Data.Set as S + +import Geometry +import Random + +findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc +findLocInArea a@((y0, x0), (y1, x1)) p = do + rx <- randomR (x0, x1) + ry <- randomR (y0, y1) + let loc = (ry, rx) + if p loc then return loc else findLocInArea a p + +locInArea :: Area -> Rnd Loc +locInArea a = findLocInArea a (const True) + +connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X), (Y,X))] -> + Rnd [((Y,X), (Y,X))] +connectGrid' (ny, nx) unconnected candidates acc + | S.null candidates = return (L.map normalize acc) + | otherwise = do + c <- oneOf (S.toList candidates) + -- potential new candidates: + let ns = S.fromList $ neighbors ((0,0),(ny-1,nx-1)) c + nu = S.delete c unconnected -- new unconnected + -- (new candidates, potential connections): + (nc, ds) = S.partition (`S.member` nu) ns + new <- if S.null ds + then return id + else do + d <- oneOf (S.toList ds) + return ((c,d) :) + connectGrid' (ny,nx) nu (S.delete c (candidates `S.union` nc)) (new acc) + +connectGrid :: (Y,X) -> Rnd [((Y,X), (Y,X))] +connectGrid (ny, nx) = do + let unconnected = S.fromList [ (y, x) | x <- [0..nx-1], y <- [0..ny-1] ] + -- candidates are neighbors that are still unconnected; we start with + -- a random choice + rx <- randomR (0, nx-1) + ry <- randomR (0, ny-1) + let candidates = S.fromList [ (ry, rx) ] + connectGrid' (ny, nx) unconnected candidates [] + +randomConnection :: (Y,X) -> Rnd ((Y,X), (Y,X)) +randomConnection (ny, nx) = do + rb <- randomR (False, True) + if rb + then do + rx <- randomR (0, nx-2) + ry <- randomR (0, ny-1) + return (normalize ((ry, rx), (ry, rx+1))) + else do + ry <- randomR (0, ny-2) + rx <- randomR (0, nx-1) + return (normalize ((ry, rx), (ry+1, rx))) diff --git a/src/Grammar.hs b/src/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Grammar.hs @@ -0,0 +1,84 @@ +module Grammar where + +import Data.Char +import Data.Set as S +import Data.List as L +import qualified Data.IntMap as IM + +import Item +import Movable +import MovableKind +import State +import ItemKind +import Effect + + +suffixS :: String -> String +suffixS word = case last word of + 'y' -> init word ++ "ies" + 's' -> word ++ "es" + 'x' -> word ++ "es" + _ -> word ++ "s" + +capitalize :: String -> String +capitalize [] = [] +capitalize (c : cs) = toUpper c : cs + +-- | How to refer to a movable in object position of a sentence. +objectMovable :: MovableKind -> String +objectMovable mk = nname mk + +-- | How to refer to a movable in subject position of a sentence. +subjectMovable :: MovableKind -> String +subjectMovable x = capitalize $ objectMovable x + +verbMovable :: MovableKind -> String -> String +verbMovable mk v = if nname mk == "you" then v else suffixS v + +-- | Sentences such like "The dog barks". +subjectMovableVerb :: MovableKind -> String -> String +subjectMovableVerb x v = subjectMovable x ++ " " ++ verbMovable x v + +compoundVerbMovable :: MovableKind -> String -> String -> String +compoundVerbMovable m v p = verbMovable m v ++ " " ++ p + +subjectVerbIObject :: State -> Movable -> String -> Item -> String -> String +subjectVerbIObject state m v o add = + subjectMovable (mkind m) ++ " " ++ + verbMovable (mkind m) v ++ " " ++ + objectItem state o ++ add ++ "." + +subjectVerbMObject :: Movable -> String -> Movable -> String -> String +subjectVerbMObject m v o add = + subjectMovable (mkind m) ++ " " ++ + verbMovable (mkind m) v ++ " " ++ + objectMovable (mkind o) ++ add ++ "." + +subjCompoundVerbIObj :: State -> Movable -> String -> String -> + Item -> String -> String +subjCompoundVerbIObj state m v p o add = + subjectMovable (mkind m) ++ " " ++ + compoundVerbMovable (mkind m) v p ++ " " ++ + objectItem state o ++ add ++ "." + +makeObject :: Int -> (String -> String) -> String -> String +makeObject 1 adj obj = let b = adj obj + in case b of + (c:_) | c `elem` "aeio" -> "an " ++ b + _ -> "a " ++ b +makeObject n adj obj = show n ++ " " ++ adj (suffixS obj) + +objectItem :: State -> Item -> String +objectItem state o = + let ik = ikind o + kind = ItemKind.getIK ik + identified = L.length (jflavour kind) == 1 || + ik `S.member` sdiscoveries state + addSpace s = if s == "" then "" else " " ++ s + eff = effectToName (jeffect kind) + pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")" + adj name = if identified + then name ++ addSpace eff ++ addSpace pwr + else let flavour = getFlavour (sassocs state) ik + in flavourToName flavour ++ " " ++ name + in makeObject (icount o) adj (jname kind) diff --git a/src/HighScores.hs b/src/HighScores.hs new file mode 100644 --- /dev/null +++ b/src/HighScores.hs @@ -0,0 +1,161 @@ +module HighScores where + +import System.Directory +import Control.Exception as E hiding (handle) +import Control.Monad +import Text.Printf +import System.Time + +import Data.Binary +import Data.List as L +import Data.Maybe + +import File +import Dungeon +import qualified Config +import WorldLoc + +-- | A single score. +-- TODO: add heroes' names, exp and level, cause of death, user number/name. +-- Note: I tried using Date.Time, but got all kinds of problems, +-- including build problems and opaque types that make serialization difficult, +-- and I couldn't use Datetime because it needs old base (and is under GPL). +-- TODO: When we finally move to Date.Time, let's take timezone into account. +data ScoreRecord = ScoreRecord + { points :: Int, + negTurn :: Int, + date :: ClockTime, + status :: Status} + deriving (Eq, Ord) + +data Status = Killed LevelId | Camping LevelId | Victor + deriving (Eq, Ord) + +instance Binary ClockTime where + put (TOD s p) = + do + put s + put p + get = + do + s <- get + p <- get + return (TOD s p) + +instance Binary Status where + put (Killed ln) = putWord8 0 >> put ln + put (Camping ln) = putWord8 1 >> put ln + put Victor = putWord8 2 + get = do + tag <- getWord8 + case tag of + 0 -> liftM Killed get + 1 -> liftM Camping get + 2 -> return Victor + +instance Binary ScoreRecord where + put (ScoreRecord points negTurn date status) = + do + put points + put negTurn + put date + put status + get = + do + points <- get + negTurn <- get + date <- get + status <- get + return (ScoreRecord points negTurn date status) + +-- | Show a single high score. +showScore :: (Int, ScoreRecord) -> String +showScore (pos, score) = + let died = + case status score of + Killed (LambdaCave n) -> "perished on level " ++ show n ++ "," + Camping (LambdaCave n) -> "is camping on level " ++ show n ++ "," + Victor -> "emerged victorious" + time = calendarTimeToString . toUTCTime . date $ score + big = " " + lil = " " + -- TODO: later: https://github.com/kosmikus/LambdaHack/issues#issue/9 + steps = negTurn score `div` (-10) + in + printf + "%s\n%4d. %6d This adventuring party %s after %d steps \n%son %s. \n" + big pos (points score) died steps lil time + +-- | The list of scores, in decreasing order. +type ScoreTable = [ScoreRecord] + +-- | Empty score table +empty :: ScoreTable +empty = [] + +-- | Name of the high scores file. +file :: Config.CP -> IO String +file config = Config.getFile config "files" "highScores" + +-- | We save a simple serialized version of the high scores table. +-- The 'False' is used only as an EOF marker. +save :: Config.CP -> ScoreTable -> IO () +save config scores = + do + f <- file config + E.catch (removeFile f) (\ e -> case e :: IOException of _ -> return ()) + encodeCompressedFile f (scores, False) + +-- | Read the high scores table. Return the empty table if no file. +restore :: Config.CP -> IO ScoreTable +restore config = + E.catch (do + f <- file config + (x, z) <- strictDecodeCompressedFile f + (z :: Bool) `seq` return x) + (\ e -> case e :: IOException of + _ -> return []) + +-- | Insert a new score into the table, Return new table and the position. +insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) +insertPos s h = + let (prefix, suffix) = L.span (\ x -> x > s) h in + (prefix ++ [s] ++ suffix, L.length prefix + 1) + +-- | Show a screenful of the high scores table. +-- Parameter height is the number of (3-line) scores to be shown. +showTable :: ScoreTable -> Int -> Int -> String +showTable h start height = + let zipped = zip [1..] h + screenful = take height . drop (start - 1) $ zipped + in + L.concatMap showScore screenful + +-- | Produces a couple of renderings of the high scores table. +slideshow :: Int -> ScoreTable -> Int -> [String] +slideshow pos h height = + if pos <= height + then [showTable h 1 height] + else [showTable h 1 height, + showTable h (max (height + 1) (pos - height `div` 2)) height] + +-- | Take care of a new score, return a list of messages to display. +register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String]) +register config write s = + do + h <- restore config + let (h', pos) = insertPos s h + (lines, _) = normalLevelSize + height = lines `div` 3 + (msgCurrent, msgUnless) = + case status s of + Killed _ -> (" short-lived", " (score halved)") + Camping _ -> (" current", " (unless you are slain)") + Victor -> (" glorious", + if pos <= height + then " among the greatest heroes" + else "") + msg = printf "Your%s exploits award you place >> %d <<%s." + msgCurrent pos msgUnless + if write then save config h' else return () + return (msg, slideshow pos h' height) diff --git a/src/Item.hs b/src/Item.hs new file mode 100644 --- /dev/null +++ b/src/Item.hs @@ -0,0 +1,191 @@ +module Item where + +import Data.Binary +import Data.Set as S +import Data.List as L +import qualified Data.IntMap as IM +import Data.Maybe +import Data.Char +import Data.Function +import Control.Monad + +import Random +import ItemKind +import qualified Color + +data Item = Item + { ikind :: !Int, + ipower :: !Int, -- https://github.com/Mikolaj/Allure/issues#issue/11 + iletter :: Maybe Char, -- ^ inventory identifier + icount :: !Int } + deriving Show + +instance Binary Item where + put (Item ikind ipower iletter icount ) = + put ikind >> put ipower >> put iletter >> put icount + get = liftM4 Item get get get get + +type Assocs = IM.IntMap Flavour + +type Discoveries = S.Set Int + +-- | Assinges flavours to item kinds. Assures no flavor is repeated, +-- except for items with only one permitted flavour. +rollAssocs :: Int -> ItemKind -> + Rnd (IM.IntMap Flavour, S.Set Flavour) -> + Rnd (IM.IntMap Flavour, S.Set Flavour) +rollAssocs key kind rnd = + if L.length (jflavour kind) == 1 + then rnd + else do + (assocs, available) <- rnd + let proper = S.fromList (jflavour kind) `S.intersection` available + flavour <- oneOf (S.toList proper) + return (IM.insert key flavour assocs, S.delete flavour available) + +-- | Randomly chooses flavour for all item kinds for this game. +dungeonAssocs :: Rnd Assocs +dungeonAssocs = + liftM fst $ + IM.foldWithKey rollAssocs (return (IM.empty, S.fromList stdFlav)) dungeonLoot + +getFlavour :: Assocs -> Int -> Flavour +getFlavour assocs ik = + let kind = ItemKind.getIK ik + in case jflavour kind of + [] -> error "getFlavour" + [f] -> f + _:_ -> assocs IM.! ik + +viewItem :: Int -> Assocs -> (Char, Color.Color) +viewItem ik assocs = (jsymbol (getIK ik), flavourToColor $ getFlavour assocs ik) + +itemLetter :: ItemKind -> Maybe Char +itemLetter ik = if jsymbol ik == '$' then Just '$' else Nothing + +-- | Generate an item. +newItem :: Int -> Rnd Item +newItem lvl = do + let dLoot = IM.assocs dungeonLoot + fik = Frequency $ L.zip (L.map (jfreq . snd) dLoot) (L.map fst dLoot) + ikChosen <- frequency fik + let kind = getIK ikChosen + count <- rollQuad lvl (jcount kind) + if count == 0 + then newItem lvl -- Rare item; beware of inifite loops. + else do + power <- rollQuad lvl (jpower kind) + return $ Item ikChosen power (itemLetter kind) count + +-- | Assigns a letter to an item, for inclusion +-- in the inventory of a hero. Takes a remembered +-- letter and a starting letter. +assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char +assignLetter r c is = + case r of + Just l | l `L.elem` allowed -> Just l + _ -> listToMaybe free + where + current = S.fromList (concatMap (maybeToList . iletter) is) + allLetters = ['a'..'z'] ++ ['A'..'Z'] + candidates = take (length allLetters) $ + drop (fromJust (L.findIndex (==c) allLetters)) $ + cycle allLetters + free = L.filter (\x -> not (x `S.member` current)) candidates + allowed = '$' : free + +cmpLetter :: Char -> Char -> Ordering +cmpLetter x y = compare (isUpper x, toLower x) (isUpper y, toLower y) + +cmpLetter' :: Maybe Char -> Maybe Char -> Ordering +cmpLetter' Nothing Nothing = EQ +cmpLetter' Nothing (Just _) = GT +cmpLetter' (Just _) Nothing = LT +cmpLetter' (Just l) (Just l') = cmpLetter l l' + +maxBy :: (a -> a -> Ordering) -> a -> a -> a +maxBy cmp x y = case cmp x y of + LT -> y + _ -> x + +maxLetter = maxBy cmpLetter + +mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char +mergeLetter = mplus + +letterRange :: [Char] -> String +letterRange xs = sectionBy (sortBy cmpLetter xs) Nothing + where + succLetter c d = ord d - ord c == 1 + + sectionBy [] Nothing = "" + sectionBy [] (Just (c,d)) = finish (c,d) + sectionBy (x:xs) Nothing = sectionBy xs (Just (x,x)) + sectionBy (x:xs) (Just (c,d)) + | succLetter d x = sectionBy xs (Just (c,x)) + | otherwise = finish (c,d) ++ sectionBy xs (Just (x,x)) + + finish (c,d) | c == d = [c] + | succLetter c d = [c,d] + | otherwise = [c,'-',d] + +letterLabel :: Maybe Char -> String +letterLabel Nothing = " " +letterLabel (Just c) = c : " - " + +-- | Adds an item to a list of items, joining equal items. +-- Also returns the joined item. +-- TODO: the resulting list can contain items with the same letter. +-- TODO: name [Item] Inventory and have some invariants, e.g. no equal letters. +joinItem :: Item -> [Item] -> (Item, [Item]) +joinItem i is = + case findItem (equalItemIdentity i) is of + Nothing -> (i, i : is) + Just (j,js) -> let n = i { icount = icount i + icount j, + iletter = mergeLetter (iletter j) (iletter i) } + in (n, n : js) + +-- | Removes an item from a list of items. +-- Takes an equality function (i.e., by letter or ny kind) as an argument. +removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item] +removeItemBy eq i = concatMap $ \ x -> + if eq i x + then let remaining = icount x - icount i + in if remaining > 0 + then [x { icount = remaining }] + else [] + else [x] + +equalItemIdentity :: Item -> Item -> Bool +equalItemIdentity i1 i2 = ipower i1 == ipower i2 && ikind i1 == ikind i2 + +removeItemByIdentity = removeItemBy equalItemIdentity + +equalItemLetter :: Item -> Item -> Bool +equalItemLetter = (==) `on` iletter + +removeItemByLetter = removeItemBy equalItemLetter + +-- | Finds an item in a list of items. +findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item]) +findItem p is = findItem' [] is + where + findItem' acc [] = Nothing + findItem' acc (i:is) + | p i = Just (i, reverse acc ++ is) + | otherwise = findItem' (i:acc) is + +strongestItem :: [Item] -> String -> Maybe Item +strongestItem is groupName = + let cmp = compare `on` ipower + igs = L.filter (\ i -> jname (getIK (ikind i)) == groupName) is + in case igs of + [] -> Nothing + _ -> Just $ L.maximumBy cmp igs + +itemPrice :: Item -> Int +itemPrice i = + case jname (getIK (ikind i)) of + "gold piece" -> icount i + "gem" -> 100 + _ -> 0 diff --git a/src/ItemAction.hs b/src/ItemAction.hs new file mode 100644 --- /dev/null +++ b/src/ItemAction.hs @@ -0,0 +1,319 @@ +module ItemAction where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.Function +import Data.List as L +import Data.Map as M +import qualified Data.IntMap as IM +import Data.Maybe +import Data.Set as S +import System.Time + +import Action +import Display hiding (display) +import Dungeon +import Geometry +import Grammar +import qualified HighScores as H +import Item +import qualified ItemKind +import qualified Keys as K +import Level +import LevelState +import Message +import Movable +import MovableState +import MovableKind +import MovableAdd +import Perception +import Random +import State +import qualified Config +import qualified Save +import qualified Effect +import EffectAction +import qualified Tile + +-- Item UI code with the Action type and everything it depends on +-- that is not already in Action.hs and EffectAction.hs. +-- This file should not depend on Action.hs. + +-- | Display inventory +inventory :: Action a +inventory = do + items <- gets (mitems . getPlayerBody) + if L.null items + then abortWith "Not carrying anything." + else do + displayItems "Carrying:" True items + session getConfirm + abortWith "" + +-- | Let the player choose any item with a given group name. +-- Note that this does not guarantee an item from the group to be chosen, +-- as the player can override the choice. +getGroupItem :: [Item] -> -- all objects in question + String -> -- name of the group + String -> -- prompt + String -> -- how to refer to the collection of objects + Action (Maybe Item) +getGroupItem is groupName prompt packName = + let choice i = groupName == ItemKind.jname (ItemKind.getIK (ikind i)) + header = capitalize $ suffixS groupName + in getItem prompt choice header is packName + +applyGroupItem :: Actor -> -- actor applying the item; on current level + String -> -- how the "applying" is called + Item -> -- the item to be applied + Action () +applyGroupItem actor verb item = do + state <- get + body <- gets (getActor actor) + per <- currentPerception + -- only one item consumed, even if several in inventory + let consumed = item { icount = 1 } + msg = subjectVerbIObject state body verb consumed "" + loc = mloc body + removeFromInventory actor consumed loc + when (loc `S.member` ptvisible per) $ messageAdd msg + itemEffectAction actor actor consumed + advanceTime actor + +playerApplyGroupItem :: String -> Action () +playerApplyGroupItem groupName = do + is <- gets (mitems . getPlayerBody) + iOpt <- getGroupItem is groupName + ("What to " ++ applyToVerb groupName ++ "?") "in inventory" + pl <- gets splayer + case iOpt of + Just i -> + let verb = applyToVerb (ItemKind.jname (ItemKind.getIK (ikind i))) + in applyGroupItem pl verb i + Nothing -> neverMind True + +applyToVerb :: String -> String +applyToVerb "potion" = "quaff" +applyToVerb "scroll" = "read" +applyToVerb _ = "destructively apply" + +quaffPotion :: Action () +quaffPotion = playerApplyGroupItem "potion" + +readScroll :: Action () +readScroll = playerApplyGroupItem "scroll" + +zapGroupItem :: Actor -> -- actor zapping the item; on current level + Loc -> -- target location for the zapping + String -> -- how the "zapping" is called + Item -> -- the item to be zapped + Action () +zapGroupItem source loc verb item = do + state <- get + sm <- gets (getActor source) + per <- currentPerception + let consumed = item { icount = 1 } + msg = subjectVerbIObject state sm verb consumed "" + sloc = mloc sm + removeFromInventory source consumed sloc + -- The message describes the source part of the action. + when (sloc `S.member` ptvisible per) $ messageAdd msg + case locToActor loc state of + Just ta -> do + -- Messages inside itemEffectAction describe the target part. + b <- itemEffectAction source ta consumed + when (not b) $ + modify (updateLevel (dropItemsAt [consumed] loc)) + Nothing -> + modify (updateLevel (dropItemsAt [consumed] loc)) + advanceTime source + +playerZapGroupItem :: String -> Action () +playerZapGroupItem groupName = do + state <- get + is <- gets (mitems . getPlayerBody) + iOpt <- getGroupItem is groupName + ("What to " ++ zapToVerb groupName ++ "?") "in inventory" + pl <- gets splayer + per <- currentPerception + case iOpt of + Just i -> + case targetToLoc (ptvisible per) state of + Nothing -> abortWith "target invalid" + Just loc -> + -- TODO: draw digital line and see if obstacles prevent firing + if actorReachesLoc pl loc per (Just pl) + then let verb = zapToVerb (ItemKind.jname (ItemKind.getIK (ikind i))) + in zapGroupItem pl loc verb i + else abortWith "target not reachable" + Nothing -> neverMind True + +zapToVerb :: String -> String +zapToVerb "wand" = "aim" +zapToVerb "dart" = "throw" +zapToVerb _ = "furiously zap" + +aimItem :: Action () +aimItem = playerZapGroupItem "wand" + +throwItem :: Action () +throwItem = playerZapGroupItem "dart" + +-- | Drop a single item. +-- TODO: allow dropping a given number of identical items. +dropItem :: Action () +dropItem = do + pl <- gets splayer + state <- get + pbody <- gets getPlayerBody + ploc <- gets (mloc . getPlayerBody) + items <- gets (mitems . getPlayerBody) + iOpt <- getAnyItem "What to drop?" items "inventory" + case iOpt of + Just stack -> do + let i = stack { icount = 1 } + removeOnlyFromInventory pl i (mloc pbody) + messageAdd (subjectVerbIObject state pbody "drop" i "") + modify (updateLevel (dropItemsAt [i] ploc)) + Nothing -> neverMind True + playerAdvanceTime + +-- TODO: this is a hack for dropItem, because removeFromInventory +-- makes it impossible to drop items if the floor not empty. +removeOnlyFromInventory :: Actor -> Item -> Loc -> Action () +removeOnlyFromInventory actor i loc = do + updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems m) }) + +-- | Remove given item from an actor's inventory or floor. +-- TODO: this is subtly wrong: if identical items are on the floor and in +-- inventory, the floor one will be chosen, regardless of player intention. +-- TODO: right now it ugly hacks (with the ploc) around removing items +-- of dead heros/monsters. The subtle incorrectness helps here a lot, +-- because items of dead heroes land on the floor, so we use them up +-- in inventory, but remove them after use from the floor. +removeFromInventory :: Actor -> Item -> Loc -> Action () +removeFromInventory actor i loc = do + b <- removeFromLoc i loc + when (not b) $ + updateAnyActor actor (\ m -> m { mitems = removeItemByLetter i (mitems m) }) + +-- | Remove given item from the given location. Tell if successful. +removeFromLoc :: Item -> Loc -> Action Bool +removeFromLoc i loc = do + lmap <- gets (lmap . slevel) + if not $ L.any (equalItemIdentity i) (Tile.titems (lmap `at` loc)) + then return False + else + modify (updateLevel (updateLMap adj)) >> + return True + where + adj = M.adjust (\ (t, rt) -> (remove t, rt)) loc + remove t = t { Tile.titems = removeItemByIdentity i (Tile.titems t) } + +actorPickupItem :: Actor -> Action () +actorPickupItem actor = do + state <- get + pl <- gets splayer + per <- currentPerception + lmap <- gets (lmap . slevel) + body <- gets (getActor actor) + let loc = mloc body + t = lmap `at` loc -- the map tile in question + perceived = loc `S.member` ptvisible per + isPlayer = actor == pl + -- check if something is here to pick up + case Tile.titems t of + [] -> abortIfWith isPlayer "nothing here" + i:rs -> -- pick up first item; TODO: let player select item;not for monsters + case assignLetter (iletter i) (mletter body) (mitems body) of + Just l -> do + let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems body) + -- message depends on who picks up and if a hero can perceive it + if isPlayer + then messageAdd (letterLabel (iletter ni) ++ objectItem state ni) + else when perceived $ + messageAdd $ subjCompoundVerbIObj state body "pick" "up" i "" + assertTrue $ removeFromLoc i loc + -- add item to actor's inventory: + updateAnyActor actor $ \ m -> + m { mitems = nitems, mletter = maxLetter l (mletter body) } + Nothing -> abortIfWith isPlayer "cannot carry any more" + advanceTime actor + +pickupItem :: Action () +pickupItem = do + pl <- gets splayer + actorPickupItem pl + +-- TODO: I think that player handlers should be wrappers +-- around more general actor handlers, but +-- the actor handlers should be performing +-- specific actions, i.e., already specify the item to be +-- picked up. It doesn't make sense to invoke dialogues +-- for arbitrary actors, and most likely the +-- decision for a monster is based on perceiving +-- a particular item to be present, so it's already +-- known. In actor handlers we should make sure +-- that messages are printed to the player only if the +-- hero can perceive the action. +-- Perhaps this means half of this code should be split and moved +-- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed. + +-- | Let the player choose any item from a list of items. +-- TODO: you can drop an item on the floor, which works correctly, +-- but is weird and useless. +getAnyItem :: String -> -- prompt + [Item] -> -- all objects in question + String -> -- how to refer to the collection of objects + Action (Maybe Item) +getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn + +-- | Let the player choose a single item from a list of items. +getItem :: String -> -- prompt message + (Item -> Bool) -> -- which items to consider suitable + String -> -- how to describe suitable objects + [Item] -> -- all objects in question + String -> -- how to refer to the collection of objects + Action (Maybe Item) +getItem prompt p ptext is0 isn = do + lmap <- gets (lmap . slevel) + body <- gets getPlayerBody + let loc = mloc body + t = lmap `at` loc -- the map tile in question + tis = Tile.titems t + floorMsg = if L.null tis then "" else " -," + is = L.filter p is0 + choice = if L.null is + then "[*," ++ floorMsg ++ " ESC]" + else let r = letterRange (concatMap (maybeToList . iletter) is) + in "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]" + interact = do + when (L.null is0 && L.null tis) $ + abortWith "Not carrying anything." + messageWipeAndSet (prompt ++ " " ++ choice) + display + session nextCommand >>= perform + perform command = do + resetMessage + case command of + K.Char '?' -> do + -- filter for supposedly suitable objects + b <- displayItems (ptext ++ " " ++ isn) True is + if b then session (getOptionalConfirm (const interact) perform) + else interact + K.Char '*' -> do + -- show all objects + b <- displayItems ("Objects " ++ isn) True is0 + if b then session (getOptionalConfirm (const interact) perform) + else interact + K.Char '-' -> + case tis of + [] -> return Nothing + i:rs -> -- use first item; TODO: let player select item + return $ Just i + K.Char l -> + return (find (\ i -> maybe False (== l) (iletter i)) is0) + K.Return -> -- TODO: i should be the first displayed (except $) + return (case is of [] -> Nothing ; i : _ -> Just i) + _ -> return Nothing + interact diff --git a/src/ItemKind.hs b/src/ItemKind.hs new file mode 100644 --- /dev/null +++ b/src/ItemKind.hs @@ -0,0 +1,169 @@ +module ItemKind where + +import qualified Data.List as L +import qualified Data.IntMap as IM + +import Color +import Effect +import Random + +data ItemKind = ItemKind + { jsymbol :: !Char -- ^ map symbol + , jflavour :: [Flavour] -- ^ possible flavours + , jname :: String -- ^ group name + , jeffect :: Effect -- ^ the effect when activated + , jcount :: RollQuad -- ^ created in that quantify + , jfreq :: !Int -- ^ created that often + , jpower :: RollQuad -- ^ created with that power + } + deriving (Show, Eq, Ord) + +type Flavour = (Color, Bool) -- the flag says to use fancy color names + +zipPlain cs = L.zip cs (repeat False) +zipFancy cs = L.zip cs (repeat True) +darkCol = [Red .. Cyan] +brightCol = [BrRed .. BrCyan] -- BrBlack excluded (not really that bright) +stdCol = darkCol ++ brightCol +stdFlav = zipPlain stdCol ++ zipFancy stdCol + +flavourToName :: Flavour -> String +flavourToName (c, False) = colorToName c +flavourToName (c, True) = colorToName' c + +flavourToColor :: Flavour -> Color +flavourToColor (c, _) = c + +dungeonLoot :: IM.IntMap ItemKind +dungeonLoot = IM.fromDistinctAscList (L.zip [0..] loot) + +getIK ik = dungeonLoot IM.! ik + +loot :: [ItemKind] +loot = + [amulet, + dart, + gem1, gem2, gem3, gem4, + gold, + potion1, potion2, potion3, + ring, + scroll1, scroll2, + sword, + wand] + +-- rollQuad (a, b, x, y) = a * d b + (lvl * x * d y) / 10 + +amulet, dart, gem, gem1, gem2, gem3, gem4, gold :: ItemKind +potion, potion1, potion2, potion3 :: ItemKind +ring, scroll, scroll1, scroll2, sword, wand :: ItemKind +amulet = ItemKind + { jsymbol = '"' + , jflavour = [(BrGreen, True)] + , jname = "amulet" + , jeffect = Regneration + , jcount = intToQuad 1 + , jfreq = 10 + , jpower = (2, 1, 2, 2) + } +dart = ItemKind + { jsymbol = ')' + , jflavour = [(Yellow, False)] + , jname = "dart" + , jeffect = Wound (1, 1) + , jcount = (3, 3, 0, 0) + , jfreq = 30 + , jpower = intToQuad 0 + } +gem = ItemKind + { jsymbol = '*' + , jflavour = zipPlain brightCol -- natural, so not fancy + , jname = "gem" + , jeffect = NoEffect + , jcount = intToQuad 0 + , jfreq = 20 -- x4, but rare on shallow levels + , jpower = intToQuad 0 + } +gem1 = gem + { jcount = (1, 1, 0, 0) -- appears on lvl 1 + } +gem2 = gem + { jcount = (0, 0, 2, 1) -- appears on lvl 5, doubled on lvl 10 + } +gem3 = gem + { jcount = (0, 0, 1, 1) -- appears on lvl 10 + } +gem4 = gem + { jcount = (0, 0, 1, 1) -- appears on lvl 10 + } +gold = ItemKind + { jsymbol = '$' + , jflavour = [(BrYellow, False)] + , jname = "gold piece" + , jeffect = NoEffect + , jcount = (0, 0, 10, 10) + , jfreq = 80 + , jpower = intToQuad 0 + } +potion = ItemKind + { jsymbol = '!' + , jflavour = zipFancy stdCol + , jname = "potion" + , jeffect = NoEffect + , jcount = intToQuad 1 + , jfreq = 10 + , jpower = intToQuad 0 + } +potion1 = potion + { jeffect = ApplyPerfume + } +potion2 = potion + { jeffect = Heal + , jpower = (10, 1, 0, 0) + } +potion3 = potion + { jeffect = Wound (0, 0) + , jpower = (10, 1, 0, 0) + } +ring = ItemKind + { jsymbol = '=' + , jflavour = [(White, False)] + , jname = "ring" + , jeffect = Searching + , jcount = intToQuad 1 + , jfreq = 10 + , jpower = (1, 1, 2, 2) + } +scroll = ItemKind + { jsymbol = '?' + , jflavour = zipFancy darkCol -- arcane and old + , jname = "scroll" + , jeffect = NoEffect + , jcount = intToQuad 1 + , jfreq = 10 + , jpower = intToQuad 0 + } +scroll1 = scroll + { jeffect = SummonFriend + , jfreq = 20 + } +scroll2 = scroll + { jeffect = SummonEnemy + } +sword = ItemKind + { jsymbol = ')' + , jflavour = [(BrCyan, False)] + , jname = "sword" + , jeffect = Wound (3, 1) + , jcount = intToQuad 1 + , jfreq = 60 + , jpower = (1, 2, 4, 2) + } +wand = ItemKind + { jsymbol = '/' + , jflavour = [(BrRed, True)] + , jname = "wand" + , jeffect = Dominate + , jcount = intToQuad 1 + , jfreq = 10 + , jpower = intToQuad 0 + } diff --git a/src/Keybindings.hs b/src/Keybindings.hs new file mode 100644 --- /dev/null +++ b/src/Keybindings.hs @@ -0,0 +1,41 @@ +module Keybindings where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.Map as M +import Data.List as L + +import Action +import Command +import qualified Keys as K + +-- | Keybindings. +data Keybindings = Keybindings + { kdir :: DirCommand, + kudir :: DirCommand, + kother :: M.Map K.Key Command + } + +handleKey :: Keybindings -> K.Key -> Action () +handleKey kb k = + do + K.handleDirection k (caction $ kdir kb) $ + K.handleUDirection k (caction $ kudir kb) $ + case M.lookup k (kother kb) of + Just c -> caction c + Nothing -> abortWith $ "unknown command (" ++ K.showKey k ++ ")" + +keyHelp :: (K.Key -> [K.Key]) -> Keybindings -> String +keyHelp aliases kb = + let + fmt k h = replicate 15 ' ' ++ k ++ replicate ((13 - length k) `max` 1) ' ' + ++ h ++ replicate ((35 - length h) `max` 1) ' ' + fmts s = replicate 15 ' ' ++ s ++ replicate ((48 - length s) `max` 1) ' ' + blank = fmt "" "" + title = fmt "keys" "command" + footer = fmts "(See file PLAYING.markdown.)" + disp k = L.concatMap show $ aliases k + rest = [ fmt (disp k) h + | (k, Described h _) <- M.toAscList (kother kb) ] + in + unlines ([blank, title] ++ rest ++ [blank, footer, blank]) diff --git a/src/Keys.hs b/src/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Keys.hs @@ -0,0 +1,156 @@ +module Keys where + +import Prelude hiding (Left, Right) + +import Geometry hiding (Up, Down) +import Data.Maybe +import Data.List as L +import Data.Map as M + +-- | Library-independent datatype to represent keys. +data Key = + Esc + | Return + | Tab + | PgUp + | PgDn + | Left + | Right + | Up + | Down + | End + | Begin + | Home + | KP Char -- ^ a keypad key for a character (digits and operators) + | Char Char -- ^ a single printable character + | Unknown String -- ^ an unknown key, collected to warn the user later + deriving (Ord, Eq) + +showKey :: Key -> String +showKey (Char ' ') = "" -- 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 = "" +showKey PgDn = "" +showKey Left = "" +showKey Right = "" +showKey Up = "" +showKey Down = "" +showKey End = "" +showKey Begin = "" +showKey Home = "" +showKey (KP 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 diff --git a/src/Level.hs b/src/Level.hs new file mode 100644 --- /dev/null +++ b/src/Level.hs @@ -0,0 +1,128 @@ +module Level where + +import Control.Monad + +import Data.Binary +import Data.Map as M +import Data.List as L +import qualified Data.IntMap as IM + +import Geometry +import GeometryRnd +import Movable +import Item +import Random +import qualified Terrain +import WorldLoc +import Data.Maybe +import qualified Tile + +type Party = IM.IntMap Movable + +data Level = Level + { lname :: LevelId, -- TODO: remove + lheroes :: Party, -- ^ all heroes on the level + lsize :: (Y,X), + lmonsters :: Party, -- ^ all monsters on the level + lsmell :: SMap, + lmap :: LMap, + lmeta :: String } + deriving Show + +updateLMap :: (LMap -> LMap) -> Level -> Level +updateLMap f lvl = lvl { lmap = f (lmap lvl) } + +updateSMap :: (SMap -> SMap) -> Level -> Level +updateSMap f lvl = lvl { lsmell = f (lsmell lvl) } + +updateMonsters :: (Party -> Party) -> Level -> Level +updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) } + +updateHeroes :: (Party -> Party) -> Level -> Level +updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) } + +emptyParty :: Party +emptyParty = IM.empty + +instance Binary Level where + put (Level nm hs sz@(sy,sx) ms lsmell lmap lmeta) = + do + put nm + put hs + put sz + put ms + put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ] + put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ] + put lmeta + get = do + nm <- get + hs <- get + sz@(sy,sx) <- get + ms <- get + xs <- get + let lsmell = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs) + xs <- get + let lmap = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs) + lmeta <- get + return (Level nm hs sz ms lsmell lmap lmeta) + +type LMap = Map (Y,X) (Tile.Tile, Tile.Tile) +type SMap = Map (Y,X) Time + +at l p = fst (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l) +rememberAt l p = snd (findWithDefault (Tile.unknownTile, Tile.unknownTile) p l) + +-- Checks for the presence of movables. Does *not* check if the tile is open. +unoccupied :: [Movable] -> Loc -> Bool +unoccupied movables loc = + all (\ m -> mloc m /= loc) movables + +-- Check whether one location is accessible from the other. +-- Precondition: the two locations are next to each other. +-- Currently only implements that the target location has to be open. +-- TODO: in the future check flying for chasms, swimming for water, etc. +accessible :: LMap -> Loc -> Loc -> Bool +accessible lmap source target = + let tgt = lmap `at` target + in Tile.open tgt + +-- check whether the location contains a door of secrecy level lower than k +openable :: Int -> LMap -> Loc -> Bool +openable k lmap target = + let tgt = lmap `at` target + in case Terrain.deDoor $ Tile.tterrain tgt of + Just (Just n) -> n < k + _ -> False + +findLoc :: Level -> (Loc -> Tile.Tile -> Bool) -> Rnd Loc +findLoc l@(Level { lsize = sz, lmap = lm }) p = + do + loc <- locInArea ((0,0),sz) + let tile = lm `at` loc + if p loc tile + then return loc + else findLoc l p + +findLocTry :: Int -> -- try k times + Level -> + (Loc -> Tile.Tile -> Bool) -> -- loop until satisfied + (Loc -> Tile.Tile -> Bool) -> -- only try to satisfy k times + Rnd Loc +findLocTry k l@(Level { lsize = sz, lmap = lm }) p pTry = + do + loc <- locInArea ((0,0),sz) + let tile = lm `at` loc + if p loc tile && pTry loc tile + then return loc + else if k > 1 + then findLocTry (k - 1) l p pTry + else findLoc l p + +-- Actually, do not scatter items around, it's too much work for the player. +dropItemsAt :: [Item] -> Loc -> Level -> Level +dropItemsAt items loc lvl@(Level { lmap = lmap }) = + let joinItems items = L.foldl' (\ acc i -> snd (joinItem i acc)) items + t = lmap `at` loc + nt = t { Tile.titems = joinItems items (Tile.titems t) } + ntRemember = lmap `rememberAt` loc + in updateLMap (M.insert loc (nt, ntRemember)) lvl diff --git a/src/LevelState.hs b/src/LevelState.hs new file mode 100644 --- /dev/null +++ b/src/LevelState.hs @@ -0,0 +1,35 @@ +module LevelState where + +import qualified Color +import Geometry +import Level +import State +import Item +import Grammar +import qualified Terrain +import qualified Tile + +viewTile :: Bool -> Tile.Tile -> Assocs -> (Char, Color.Color) +viewTile b (Tile.Tile t []) a = Terrain.viewTerrain b t +viewTile b (Tile.Tile t (i:_)) a = Item.viewItem (ikind i) a + +-- | Produces a textual description of the terrain and items at an already +-- explored location. Mute for unknown locations. +-- The "detailed" variant is for use in the targeting mode. +lookAt :: Bool -> Bool -> State -> LMap -> Loc -> String -> String +lookAt detailed canSee s lmap loc msg + | detailed = + Terrain.lookTerrain (Tile.tterrain (lmap `rememberAt` loc)) ++ " " ++ msg ++ isd + | otherwise = msg ++ isd + where + is = Tile.titems (lmap `rememberAt` loc) + prefixSee = if canSee then "You see " else "You remember " + prefixThere = if canSee + then "There are several objects here" + else "You remember several objects here" + isd = case is of + [] -> "" + [i] -> prefixSee ++ objectItem s i ++ "." + [i,j] -> prefixSee ++ objectItem s i ++ " and " + ++ objectItem s j ++ "." + _ -> prefixThere ++ if detailed then ":" else "." diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,45 @@ +module Main where + +import System.Directory +import Data.Map as M + +import Action +import State +import DungeonState +import qualified Display +import Random +import qualified Save +import Turn +import qualified Config +import MovableAdd +import Item +import qualified Keys as K + +main :: IO () +main = Display.startup start + +-- | Either restore a saved game, or setup a new game. +start :: Display.InternalSession -> IO () +start internalSession = do + config <- Config.config + let section = Config.getItems config "macros" + !macros = K.macroKey section + session = (internalSession, macros) + -- check if we have a savegame + f <- Save.file config + b <- doesFileExist f + restored <- if b + then do + Display.displayBlankConfirm session "Restoring save game" + Save.restoreGame config + else return $ Right "Welcome to Allure of the Stars!" -- new game + case restored of + Right msg -> do + (ploc, lvl, dng) <- rndToIO $ generate config + assocs <- rndToIO $ dungeonAssocs + let defState = defaultState dng lvl + state = defState { sconfig = config, sassocs = assocs } + hstate = initialHeroes ploc state + handlerToIO session hstate msg handle + Left state -> + handlerToIO session state "Welcome back to Allure of the Stars." handle diff --git a/src/Message.hs b/src/Message.hs new file mode 100644 --- /dev/null +++ b/src/Message.hs @@ -0,0 +1,32 @@ +module Message where + +import Data.List as L +import Data.Char + +type Message = String + +more :: Message +more = " --more-- " + +yesno :: Message +yesno = " [yn]" + +addMsg :: Message -> Message -> Message +addMsg [] x = x +addMsg xs [] = xs +addMsg xs x = xs ++ " " ++ x + +splitMsg :: Int -> Message -> [String] +splitMsg w xs + | w <= m = [xs] -- border case, we cannot make progress + | l <= w = [xs] -- no problem, everything fits + | otherwise = + let (pre, post) = splitAt (w - m) xs + (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre + rpost = dropWhile isSpace ppost + in if L.null rpost + then pre : splitMsg w post + else reverse rpost : splitMsg w (reverse ppre ++ post) + where + m = length more + l = length xs diff --git a/src/Movable.hs b/src/Movable.hs new file mode 100644 --- /dev/null +++ b/src/Movable.hs @@ -0,0 +1,83 @@ +module Movable where + +import Data.Binary +import Control.Monad + +import Geometry +import Item +import MovableKind + +-- | Monster properties that are changing a lot. If they are dublets +-- of properties form MovableKind, the intention is they may be modified +-- temporarily, but will return to the original value over time. E.g., HP. +data Movable = Movable + { mkind :: !MovableKind, -- ^ kind of the movable; TODO: make this Int + mhp :: !Int, -- ^ current hit pints + mdir :: Maybe Dir, -- ^ the direction of running + mtarget :: Target, -- ^ the target for distance attacks and AI + mloc :: !Loc, -- ^ current location + mitems :: [Item], -- ^ inventory + mletter :: !Char, -- ^ next inventory letter + mtime :: !Time } -- ^ time of next action + deriving Show + +instance Binary Movable where + put (Movable mk mhp md tgt ml minv mletter mtime) = + do + put mk + put mhp + put md + put tgt + put ml + put minv + put mletter + put mtime + get = do + mk <- get + mhp <- get + md <- get + tgt <- get + ml <- get + minv <- get + mletter <- get + mtime <- get + return (Movable mk mhp md tgt ml minv mletter mtime) + +data Actor = AHero Int -- ^ hero index (on the lheroes intmap) + | AMonster Int -- ^ monster index (on the lmonsters intmap) + deriving (Show, Eq, Ord) + +isAHero :: Actor -> Bool +isAHero (AHero _) = True +isAHero (AMonster _) = False + +isAMonster :: Actor -> Bool +isAMonster = not . isAHero + +instance Binary Actor where + put (AHero n) = putWord8 0 >> put n + put (AMonster n) = putWord8 1 >> put n + get = do + tag <- getWord8 + case tag of + 0 -> liftM AHero get + 1 -> liftM AMonster get + _ -> fail "no parse (Actor)" + +data Target = + TEnemy Actor Loc -- ^ fire at the actor; last seen location + | TLoc Loc -- ^ fire at a given location + | TCursor -- ^ fire at the current position of the cursor; default + deriving (Show, Eq) + +instance Binary Target where + put (TEnemy a ll) = putWord8 0 >> put a >> put ll + put (TLoc loc) = putWord8 1 >> put loc + put TCursor = putWord8 2 + get = do + tag <- getWord8 + case tag of + 0 -> liftM2 TEnemy get get + 1 -> liftM TLoc get + 2 -> return TCursor + _ -> fail "no parse (Target)" diff --git a/src/MovableAdd.hs b/src/MovableAdd.hs new file mode 100644 --- /dev/null +++ b/src/MovableAdd.hs @@ -0,0 +1,109 @@ +module MovableAdd where + +import Prelude hiding (floor) +import qualified Data.IntMap as IM +import Data.List as L +import Data.Map as M +import Data.Ratio +import Data.Maybe +import qualified Data.Char as Char + +import Geometry +import State +import Level +import Dungeon +import Movable +import MovableState +import MovableKind +import Random +import qualified Config +import WorldLoc +import qualified Tile + +-- Generic functions + +-- setting the time of new monsters to 0 makes them able to +-- move immediately after generation; this does not seem like +-- a bad idea, but it would certainly be "more correct" to set +-- the time to the creation time instead +template :: MovableKind -> Int -> Loc -> Movable +template mk hp loc = Movable mk hp Nothing TCursor loc [] 'a' 0 + +nearbyFreeLoc :: Loc -> State -> Loc +nearbyFreeLoc origin state@(State { slevel = Level { lmap = map } }) = + let hs = levelHeroList state + ms = levelMonsterList state + places = origin : L.nub (concatMap surroundings places) + good loc = Tile.open (map `at` loc) && not (loc `L.elem` L.map mloc (hs ++ ms)) + in fromMaybe (error "no nearby free location found") $ L.find good places + +-- Adding heroes + +findHeroName :: Config.CP -> Int -> String +findHeroName config n = + let heroName = Config.getOption config "heroes" ("HeroName_" ++ show n) + in fromMaybe ("hero number " ++ show n) heroName + +-- | Create a new hero on the current level, close to the given location. +addHero :: Loc -> State -> State +addHero ploc state = + let config = sconfig state + bHP = Config.get config "heroes" "baseHP" + mk = hero {nhpMin = bHP, nhpMax = bHP, nsymbol = symbol, nname = name } + loc = nearbyFreeLoc ploc state + n = fst (scounter state) + symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n + name = findHeroName config n + startHP = bHP `div` (min 10 (n + 1)) + m = template mk startHP loc + state' = state { scounter = (n + 1, snd (scounter state)) } + in updateLevel (updateHeroes (IM.insert n m)) state' + +-- | Create a set of initial heroes on the current level, at location ploc. +initialHeroes :: Loc -> State -> State +initialHeroes ploc state = + let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes" + in iterate (addHero ploc) state !! k + +-- Adding monsters + +-- | Chance that a new monster is generated. Currently depends on the +-- number of monsters already present, and on the level. In the future, +-- the strength of the character and the strength of the monsters present +-- could further influence the chance, and the chance could also affect +-- which monster is generated. +monsterGenChance :: LevelId -> Int -> Rnd Bool +monsterGenChance (LambdaCave depth) numMonsters = + chance $ 1%(fromIntegral (250 + 200 * (numMonsters - depth)) `max` 50) + +-- | Create a new monster in the level, at a random position. +addMonster :: MovableKind -> Int -> Loc -> State -> State +addMonster mk hp ploc state = do + let loc = nearbyFreeLoc ploc state + n = snd (scounter state) + m = template mk hp loc + state' = state { scounter = (fst (scounter state), n + 1) } + updateLevel (updateMonsters (IM.insert n m)) state' + +-- | Create a new monster in the level, at a random position. +rollMonster :: State -> Rnd State +rollMonster state@(State { slevel = lvl }) = do + let hs = levelHeroList state + ms = levelMonsterList state + rc <- monsterGenChance (lname lvl) (L.length ms) + if not rc + then return state + else do + -- TODO: new monsters should always be generated in a place that isn't + -- visible by the player (if possible -- not possible for bigrooms) + -- levels with few rooms are dangerous, because monsters may spawn + -- in adjacent and unexpected places + loc <- findLocTry 1000 lvl + (\ l t -> Tile.open t + && not (l `L.elem` L.map mloc (hs ++ ms))) + (\ l t -> Tile.floor t + && L.all (\ pl -> distance (mloc pl, l) > 400) hs) + let fmk = Frequency $ L.zip (L.map nfreq dungeonMonsters) dungeonMonsters + mk <- frequency fmk + hp <- randomR (nhpMin mk, nhpMax mk) + return $ addMonster mk hp loc state diff --git a/src/MovableKind.hs b/src/MovableKind.hs new file mode 100644 --- /dev/null +++ b/src/MovableKind.hs @@ -0,0 +1,111 @@ +module MovableKind where + +import Data.Binary +import Control.Monad + +import Geometry +import Random +import qualified Color + +-- | Monster properties that are changing rarely and permanently. +data MovableKind = MovableKind + { nhpMin :: !Int -- ^ minimal initial hp + , nhpMax :: !Int -- ^ maximal possible and initial hp + , nspeed :: !Time -- ^ natural speed + , nsymbol :: !Char -- ^ map symbol + , ncolor :: !Color.Color -- ^ map color + , nname :: String -- ^ name + , nsight :: !Bool -- ^ can it see? + , nsmell :: !Bool -- ^ can it smell? + , niq :: !Int -- ^ intelligence + , nregen :: !Int -- ^ regeneration interval + , nfreq :: !Int -- ^ created that often + } + deriving (Show, Eq) + +instance Binary MovableKind where + put (MovableKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq) = + do + put nhpMin + put nhpMax + put nsp + put nsym + put ncol + put nnm + put nsi + put nsm + put niq + put nreg + put nfreq + get = do + nhpMin <- get + nhpMax <- get + nsp <- get + nsym <- get + ncol <- get + nnm <- get + nsi <- get + nsm <- get + niq <- get + nreg <- get + nfreq <- get + return (MovableKind nhpMin nhpMax nsp nsym ncol nnm nsi nsm niq nreg nfreq) + +-- | The list of kinds of monsters that appear randomly throughout the dungeon. +dungeonMonsters :: [MovableKind] +dungeonMonsters = [eye, fastEye, nose] + +hero, eye, fastEye, nose :: MovableKind +hero = MovableKind + { nhpMin = 50, + nhpMax = 50, + nspeed = 10, + nsymbol = '@', + nname = "you", + ncolor = Color.BrWhite, -- Heroes white, monsters colorful. + nsight = True, + nsmell = False, + niq = 13, -- Can see secret doors under alien control. + nregen = 1500, + nfreq = 0 + } + +eye = MovableKind + { nhpMin = 1, -- falls in 1--4 unarmed rounds + nhpMax = 12, + nspeed = 10, + nsymbol = 'e', + ncolor = Color.BrRed, + nname = "the reducible eye", + nsight = True, + nsmell = False, + niq = 8, + nregen = 1500, + nfreq = 6 + } +fastEye = MovableKind + { nhpMin = 1, -- falls in 1--2 unarmed rounds + nhpMax = 6, + nspeed = 4, + nsymbol = 'e', + ncolor = Color.BrBlue, + nname = "the super-fast eye", + nsight = True, + nsmell = False, + niq = 12, + nregen = 1500, + nfreq = 1 + } +nose = MovableKind + { nhpMin = 6, -- 2--5 and in 1 round of the strongest sword + nhpMax = 13, + nspeed = 11, + nsymbol = 'n', + ncolor = Color.Green, + nname = "the point-free nose", + nsight = False, + nsmell = True, + niq = 0, + nregen = 1500, + nfreq = 2 + } diff --git a/src/MovableState.hs b/src/MovableState.hs new file mode 100644 --- /dev/null +++ b/src/MovableState.hs @@ -0,0 +1,123 @@ +module MovableState where + +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.IntMap as IM +import Control.Monad +import Data.Maybe +import Control.Exception (assert) + +import Geometry +import Movable +import Level +import Dungeon +import State +import WorldLoc + +-- The operations with "Any", and those that use them, consider all the dungeon. +-- All the other actor and level operations only consider the current level. + +-- | Finds an actor body on any level. Error if not found. +findActorAnyLevel :: Actor -> State -> Maybe (LevelId, Movable) +findActorAnyLevel actor state@(State { slevel = lvl, + sdungeon = Dungeon m }) = + let chk lvl = + fmap (\ m -> (lname lvl, m)) $ + case actor of + AHero n -> IM.lookup n (lheroes lvl) + AMonster n -> IM.lookup n (lmonsters lvl) + in listToMaybe $ mapMaybe chk (lvl : M.elems m) + +getPlayerBody :: State -> Movable +getPlayerBody state = snd $ fromMaybe (error "getPlayerBody") $ + findActorAnyLevel (splayer state) state + +-- | The list of actors and levels for all heroes in the dungeon. +-- Heroes from the current level go first. +allHeroesAnyLevel :: State -> [(Actor, LevelId)] +allHeroesAnyLevel state = + let Dungeon m = sdungeon state + one (Level { lname = ln, lheroes = hs }) = + L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs hs) + in L.concatMap one (slevel state : M.elems m) + +updateAnyActorBody :: Actor -> (Movable -> Movable) -> State -> State +updateAnyActorBody actor f state = + case findActorAnyLevel actor state of + Just (ln, _) -> + case actor of + AHero n -> updateAnyLevel (updateHeroes $ IM.adjust f n) ln state + AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state + Nothing -> error "updateAnyActorBody" + +updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State +updateAnyLevel f ln state@(State { slevel = level, + sdungeon = Dungeon dng }) + | ln == lname level = updateLevel f state + | otherwise = updateDungeon (const $ Dungeon $ M.adjust f ln dng) state + +-- | Calculate the location of player's target. +targetToLoc :: S.Set Loc -> State -> Maybe Loc +targetToLoc visible state = + case mtarget (getPlayerBody state) of + TLoc loc -> Just loc + TCursor -> + if lname (slevel state) == clocLn (scursor state) + then Just $ clocation (scursor state) + else Nothing -- cursor invalid: set at a different level + TEnemy a _ll -> do + guard $ memActor a state -- alive and on the current level? + let loc = mloc (getActor a state) + guard $ S.member loc visible -- visible? + return loc + +-- The operations below disregard levels other than the current. + +-- | Checks if the actor is present on the current level. +memActor :: Actor -> State -> Bool +memActor a (State { slevel = lvl }) = + case a of + AHero n -> IM.member n (lheroes lvl) + AMonster n -> IM.member n (lmonsters lvl) + +-- | Gets actor body from the current level. Error if not found. +getActor :: Actor -> State -> Movable +getActor a (State { slevel = lvl }) = + case a of + AHero n -> lheroes lvl IM.! n + AMonster n -> lmonsters lvl IM.! n + +-- | Removes the actor, if present, from the current level. +deleteActor :: Actor -> State -> State +deleteActor a = + case a of + AHero n -> updateLevel (updateHeroes (IM.delete n)) + AMonster n -> updateLevel (updateMonsters (IM.delete n)) + +-- | Add actor to the current level. +insertActor :: Actor -> Movable -> State -> State +insertActor a m = + case a of + AHero n -> updateLevel (updateHeroes (IM.insert n m)) + AMonster n -> updateLevel (updateMonsters (IM.insert n m)) + +levelHeroList, levelMonsterList :: State -> [Movable] +levelHeroList (State { slevel = Level { lheroes = hs } }) = IM.elems hs +levelMonsterList (State { slevel = Level { lmonsters = ms } }) = IM.elems ms + +-- | Finds an actor at a location on the current level. Perception irrelevant. +locToActor :: Loc -> State -> Maybe Actor +locToActor loc state = + let l = locToActors loc state + in assert (L.length l <= 1) $ + listToMaybe l + +locToActors :: Loc -> State -> [Actor] +locToActors loc state = + getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero) + where + getIndex (projection, injection) = + let l = IM.assocs $ projection $ slevel state + im = L.filter (\ (_i, m) -> mloc m == loc) l + in fmap (injection . fst) im diff --git a/src/Multiline.hs b/src/Multiline.hs new file mode 100644 --- /dev/null +++ b/src/Multiline.hs @@ -0,0 +1,8 @@ +module Multiline (multiline) where + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TQ + +-- | Used to handle multiline verbatim string expressions, see ConfigDefault.hs. +multiline :: TQ.QuasiQuoter +multiline = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined diff --git a/src/Perception.hs b/src/Perception.hs new file mode 100644 --- /dev/null +++ b/src/Perception.hs @@ -0,0 +1,114 @@ +module Perception where + +import qualified Data.Set as S +import Data.List as L +import qualified Data.IntMap as IM +import Data.Maybe +import Control.Monad + +import Geometry +import State +import Level +import Movable +import MovableState +import qualified MovableKind +import FOV +import qualified Config +import qualified Tile + +data Perception = + Perception { preachable :: S.Set Loc, pvisible :: S.Set Loc } + +-- The pplayer field is void if player not on the current level, +-- or if the player controls a blind monster. Right now, the field is used only +-- for player-controlled monsters on the current level. +data Perceptions = + Perceptions { pplayer :: Maybe Perception, + pheroes :: IM.IntMap Perception, + ptotal :: Perception } + +ptreachable, ptvisible :: Perceptions -> S.Set Loc +ptreachable = preachable . ptotal +ptvisible = pvisible . ptotal + +actorPrLoc :: (Perception -> S.Set Loc) -> + Actor -> Loc -> Perceptions -> Maybe Actor -> Bool +actorPrLoc projection actor loc per pl = + let tryHero = case actor of + AMonster _ -> Nothing + AHero i -> do + hper <- IM.lookup i (pheroes per) + return $ loc `S.member` (projection hper) + tryPl = do -- the case for a monster under player control + guard $ Just actor == pl + pper <- pplayer per + return $ loc `S.member` projection pper + tryAny = tryHero `mplus` tryPl + in fromMaybe False tryAny -- assume not visible, if no perception found + +actorSeesLoc :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool +actorSeesLoc = actorPrLoc pvisible + +actorReachesLoc :: Actor -> Loc -> Perceptions -> Maybe Actor -> Bool +actorReachesLoc = actorPrLoc preachable + +-- Not quite correct if FOV not symmetric (Shadow). +actorReachesActor :: Actor -> Actor -> Loc -> Loc -> Perceptions -> Maybe Actor + -> Bool +actorReachesActor actor1 actor2 loc1 loc2 per pl = + actorReachesLoc actor1 loc2 per pl || + actorReachesLoc actor2 loc1 per pl + +perception_ :: State -> Perceptions +perception_ state@(State { splayer = pl, + slevel = Level { lmap = lmap, lheroes = hs }, + sconfig = config, + ssensory = sensory }) = + let mode = Config.get config "engine" "fovMode" + radius = Config.get config "engine" "fovRadius" + fovMode m = if not $ MovableKind.nsight (mkind m) then Blind else + -- terrible, temporary hack + case sensory of + Vision 3 -> Digital radius + Vision 2 -> Permissive radius + Vision 1 -> Shadow + _ -> + -- this is not a hack + case mode of + "permissive" -> Permissive radius + "digital" -> Digital radius + "shadow" -> Shadow + _ -> error $ "perception_: unknown mode: " ++ show mode + + -- Perception for a player-controlled monster on the current level. + pper = if isAMonster pl && memActor pl state + then let m = getPlayerBody state + in Just $ perception (fovMode m) (mloc m) lmap + else Nothing + pers = IM.map (\ h -> perception (fovMode h) (mloc h) lmap) hs + lpers = maybeToList pper ++ IM.elems pers + reachable = S.unions (L.map preachable lpers) + visible = S.unions (L.map pvisible lpers) + in Perceptions { pplayer = pper, + pheroes = pers, + ptotal = Perception reachable visible } + +-- | Once we compute the reachable fields using FOV, it is possible +-- to compute what the hero can actually see. +perception :: FovMode -> Loc -> LMap -> Perception +perception fovMode ploc lmap = + let + -- Reachable are all fields on an unblocked path from the hero position. + reachable = fullscan fovMode ploc lmap + -- Everybody can see locations that have light and are reachable. + uniVisible = S.filter (\ loc -> Tile.light (lmap `at` loc)) reachable + -- The hero is assumed to carry a light source, too. + litVisible = S.insert ploc uniVisible + -- Reachable fields adjacent to lit fields are visible, too. + adjVisible = + S.filter + (\ loc -> L.any (\ l -> S.member l litVisible) (surroundings loc)) + reachable + -- Visible fields are either lit or adjacent to lit. + visible = S.union litVisible adjVisible + in Perception reachable visible diff --git a/src/Random.hs b/src/Random.hs new file mode 100644 --- /dev/null +++ b/src/Random.hs @@ -0,0 +1,100 @@ +module Random (module Frequency, module Random) where + +import qualified Data.Binary as Binary +import Data.Ratio +import Data.List as L +import qualified System.Random as R +import Control.Monad.State + +import Frequency + +type Rnd a = State R.StdGen a + +-- Written in a "portable" way because the implementation of +-- State changes between mtl versions 1 and 2. +randomR :: (R.Random a) => (a, a) -> Rnd a +randomR rng = + do + g <- get + let (x, ng) = R.randomR rng g + put ng + return x + +binaryChoice :: a -> a -> Rnd a +binaryChoice p0 p1 = + do + b <- randomR (False,True) + return (if b then p0 else p1) + +chance :: Rational -> Rnd Bool +chance r = + do + let n = numerator r + d = denominator r + k <- randomR (1,d) + return (k <= n) + +-- | d for die/dice +d :: Int -> Rnd Int +d x = if x <= 0 then return 0 else randomR (1,x) + +oneOf :: [a] -> Rnd a +oneOf xs = + do + r <- randomR (0, length xs - 1) + return (xs !! r) + +frequency :: Frequency a -> Rnd a +frequency (Frequency xs) = + do + r <- randomR (1, sum (map fst xs)) + return (frequency' r xs) + where + frequency' :: Int -> [(Int, a)] -> a + frequency' _ [(_, x)] = x + frequency' m ((n, x) : xs) + | m <= n = x + | otherwise = frequency' (m - n) xs + +rndToIO :: Rnd a -> IO a +rndToIO r = + do + g <- R.getStdGen + let (x,g') = runState r g + R.setStdGen g' + return x + +-- ** Arithmetic operations on Rnd. + +infixl 7 *~ +infixl 6 ~+~ + +(~+~) :: Num a => Rnd a -> Rnd a -> Rnd a +(~+~) = liftM2 (+) + +(*~) :: Num a => Int -> Rnd a -> Rnd a +x *~ r = liftM sum (replicateM x r) + +-- RollDice: 1d7, 3d3, etc. (a, b) represent (a *~ d b). +type RollDice = (Binary.Word8, Binary.Word8) + +rollDice :: RollDice -> Rnd Int +rollDice (a', b') = + let (a, b) = (fromEnum a', fromEnum b') + in a *~ d b + +-- rollQuad (a, b, x, y) = a *~ d b + (lvl * (x *~ d y)) / 10 +type RollQuad = (Binary.Word8, Binary.Word8, Binary.Word8, Binary.Word8) + +rollQuad :: Int -> RollQuad -> Rnd Int +rollQuad lvl (a, b, x, y) = do + aDb <- rollDice (a, b) + xDy <- rollDice (x, y) + return $ aDb + (lvl * xDy) `div` 10 + +intToQuad :: Int -> RollQuad +intToQuad 0 = (0, 0, 0, 0) +intToQuad n = let n' = fromIntegral n + in if n' > maxBound || n' < minBound + then error "intToQuad" + else (n', 1, 0, 0) diff --git a/src/Save.hs b/src/Save.hs new file mode 100644 --- /dev/null +++ b/src/Save.hs @@ -0,0 +1,52 @@ +module Save where + +import System.Directory +import Control.Exception as E hiding (handle) + +import File +import Level +import State +import qualified Config + +-- | Name of the save game. +file :: Config.CP -> IO FilePath +file config = Config.getFile config "files" "saveGame" + +-- | We save a simple serialized version of the current level and +-- the current state. The 'False' is used only as an EOF marker. +saveGame :: State -> IO () +saveGame state = + do + f <- file (sconfig state) + encodeCompressedFile f (state, False) + +-- | Restore a saved game. Returns either the current level and +-- game state, or a string containing an error message if restoring +-- the game fails. +restoreGame :: Config.CP -> IO (Either State String) +restoreGame config = + E.catch (do + mvBkp config + f <- file config + (x, z) <- strictDecodeCompressedFile (f ++ ".bkp") + (z :: Bool) `seq` return $ Left x) + (\ e -> case e :: IOException of + _ -> return (Right $ + "Restore failed: " + ++ (unwords . lines) (show e))) + +-- | Move the savegame file to a backup slot. +mvBkp :: Config.CP -> IO () +mvBkp config = + do + f <- file config + renameFile f (f ++ ".bkp") + +-- | Remove the backup of the savegame. Should be called before any +-- non-error exit from the game. +rmBkp :: Config.CP -> IO () +rmBkp config = + do + f <- file config + E.catch (removeFile (f ++ ".bkp")) + (\ e -> case e :: IOException of _ -> return ()) diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -0,0 +1,178 @@ +module State where + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap as IM +import Control.Monad +import Data.Binary +import qualified Config + +import Movable +import Geometry +import Level +import Dungeon +import Item +import Message +import qualified ItemKind +import WorldLoc + +-- | The 'State' contains all the game state that has to be saved. +-- In practice, we maintain extra state, but that state is state +-- accumulated during a turn or relevant only to the current session. +-- TODO: consider changing slevel to LevelId, removing the lname field +-- and not removing the current level from the dungeon. +data State = State + { splayer :: Actor, -- ^ represents the player-controlled movable + scursor :: Cursor, -- ^ cursor location and level to return to + shistory :: [Message], + ssensory :: SensoryMode, + sdisplay :: DisplayMode, + stime :: Time, + sassocs :: Assocs, -- ^ how every item appears + sdiscoveries :: Discoveries, -- ^ items (kinds) that have been discovered + sdungeon :: Dungeon, -- ^ all but the current dungeon level + slevel :: Level, + scounter :: (Int, Int), -- ^ stores next hero index and monster index + sconfig :: Config.CP + } + deriving Show + +data Cursor = Cursor + { ctargeting :: Bool, -- ^ are we in targeting mode? + clocLn :: LevelId, -- ^ cursor level + clocation :: Loc, -- ^ cursor coordinates + creturnLn :: LevelId -- ^ the level current player resides on + } + deriving Show + +defaultState :: Dungeon -> Level -> State +defaultState dng lvl = + State + (AHero 0) + (Cursor False (LambdaCave (-1)) (-1, -1) (lname lvl)) + [] + Implicit Normal + 0 + IM.empty + S.empty + dng + lvl + (0, 0) + (Config.defaultCP) + +updateCursor :: (Cursor -> Cursor) -> State -> State +updateCursor f s = s { scursor = f (scursor s) } + +updateHistory :: ([String] -> [String]) -> State -> State +updateHistory f s = s { shistory = f (shistory s) } + +updateTime :: (Time -> Time) -> State -> State +updateTime f s = s { stime = f (stime s) } + +updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State +updateDiscoveries f s = s { sdiscoveries = f (sdiscoveries s) } + +updateLevel :: (Level -> Level) -> State -> State +updateLevel f s = s { slevel = f (slevel s) } + +updateDungeon :: (Dungeon -> Dungeon) -> State -> State +updateDungeon f s = s {sdungeon = f (sdungeon s)} + +toggleVision :: State -> State +toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Smell + Vision n -> Vision (n-1) + Smell -> Implicit + Implicit -> Vision 3 } + +toggleOmniscient :: State -> State +toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient + then Normal + else Omniscient } + +toggleTerrain :: State -> State +toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal + Terrain n -> Terrain (n-1) + _ -> Terrain 4 } + +instance Binary State where + put (State player cursor hst sense disp time assocs discs dng lvl ct config) = + do + put player + put cursor + put hst + put sense + put disp + put time + put assocs + put discs + put dng + put lvl + put ct + put config + get = + do + player <- get + cursor <- get + hst <- get + sense <- get + disp <- get + time <- get + assocs <- get + discs <- get + dng <- get + lvl <- get + ct <- get + config <- get + return + (State player cursor hst sense disp time assocs discs dng lvl ct config) + +instance Binary Cursor where + put (Cursor act cln loc rln) = + do + put act + put cln + put loc + put rln + get = + do + act <- get + cln <- get + loc <- get + rln <- get + return (Cursor act cln loc rln) + +data SensoryMode = + Implicit + | Vision Int + | Smell + deriving (Show, Eq) + +instance Binary SensoryMode where + put Implicit = putWord8 0 + put (Vision n) = putWord8 1 >> put n + put Smell = putWord8 2 + get = do + tag <- getWord8 + case tag of + 0 -> return Implicit + 1 -> liftM Vision get + 2 -> return Smell + _ -> fail "no parse (SensoryMode)" + +data DisplayMode = + Normal + | Omniscient + | Terrain Int -- TODO: unused right now + deriving (Show, Eq) + +instance Binary DisplayMode where + put Normal = putWord8 0 + put Omniscient = putWord8 1 + put (Terrain n) = putWord8 2 >> put n + get = do + tag <- getWord8 + case tag of + 0 -> return Normal + 1 -> return Omniscient + 2 -> liftM Terrain get + _ -> fail "no parse (DisplayMode)" diff --git a/src/Strategy.hs b/src/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/Strategy.hs @@ -0,0 +1,50 @@ +module Strategy where + +import Control.Monad + +import Frequency + +-- Monster strategies + +-- | A strategy is a choice of frequency tables. +newtype Strategy a = Strategy { runStrategy :: [Frequency a] } + deriving Show + +-- | Strategy is a monad. TODO: Can we write this as a monad transformer? +instance Monad Strategy where + return x = Strategy $ return (Frequency [(1, x)]) + m >>= f = Strategy $ + filter (\ (Frequency xs) -> not (null xs)) + [ Frequency [ (p * q, b) + | (p, a) <- runFrequency x, + y <- runStrategy (f a), + (q, b) <- runFrequency y ] + | x <- runStrategy m ] + +liftFrequency :: Frequency a -> Strategy a +liftFrequency f = + Strategy $ filter (\ (Frequency xs) -> not (null xs)) $ return f + +instance MonadPlus Strategy where + mzero = Strategy [] + mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) + +infixr 2 .| + +(.|) :: Strategy a -> Strategy a -> Strategy a +(.|) = mplus + +reject :: Strategy a +reject = mzero + +infix 3 .=> + +(.=>) :: Bool -> Strategy a -> Strategy a +p .=> m | p = m + | otherwise = mzero + +only :: (a -> Bool) -> Strategy a -> Strategy a +only p s = + do + x <- s + p x .=> return x diff --git a/src/StrategyState.hs b/src/StrategyState.hs new file mode 100644 --- /dev/null +++ b/src/StrategyState.hs @@ -0,0 +1,217 @@ +module StrategyState where + +import Data.List as L +import Data.Map as M +import Data.Set as S +import qualified Data.IntMap as IM +import Data.Maybe +import Control.Monad +import Control.Monad.State hiding (State) +import Control.Exception (assert) + +import Geometry +import Level +import Movable +import MovableState +import MovableKind +import Random +import Perception +import Strategy +import State +import Action +import Actions +import ItemAction +import qualified ItemKind +import Item +import qualified Effect +import qualified Tile + +-- import Debug.Trace + +{- +Monster movement +---------------- + +Not all monsters use the same algorithm to find the hero. +Some implemented and unimplemented methods are listed below: + +* Random +The simplest way to have a monster move is at random. + +* Sight +If a monster can see the hero (as an approximation, +we assume it is the case when the hero can see the monster), +the monster should move toward the hero. + +* Smell +The hero leaves a trail when moving toward the dungeon. +For a certain timespan (100--200 moves), it is possible +for certain monsters to detect that a hero has been at a certain field. +Once a monster is following a trail, it should move to the +neighboring field where the hero has most recently visited. + +* Noise +The hero makes noise. If the distance between the hero +and the monster is small enough, the monster can hear the hero +and moves into the approximate direction of the hero. +-} + +strategy :: Actor -> State -> Perceptions -> Strategy (Action ()) +strategy actor + oldState@(State { scursor = cursor, + splayer = pl, + stime = time, + slevel = Level { lname = ln, + lsmell = nsmap, + lmap = lmap } }) + per = +-- trace (show time ++ ": " ++ show actor) $ + strategy + where + Movable { mkind = mk, mloc = me, mdir = mdir, + mtarget = tgt, mitems = items } = + getActor actor oldState + delState = deleteActor actor oldState + enemyVisible a l = + -- We assume monster sight is infravision, so light has no significance. + nsight mk && actorReachesActor a actor l me per Nothing || + -- Any enemy is visible if adjacent (e. g., a monster player). + memActor a delState && adjacent me l + -- If no heroes on the level, monsters go at each other. TODO: let them + -- earn XP by killing each other to make this dangerous to the player. + hs = L.map (\ (i, m) -> (AHero i, mloc m)) $ + IM.assocs $ lheroes $ slevel delState + ms = L.map (\ (i, m) -> (AMonster i, mloc m)) $ + IM.assocs $ lmonsters $ slevel delState + -- Below, "foe" is the hero (or a monster, or loc) chased by the actor. + (newTgt, floc) = + case tgt of + TEnemy a ll | focusedMonster -> + case findActorAnyLevel a delState of + Just (_, m) -> + let l = mloc m + in if enemyVisible a l + then (TEnemy a l, Just l) + else if isJust (snd closest) || me == ll + then closest -- prefer visible foes + else (tgt, Just ll) -- last known location of enemy + Nothing -> closest -- enemy dead, monsters can feel it + TLoc loc -> if me == loc + then closest + else (tgt, Just loc) -- ignore everything and go to loc + _ -> closest + closest = + let hsAndTraitor = if isAMonster pl + then (pl, mloc $ getPlayerBody delState) : hs + else hs + foes = if L.null hsAndTraitor then ms else hsAndTraitor + -- We assume monster sight is infravision, so light has no effect. + foeVisible = L.filter (\ (a, l) -> enemyVisible a l) foes + foeDist = L.map (\ (a, l) -> (distance (me, l), l, a)) foeVisible + in case foeDist of + [] -> (TCursor, Nothing) + _ -> let (_, l, a) = L.minimum foeDist + in (TEnemy a l, Just l) + onlyFoe = onlyMoves (maybe (const False) (==) floc) me + towardsFoe = case floc of + Nothing -> const mzero + Just loc -> + let foeDir = towards (me, loc) + in only (\ x -> distance (foeDir, x) <= 1) + lootHere = (\ x -> not $ L.null $ Tile.titems $ lmap `at` x) + onlyLoot = onlyMoves lootHere me + exitHere = (\ x -> let t = lmap `at` x in Tile.open t && Tile.isExit t) + onlyExit = onlyMoves exitHere me + onlyKeepsDir k = only (\ x -> maybe True (\ d -> distance (d, x) <= k) mdir) + onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) mdir) + onlyUnoccupied = onlyMoves (unoccupied (levelMonsterList delState)) me + -- Monsters don't see doors more secret than that. Enforced when actually + -- opening doors, too, so that monsters don't cheat. TODO: remove the code + -- duplication, though. + openPower = case strongestItem items "ring" of + Just i -> niq mk + ipower i + Nothing -> niq mk + openableHere = openable openPower lmap + onlyOpenable = onlyMoves openableHere me + accessibleHere = accessible lmap me + onlySensible = onlyMoves (\ l -> accessibleHere l || openableHere l) me + focusedMonster = niq mk > 10 + smells = + L.map fst $ + L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $ + L.filter (\ (_, s) -> s > 0) $ + L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves + fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d + + strategy = + fromDir True (onlyFoe moveFreely) + .| isJust floc .=> liftFrequency (msum freqs) + .| lootHere me .=> actionPickup + .| fromDir True moveAround + actionPickup = return $ actorPickupItem actor + tis = Tile.titems $ lmap `at` me + freqs = [applyFreq items 1, applyFreq tis 2, + throwFreq items 2, throwFreq tis 5, towardsFreq] + applyFreq is multi = Frequency + [ (benefit * multi, actionApply (ItemKind.jname ik) i) + | i <- is, + let ik = ItemKind.getIK (ikind i), + let benefit = + (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik), + benefit > 0, + nsight mk || not (ItemKind.jname ik == "scroll")] + actionApply groupName item = + applyGroupItem actor (applyToVerb groupName) item + throwFreq is multi = if not $ nsight mk then mzero else Frequency + [ (benefit * multi, actionThrow (ItemKind.jname ik) i) + | i <- is, + let ik = ItemKind.getIK (ikind i), + let benefit = + - (1 + ipower i) * Effect.effectToBenefit (ItemKind.jeffect ik), + benefit > 0, + -- Wasting swords would be too cruel to the player. + not (ItemKind.jname ik == "sword")] + actionThrow groupName item = + zapGroupItem actor (fromJust floc) (zapToVerb groupName) item + towardsFreq = + let freqs = runStrategy $ fromDir False moveTowards + in if nsight mk && not (L.null freqs) + then scale 30 $ head freqs + else mzero + moveTowards = + onlySensible $ + onlyUnoccupied (towardsFoe moveFreely) + .| towardsFoe moveFreely + moveAround = + onlySensible $ + (if nsight mk then onlyUnoccupied else id) $ + nsmell mk .=> L.foldr (.|) reject (L.map return smells) + .| onlyOpenable moveFreely + .| moveFreely + moveFreely = onlyLoot moveRandomly + .| onlyExit (onlyKeepsDir 2 moveRandomly) + .| niq mk > 15 .=> onlyKeepsDir 0 moveRandomly + .| niq mk > 10 .=> onlyKeepsDir 1 moveRandomly + .| niq mk > 5 .=> onlyKeepsDir 2 moveRandomly + .| onlyKeepsDir_9 moveRandomly + .| moveRandomly + +dirToAction :: Actor -> Target -> Bool -> Dir -> Action () +dirToAction actor tgt allowAttacks dir = + assert (dir /= (0,0)) $ do + -- set new direction + updateAnyActor actor $ \ m -> m { mdir = Just dir, mtarget = tgt } + -- perform action + tryWith (advanceTime actor) $ + -- if the following action aborts, we just advance the time and continue + -- TODO: ensure time is taken for other aborted actions in this file + moveOrAttack allowAttacks True actor dir + +onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir +onlyMoves p l = only (\ x -> p (l `shift` x)) + +moveRandomly :: Strategy Dir +moveRandomly = liftFrequency $ uniform moves + +wait :: Actor -> Strategy (Action ()) +wait actor = return $ advanceTime actor diff --git a/src/Terrain.hs b/src/Terrain.hs new file mode 100644 --- /dev/null +++ b/src/Terrain.hs @@ -0,0 +1,227 @@ +module Terrain + (Terrain(Door), DL(Light, Dark), rock, opening, floorDark, floorLight, unknown, stairs, door, deDoor, isFloor, isFloorDark, isRock, isOpening, isUnknown, isOpen, isExit, deStairs, fromDL, toDL, isAlight, lookTerrain, viewTerrain) where + +import Control.Monad + +import Data.Binary +import Data.Maybe + +import qualified Color +import Geometry +import WorldLoc + +import Color +import Effect +import Random + +data TileKind = TileKind + { usymbol :: !Char -- ^ map symbol + , uname :: String -- ^ name + , ucolor :: !Color.Color -- ^ map color + , ucolor2 :: !Color.Color -- ^ map color when not in FOV + , ufreq :: !Int -- ^ created that often (within a group?) + , ufeature :: [Feature] -- ^ properties + } + deriving (Show, Eq, Ord) + +data Feature = + Walkable -- ^ actors can walk through + | Clear -- ^ actors can see through + | Exit -- ^ is an exit from a room + | Lit Int -- ^ emits light; radius 0 means just the tile is lit + | Aura Effect -- ^ sustains the effect continuously + | Cause Effect -- ^ causes the effect when triggered + | Change TileKind -- ^ transitions when triggered + | Climbable VDir -- ^ triggered by climbing + | Openable -- ^ triggered by opening + | Closable -- ^ triggered by closable + | Secret RollDice -- ^ triggered by searching a number of times + deriving (Show, Eq, Ord) + +wall, doorOpen, doorClosed, doorSecret :: TileKind -- TODO: , opening, floorDark, floorLight, unknown + +wall = TileKind + { usymbol = '#' + , uname = "A wall." + , ucolor = Color.BrWhite + , ucolor2 = Color.defFG + , ufreq = 100 + , ufeature = [] + } + +doorOpen = TileKind + { usymbol = '\'' + , uname = "An open door." + , ucolor = Color.Yellow + , ucolor2 = Color.BrBlack + , ufreq = 100 + , ufeature = [Walkable, Clear, Exit, Lit 0, Change doorClosed, Openable] + } + +doorClosed = TileKind + { usymbol = '+' + , uname = "A closed door." + , ucolor = Color.Yellow + , ucolor2 = Color.BrBlack + , ufreq = 100 + , ufeature = [Exit, Change doorClosed, Closable] + } + +doorSecret = wall + { ufeature = [Change doorClosed, Secret (7, 2)] + } + +data Terrain = + Rock + | Opening + | Floor DL + | Unknown + | Stairs DL VDir (Maybe WorldLoc) + | Door (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret + deriving Show + +instance Binary VDir where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +instance Binary Terrain where + put Rock = putWord8 0 + put Opening = putWord8 1 + put (Floor dl) = putWord8 2 >> put dl + put Unknown = putWord8 3 + put (Stairs dl d n) = putWord8 5 >> put dl >> put d >> put n + put (Door o) = putWord8 6 >> put o + get = do + tag <- getWord8 + case tag of + 0 -> return Rock + 1 -> return Opening + 2 -> liftM Floor get + 3 -> return Unknown + 5 -> liftM3 Stairs get get get + 6 -> liftM Door get + _ -> fail "no parse (Terrain)" + +instance Eq Terrain where + Rock == Rock = True + Opening == Opening = True + Floor l == Floor l' = l == l' + Unknown == Unknown = True + Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t' + Door o == Door o' = o == o' + _ == _ = False + +data DL = Dark | Light + deriving (Eq, Show, Enum, Bounded) + +instance Binary DL where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +rock, opening, floorDark, floorLight, unknown :: Terrain +rock = Rock +opening = Opening +floorDark = Floor Dark +floorLight = Floor Light +unknown = Unknown + +stairs :: DL -> VDir -> Maybe WorldLoc -> Terrain +stairs = Stairs + +deStairs :: Terrain -> Maybe (VDir, Maybe WorldLoc) +deStairs (Stairs _ vdir next) = Just (vdir, next) +deStairs _ = Nothing + +deDoor :: Terrain -> Maybe (Maybe Int) +deDoor (Door n) = Just n +deDoor _ = Nothing + +door :: Maybe Int -> Terrain +door = Door + +isFloor :: Terrain -> Bool +isFloor (Floor _) = True +isFloor _ = False + +isFloorDark :: Terrain -> Bool +isFloorDark (Floor Dark) = True +isFloorDark _ = False + +isRock :: Terrain -> Bool +isRock Rock = True +isRock _ = False + +isOpening :: Terrain -> Bool +isOpening Opening = True +isOpening _ = False + +isUnknown :: Terrain -> Bool +isUnknown Unknown = True +isUnknown _ = False + +-- | allows moves and vision +isOpen :: Terrain -> Bool +isOpen (Floor {}) = True +isOpen Opening = True +isOpen (Door o) = isNothing o +isOpen (Stairs {}) = True +isOpen _ = False + +-- | marks an exit from a room +isExit :: Terrain -> Bool +isExit (Stairs {}) = True +isExit (Opening {}) = True +isExit (Door {}) = True +isExit _ = False + +fromDL :: DL -> Bool +fromDL Dark = False +fromDL Light = True + +toDL :: Bool -> DL +toDL False = Dark +toDL True = Light + +-- | is lighted on its own +isAlight :: Terrain -> Bool +isAlight (Floor l) = fromDL l +isAlight (Stairs l _ _) = fromDL l +isAlight _ = False + +-- | Produces a textual description for terrain, used if no objects +-- are present. +lookTerrain :: Terrain -> String +lookTerrain (Floor _) = "Floor." +lookTerrain Opening = "An opening." +lookTerrain (Stairs _ Up _) = "A staircase up." +lookTerrain (Stairs _ Down _) = "A staircase down." +lookTerrain (Door Nothing) = "An open door." +lookTerrain (Door (Just 0)) = "A closed door." +lookTerrain (Door (Just _)) = "A wall." -- secret +lookTerrain Rock = "Rock." +lookTerrain Unknown = "" + +-- | The parameter "n" is the level of evolution: +-- +-- 0: final +-- 1: stairs added +-- 2: doors added +-- 3: corridors and openings added +-- 4: only rooms +-- +-- The Bool indicates whether the loc is currently visible. +viewTerrain :: Bool -> Terrain -> (Char, Color.Color) +viewTerrain b t = + let def = if b then Color.BrWhite else Color.defFG + defDark = if b then Color.BrYellow else Color.BrBlack + defDoor = if b then Color.Yellow else Color.BrBlack + in case t of + Rock -> ('#', def) + Opening -> ('.', def) + (Floor d) -> ('.', if d == Light then def else defDark) + Unknown -> (' ', def) + (Stairs d p _) -> (if p == Up then '<' else '>', + if d == Light then def else defDark) + (Door (Just 0)) -> ('+', defDoor) + (Door (Just _)) -> viewTerrain b Rock -- secret door + (Door Nothing) -> ('\'', defDoor) diff --git a/src/Tile.hs b/src/Tile.hs new file mode 100644 --- /dev/null +++ b/src/Tile.hs @@ -0,0 +1,59 @@ +module Tile where + +import Control.Monad + +import Data.Binary +import Data.List as L + +import Item +import qualified Terrain + +data Tile = Tile + { tterrain :: Terrain.Terrain, + titems :: [Item] } + deriving Show + +instance Binary Tile where + put (Tile t is) = put t >> put is + get = liftM2 Tile get get + +unknownTile :: Tile +unknownTile = Tile Terrain.unknown [] + +-- | blocks moves and vision +closed :: Tile -> Bool +closed = not . open + +floor :: Tile -> Bool +floor = Terrain.isFloor . tterrain + +canBeDoor :: Tile -> Bool +canBeDoor t = + case Terrain.deDoor $ tterrain t of + Just o | secret o -> True + _ -> + Terrain.isRock (tterrain t) || + Terrain.isUnknown (tterrain t) + +secret :: Maybe Int -> Bool +secret (Just n) | n /= 0 = True +secret _ = False + +isUnknown :: Tile -> Bool +isUnknown = Terrain.isUnknown . tterrain + +toOpen :: Bool -> Maybe Int +toOpen True = Nothing +toOpen False = Just 0 + +-- | allows moves and vision +open :: Tile -> Bool +open = Terrain.isOpen . tterrain + +-- | is lighted on its own +light :: Tile -> Bool +light = Terrain.isAlight . tterrain + +-- | marks an exit from a room +isExit :: Tile -> Bool +isExit = Terrain.isExit . tterrain diff --git a/src/Turn.hs b/src/Turn.hs new file mode 100644 --- /dev/null +++ b/src/Turn.hs @@ -0,0 +1,273 @@ +module Turn where + +import Control.Monad +import Control.Monad.State hiding (State) +import Data.List as L +import Data.Map as M +import Data.Set as S +import qualified Data.Ord as Ord +import qualified Data.IntMap as IM +import qualified Data.Char as Char + +import Action +import Actions +import Command +import qualified Config +import Display hiding (display) +import EffectAction +import Keybindings +import qualified Keys as K +import Level +import Movable +import MovableState +import Random +import State +import Strategy +import StrategyState + +-- One turn proceeds through the following functions: +-- +-- handle +-- handleMonsters, handleMonster +-- nextMove +-- handle (again) +-- +-- OR: +-- +-- handle +-- handlePlayer, playerCommand +-- handleMonsters, handleMonster +-- nextMove +-- handle (again) +-- +-- What's happening where: +-- +-- handle: determine who moves next, +-- dispatch to handleMonsters or handlePlayer +-- +-- handlePlayer: remember, display, get and process commmand(s), +-- update smell map, update perception +-- +-- handleMonsters: find monsters that can move +-- +-- handleMonster: determine and process monster action, advance monster time +-- +-- nextMove: advance global game time, HP regeneration, monster generation +-- +-- This is rather convoluted, and the functions aren't named very aptly, so we +-- should clean this up later. TODO. + +-- | Decide if the hero is ready for another move. +-- Dispatch to either 'handleMonsters' or 'handlePlayer'. +handle :: Action () +handle = + do + debug "handle" + state <- get + pl <- gets splayer + let ptime = mtime (getPlayerBody state) -- time of player's next move + let time = stime state -- current game time + debug $ "handle: time check. ptime = " ++ show ptime ++ ", time = " ++ show time + if ptime > time + then do + -- the hero can't make a move yet; monsters first + -- we redraw the map even between player moves so that the movements of fast + -- monsters can be traced on the map; we disable this functionality if the + -- player is currently running, as it would slow down the running process + -- unnecessarily + ifRunning (const $ return True) displayWithoutMessage + handleMonsters + else do + handlePlayer -- it's the hero's turn! + +-- | Handle monster moves. Perform moves for individual monsters as long as +-- there are monsters that have a move time which is less than or equal to +-- the current time. +handleMonsters :: Action () +handleMonsters = + do + debug "handleMonsters" + time <- gets stime + ms <- gets (lmonsters . slevel) + pl <- gets splayer + if IM.null ms + then nextMove + else let order = Ord.comparing (mtime . snd) + (i, m) = L.minimumBy order (IM.assocs ms) + actor = AMonster i + in if mtime m > time || actor == pl + then nextMove -- no monster is ready for another move + else handleMonster actor + +-- | Handle the move of a single monster. +handleMonster :: Actor -> Action () +handleMonster actor = + do + debug "handleMonster" + state <- get + per <- currentPerception + -- Run the AI: choses an action from those given by the AI strategy. + action <- + liftIO $ rndToIO $ + frequency (head (runStrategy (strategy actor state per .| wait actor))) + action + handleMonsters + +-- | After everything has been handled for the current game time, we can +-- advance the time. Here is the place to do whatever has to be done for +-- every time unit; currently, that's monster generation. +-- TODO: nextMove may not be a good name. It's part of the problem of the +-- current design that all of the top-level functions directly call each +-- other, rather than being called by a driver function. +nextMove :: Action () +nextMove = + do + debug "nextMove" + modify (updateTime (+1)) + regenerateLevelHP + generateMonster + handle + +-- | Handle the move of the hero. +handlePlayer :: Action () +handlePlayer = + do + debug "handlePlayer" + remember -- the hero perceives his (potentially new) surroundings + -- determine perception before running player command, in case monsters + -- have opened doors ... + oldPlayerTime <- gets (mtime . getPlayerBody) + withPerception playerCommand -- get and process a player command + -- at this point, the command was successful and possibly took some time + newPlayerTime <- gets (mtime . getPlayerBody) + if newPlayerTime == oldPlayerTime + then withPerception handlePlayer -- no time taken, repeat + else do + state <- get + pl <- gets splayer + let time = stime state + ploc = mloc (getPlayerBody state) + sTimeout = Config.get (sconfig state) "monsters" "smellTimeout" + -- update smell + when (isAHero pl) $ -- only humans leave strong scent + modify (updateLevel (updateSMap (M.insert ploc (time + sTimeout)))) + -- determine player perception and continue with monster moves + withPerception handleMonsters + +-- | Determine and process the next player command. +playerCommand :: Action () +playerCommand = + do + display -- draw the current surroundings + history -- update the message history and reset current message + tryRepeatedlyWith stopRunning $ do -- on abort, just ask for a new command + ifRunning continueRun $ do + k <- session nextCommand + handleKey stdKeybindings k + + -- Design thoughts (in order to get rid or partially rid of the somewhat + -- convoluted design we have): We have three kinds of commands. + -- + -- Normal commands: they take time, so after handling the command, state changes, + -- time passes and monsters get to move. + -- + -- Instant commands: they take no time, and do not change the state. + -- + -- Meta commands: they take no time, but may change the state. + -- + -- Ideally, they can all be handled via the same (event) interface. We maintain an + -- event queue where we store what has to be handled next. The event queue is a sorted + -- list where every event contains the timestamp when the event occurs. The current game + -- time is equal to the head element of the event queue. Currently, we only have action + -- events. An actor gets to move on an event. The actor is responsible for reinsterting + -- itself in the event queue. Possible new events may include HP regeneration events, + -- monster generation events, or actor death events. + -- + -- If an action does not take any time, the actor just reinserts itself with the current + -- time into the event queue. If the insert algorithm makes sure that later events with + -- the same time get precedence, this will work just fine. + -- + -- It's important that we decouple issues like HP regeneration from action events if we + -- do it like that, because otherwise, HP regeneration may occur multiple times. + -- + -- Given this scheme, we may get orphaned events: a HP regeneration event for a dead + -- monster may be scheduled. Or a move event for a monster suddenly put to sleep. We + -- therefore have to given handlers the option of accessing and cleaning up the event + -- queue. + +-- The remaining functions in this module are individual actions or helper +-- functions. + +-- TODO: Should be defined in Command module. +helpCommand = Described "display help" displayHelp + +-- | Display command help. TODO: Should be defined in Actions module. +displayHelp :: Action () +displayHelp = do + let coImage session k = + let macros = snd session + domain = M.keysSet macros + in if k `S.member` domain then [] else [k] + ++ [ from | (from, to) <- M.assocs macros, to == k ] + aliases <- session (return . coImage) + let helpString = keyHelp aliases stdKeybindings + messageOverlayConfirm "Basic keys:" helpString + abort + +heroSelection :: [(K.Key, Command)] +heroSelection = + let heroSelect k = (K.Char (Char.intToDigit k), + Undescribed $ + selectPlayer (AHero k) >> withPerception playerCommand) + in fmap heroSelect [0..9] + +stdKeybindings :: Keybindings +stdKeybindings = Keybindings + { kdir = moveDirCommand, + kudir = runDirCommand, + kother = M.fromList $ + heroSelection ++ + [ -- interaction with the dungeon + (K.Char 'o', openCommand), + (K.Char 'c', closeCommand), + (K.Char 's', searchCommand), + + (K.Char '<', ascendCommand), + (K.Char '>', descendCommand), + + (K.Char '*', monsterCommand), + (K.Char '/', floorCommand), + (K.Tab , heroCommand), + + -- items + (K.Char 'g', pickupCommand), + (K.Char 'd', dropCommand), + (K.Char 'i', inventoryCommand), + (K.Char 'q', quaffCommand), + (K.Char 'r', readCommand), + (K.Char 't', throwCommand), + (K.Char 'a', aimCommand), + + -- wait + -- (K.Char ' ', waitCommand), -- dangerous, space is -more- key + (K.Char '.', waitCommand), + + -- saving or ending the game + (K.Char 'X', saveCommand), + (K.Char 'Q', quitCommand), + + -- debug modes + (K.Char 'R', Undescribed $ modify toggleVision), + (K.Char 'O', Undescribed $ modify toggleOmniscient), + (K.Char 'T', Undescribed $ modify toggleTerrain), + (K.Char 'I', Undescribed $ gets (lmeta . slevel) >>= abortWith), + + -- information for the player + (K.Char 'V', versionCommand), + (K.Char 'P', historyCommand), + (K.Char 'D', dumpCommand), + (K.Char '?', helpCommand), + (K.Return , acceptCommand displayHelp), + (K.Esc , cancelCommand) + ] + } diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -0,0 +1,11 @@ +module Version where + +import Data.Version + +-- Cabal +import qualified Paths_Allure as Self (version) + +import qualified Display + +version :: String +version = showVersion Self.version ++ " (" ++ Display.displayId ++ " frontend)" diff --git a/src/WorldLoc.hs b/src/WorldLoc.hs new file mode 100644 --- /dev/null +++ b/src/WorldLoc.hs @@ -0,0 +1,24 @@ +module WorldLoc where + +import Control.Monad +import Data.Binary +import Geometry + +-- | Level ids are just integers. +newtype LevelId = LambdaCave Int + deriving (Show, Eq, Ord) + +instance Binary LevelId where + put (LambdaCave n) = put n + get = liftM LambdaCave get + +-- | Name of a level. +levelName :: LevelId -> String +levelName (LambdaCave n) = "The Lambda Cave " ++ show n + +-- | Depth of a level. +levelNumber :: LevelId -> Int +levelNumber (LambdaCave n) = n + +-- | A world location is a level together with a location on that level. +type WorldLoc = (LevelId, Loc) diff --git a/src/config.default b/src/config.default new file mode 100644 --- /dev/null +++ b/src/config.default @@ -0,0 +1,56 @@ +; This is the default config file, included in the binary itself. +; The game looks for the user config file in ~/.Allure/config. +; We restricts the config file format by insisting that +; options are case-sensitive and permitting only ';' comments. + +; If you contribute to the game, please create directory ~/.Allure/ +; as described in README.markdown. In this way, you will not accidentally +; commit your private high scores (nor your save files) to the game +; git repository. + +[dungeon] +; the hardcoded default for levels with no specified layout: +LambdaCave_1: rogueRoom +; access to stairs may be blocked, so only suitable for the last level: +LambdaCave_10: noiseRoom +LambdaCave_3: bigRoom +depth: 10 + +[engine] +fovMode: digital +;fovMode: permissive +;fovMode: shadow +fovRadius: 40 + +; paths to various game files; relative to ~/.Allure/ +; (or analogous prefixes for other OSes, see getAppUserDataDirectory) +[files] +highScores: scores +saveGame: save + +[heroes] +HeroName_0: you +HeroName_1: Haskell Alvin +HeroName_2: Alonzo Barkley +HeroName_3: Ernst Abraham +HeroName_4: Samuel Saunders +HeroName_5: Roger Robin +baseHP: 50 +extraHeroes: 0 +firstDeathEnds: False + +[macros] +; TODO: the following does not work yet: +; ; throw a dart at the closest monster +; t: asterisk Return t Return +; TODO: in gtk it could be implemented via unGetChan, +; unless we prefer an explicit command queue, with flushing, etc. +; +; Angband compatibility +v: t + +[monsters] +smellTimeout: 1000 + +[ui] +historyMax: 500