Allure-0.4.1: src/Actions.hs
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)))