Allure-0.4.2: src/Actions.hs
module Actions where
import Control.Monad
import Control.Monad.State hiding (State, state)
import qualified Data.List as L
import qualified Data.IntMap as IM
import Data.Maybe
import qualified Data.Set as S
import Utils.Assert
import Action
import Display hiding (display)
import Loc
import Dir
import Grammar
import qualified HighScores as H
import Item
import qualified Keys as K
import Level
import LevelState
import Actor
import ActorState
import Content.ActorKind
import ActorAdd
import Perception
import State
import qualified Config
import qualified Save
import EffectAction
import WorldLoc
import Tile -- TODO: qualified
import qualified Kind
import qualified Feature as F
import DungeonState
-- 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
state <- get
liftIO $ Save.saveGame state
ln <- gets slid
let total = calculateTotal state
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 (btarget . getPlayerBody)
cloc <- gets (clocation . scursor)
-- return to the original level of the player
modify (\ state -> state{slid = returnLn})
modify (updateCursor (\ c -> c { ctargeting = False }))
let isEnemy = case target of TEnemy _ _ -> True ; _ -> False
unless isEnemy $
if accept
then updatePlayerBody (\ p -> p { btarget = TLoc cloc })
else updatePlayerBody (\ p -> p { btarget = TCursor })
endTargetingMsg
endTargetingMsg :: Action ()
endTargetingMsg = do
pbody <- gets getPlayerBody
state <- get
lxsize <- gets (lxsize . slevel)
let verb = "target"
targetMsg = case btarget pbody of
TEnemy a _ll ->
if memActor a state
then objectActor $ getActor a state
else "a fear of the past"
TLoc loc -> "location " ++ show (fromLoc lxsize loc)
TCursor -> "current cursor position continuously"
messageAdd $ subjectActorVerb pbody verb ++ " " ++ targetMsg ++ "."
-- | Cancel something, e.g., targeting mode, resetting the cursor
-- to the position of the player. Chosen target is not invalidated.
cancelCurrent :: Action ()
cancelCurrent = do
targeting <- gets (ctargeting . scursor)
if targeting
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
lxsize <- gets (lxsize . slevel)
lysize <- gets (lysize . slevel)
let upd cursor =
let boundedShift loc =
let (sx, sy) = fromLoc lxsize (loc `shift` dir)
(bx, by) = (max 1 $ min sx (lxsize - 2),
max 1 $ min sy (lysize - 2))
in toLoc lxsize (bx, by)
cloc = iterate boundedShift (clocation cursor) !! n
in cursor{ clocation = cloc }
modify (updateCursor upd)
doLook
-- TODO: Think about doing the mode dispatch elsewhere, especially if over
-- time more and more commands need to do the dispatch inside their code
-- (currently only a couple do).
move :: 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 { bdir = 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
loc <- gets (bloc . getPlayerBody)
per <- currentPerception
msg <- currentMessage
ms <- gets (lmonsters . slevel)
hs <- gets (lheroes . slevel)
lxsize <- gets (lxsize . slevel)
lvl <- gets 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 bloc (IM.elems dms))
monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per))
newsReported = not (L.null msg)
tile = lvl `rememberAt` loc -- tile at current location
itemsHere = not (L.null (lvl `irememberAt` loc))
heroThere = (loc `shift` dir) `elem` L.map bloc (IM.elems hs)
dirOK = accessible lvl loc (loc `shift` dir)
isTExit = Tile.isExit tile
isWalkableDark = Tile.isWalkable tile && not (Tile.isLit tile)
-- What happens next is mostly depending on the terrain we're currently on.
let hop | (monstersVisible || heroThere || newsReported ||
itemsHere || isTExit) = abort
| isWalkableDark =
-- 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 -> dirDistSq lxsize (neg dir) x > 1
&& (accessible lvl loc (loc `shift` x))
|| openable lvl (SecretStrength 1) (loc `shift` x))
(moves lxsize)
allCloseTo main = L.all (\ d -> dirDistSq lxsize 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 (not . diagonal lxsize) ns of
[ortoDir]
| allCloseTo ortoDir -> run ortoDir
_ -> abort
| not dirOK =
abort -- outside corridors never change direction
| otherwise =
let ns = L.filter (\ x -> x /= dir && dirDistSq lxsize (neg dir) x > 1) (moves lxsize)
ls = L.map (loc `shift`) ns
as = L.filter (\ x -> accessible lvl loc x
|| openable lvl (SecretStrength 1) x) ls
ts = L.map (lvl `rememberAt`) as
in if L.any Tile.isExit ts then abort else run dir
hop
ifRunning :: (Dir -> Action a) -> Action a -> Action a
ifRunning t e =
do
ad <- gets (bdir . getPlayerBody)
maybe e t ad
-- | Update player memory.
remember :: Action ()
remember =
do
per <- currentPerception
lvl <- gets slevel
let vis = S.toList (ptvisible per)
let rememberTile = [(loc, lvl `at` loc) | loc <- vis]
modify (updateLevel (updateLRMap (Kind.// rememberTile)))
let alt Nothing = Nothing
alt (Just ([], _)) = Nothing
alt (Just (t, _)) = Just (t, t)
rememberItem = IM.alter alt
modify (updateLevel (updateIMap (\ m -> L.foldr rememberItem m vis)))
-- | Ask for a direction and close the door, if any
closeDoor :: Action ()
closeDoor = do
messageReset "direction?"
display
e <- session nextCommand
lxsize <- gets (lxsize . slevel)
K.handleDirection lxsize e playerCloseDoor (neverMind True)
-- | Player closes a door. AI never does.
playerCloseDoor :: Dir -> Action ()
playerCloseDoor dir = do
state <- get
lvl <- gets slevel
pl <- gets splayer
body <- gets (getActor pl)
let hms = levelHeroList state ++ levelMonsterList state
dloc = shift (bloc body) dir -- the location we act upon
t = lvl `at` dloc
if hasFeature F.Closable t
then
case lvl `iat` dloc of
[] ->
if unoccupied hms dloc
then let adj = (Kind.// [(dloc, Tile.doorClosedId)])
in modify (updateLevel (updateLMap adj))
else abortWith "blocked" -- by monsters or heroes
_:_ -> abortWith "jammed" -- by items
else if hasFeature F.Openable t
then abortWith "already closed"
else neverMind True -- no visible doors (can be secret)
advanceTime pl
-- | An actor closes a door. Player (hero or monster) or enemy.
actorOpenDoor :: ActorId -> Dir -> Action ()
actorOpenDoor actor dir = do
lvl <- gets slevel
pl <- gets splayer
body <- gets (getActor actor)
let dloc = shift (bloc body) dir -- the location we act upon
t = lvl `at` dloc
isPlayer = actor == pl
isVerbose = isPlayer -- don't report enemy failures, if it's not player
iq = aiq $ Kind.getKind $ bkind body
openPower = SecretStrength $
if isPlayer
then 1 -- player can't open secret doors
else case strongestItem (bitems body) "ring" of -- TODO: hack
Just i -> iq + jpower i
Nothing -> iq
unless (openable lvl openPower dloc) $ neverMind isVerbose
if hasFeature F.Closable t
then abortIfWith isVerbose "already open"
else if not (hasFeature F.Closable t ||
hasFeature F.Openable t ||
hasFeature F.Hidden t)
then neverMind isVerbose -- not doors at all
else
let adj = (Kind.// [(dloc, Tile.doorOpenId)])
in modify (updateLevel (updateLMap adj))
advanceTime actor
-- | Attempt a level switch to k levels shallower.
-- TODO: perhaps set up some level name arithmetics in Level.hs
-- and hide there the fact levels are now essentially Ints.
lvlAscend :: Int -> Action ()
lvlAscend k =
do
slid <- gets slid
config <- gets sconfig
let n = levelNumber slid
nln = n - k
depth = Config.get config "dungeon" "depth"
when (nln < 1 || nln > depth) $
abortWith "no more levels in this direction"
modify (\ state -> state{slid = (LambdaCave nln)})
-- | Attempt a level change via up level and down level keys.
-- Will quit the game if the player leaves the dungeon.
lvlGoUp :: Bool -> Action ()
lvlGoUp isUp =
do
cursor <- gets scursor
targeting <- gets (ctargeting . scursor)
pbody <- gets getPlayerBody
pl <- gets splayer
slid <- gets slid
lvl <- gets slevel
st <- get
let loc = if targeting then clocation cursor else bloc pbody
tile = lvl `at` loc
vdir = if isUp then 1 else -1
sdir | hasFeature F.Climbable tile = Just 1
| hasFeature F.Descendable tile = Just (-1)
| otherwise = Nothing
case sdir of
Just vdir'
| vdir == vdir' -> -- stairs are in the right direction
case whereTo st loc 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) ->
if targeting
then do
assert (nln /= slid `blame` (nln, "stairs looped")) $
modify (\ state -> state{slid = nln})
-- do not freely reveal the other end of the stairs
lvl2 <- gets slevel
let upd cur =
let clocation = if isUnknown (lvl2 `rememberAt` nloc)
then loc
else nloc
in cur { clocation, clocLn = nln }
modify (updateCursor upd)
doLook
else tryWith (abortWith "somebody blocks the staircase") $ do
-- Remove the player from the old level.
modify (deleteActor pl)
hs <- gets levelHeroList
-- Monsters hear that players not on the level. Cancel smell.
-- Reduces memory load and savefile size.
when (L.null hs) $
modify (updateLevel (updateSmell (const IM.empty)))
-- At this place the invariant that the player exists fails.
-- Change to the new level (invariant not needed).
assert (nln /= slid `blame` (nln, "stairs looped")) $
modify (\ state -> state{slid = 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 { bloc = nloc })
-- Change the level of the player recorded in cursor.
modify (updateCursor (\ c -> c { creturnLn = nln }))
-- Bail out if anybody blocks the staircase.
inhabitants <- gets (locToActors nloc)
when (length inhabitants > 1) abort
-- The invariant "at most one actor on a tile" restored.
-- Create a backup of the savegame.
state <- get
liftIO $ do
Save.saveGame state
Save.mvBkp (sconfig state)
playerAdvanceTime
_ -> -- no stairs in the right direction
if targeting
then do
lvlAscend vdir
let upd cur = cur {clocLn = slid}
modify (updateCursor upd)
doLook
else
let txt = if isUp 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 bitems (levelHeroList state)
if total == 0
then do
go <- messageClear >> messageMoreConfirm ColorFull "Coward!"
when go $
messageMore "Next time try to grab some loot before escape!"
end
else do
let winMsg = "Congratulations, you won! Your loot, worth " ++
show total ++ " gold, is:"
displayItems winMsg True items
go <- session getConfirm
when go $ do
go2 <- handleScores True H.Victor total
when go2 $ 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 : _ -> selectPlayer (AHero ni)
>>= assert `trueM` (pl, ni, "hero duplicated")
-- | Search for secret doors
search :: Action ()
search =
do
lm <- gets (lmap . slevel)
le <- gets (lsecret . slevel)
lxsize <- gets (lxsize . slevel)
ploc <- gets (bloc . getPlayerBody)
pitems <- gets (bitems . getPlayerBody)
let delta = case strongestItem pitems "ring" of
Just i -> 1 + jpower i
Nothing -> 1
searchTile loc (slm, sle) =
let t = lm Kind.! loc
k = secretStrength (le IM.! loc) - delta
in if hasFeature F.Hidden t
then if k > 0
then (slm,
IM.insert loc (SecretStrength k) sle)
else ((loc, Tile.doorClosedId) : slm,
IM.delete loc sle)
else (slm, sle)
f (slm, sle) m = searchTile (shift ploc m) (slm, sle)
(lmDiff, lemap) = L.foldl' f ([], le) (moves lxsize)
lmNew = if L.null lmDiff then lm else lm Kind.// lmDiff
modify (updateLevel (\ l -> l{lmap = lmNew, lsecret = lemap}))
playerAdvanceTime
-- | Start the floor targeting mode or reset the cursor location to the player.
targetFloor :: Action ()
targetFloor = do
ploc <- gets (bloc . getPlayerBody)
target <- gets (btarget . 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 { btarget = tgt })
setCursor
-- | 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 (btarget . 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 (bloc m) per (Just pl)) gtlt
tgt = case lf of
[] -> target -- no monsters in sight, stick to last target
(na, nm) : _ -> TEnemy (AMonster na) (bloc nm) -- pick the next
updatePlayerBody (\ p -> p { btarget = tgt })
setCursor
-- | Set, activate and display cursor information.
setCursor :: Action ()
setCursor = do
state <- get
per <- currentPerception
ploc <- gets (bloc . getPlayerBody)
clocLn <- gets slid
let upd cursor =
let clocation = fromMaybe ploc (targetToLoc (ptvisible per) state)
in cursor { ctargeting = True, clocation, clocLn }
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
lvl <- gets slevel
per <- currentPerception
target <- gets (btarget . getPlayerBody)
let canSee = S.member loc (ptvisible per)
monsterMsg =
if canSee
then case L.find (\ m -> bloc m == loc) (levelMonsterList state) of
Just m -> subjectActor 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 lvl loc monsterMsg
-- check if there's something lying around at current loc
is = lvl `irememberAt` loc
if length is <= 2
then do
messageAdd lookMsg
else do
displayItems lookMsg False is
session getConfirm
messageAdd ""
-- | This function performs a move (or attack) by any actor,
-- i.e., it can handle monsters, heroes and both.
moveOrAttack :: Bool -> -- allow attacks?
Bool -> -- auto-open doors on move
ActorId -> -- who's moving?
Dir ->
Action ()
moveOrAttack allowAttacks autoOpen actor dir = do
-- We start by looking at the target position.
state <- get
pl <- gets splayer
lvl <- gets slevel
sm <- gets (getActor actor)
let sloc = bloc sm -- source location
tloc = sloc `shift` dir -- target location
tgt <- gets (locToActor tloc)
case tgt of
Just target
| allowAttacks ->
-- Attacking does not require full access, adjacency is enough.
actorAttackActor actor target
| accessible lvl sloc tloc -> do
-- Switching positions requires full access.
actorRunActor actor target
when (actor == pl) $
messageAdd $ lookAt False True state lvl tloc ""
| otherwise -> abortWith ""
Nothing
| accessible lvl sloc tloc -> do
-- perform the move
updateAnyActor actor $ \ body -> body {bloc = tloc}
when (actor == pl) $
messageAdd $ lookAt False True state lvl tloc ""
advanceTime actor
| allowAttacks && actor == pl
&& canBeSecretDoor (lvl `rememberAt` tloc)
-> do
messageAdd "You search your surroundings." -- TODO: proper msg
search
| autoOpen -> actorOpenDoor actor dir -- try to open a door
| otherwise -> abortWith ""
-- | Resolves the result of an actor moving into another. Usually this
-- involves melee attack, but with two heroes it just changes focus.
-- Actors on blocked locations can be attacked without any restrictions.
-- For instance, an actor capable of moving through walls
-- can be attacked from an adjacent position.
-- This function is analogous to zapGroupItem, but for melee
-- and not using up the weapon.
actorAttackActor :: ActorId -> ActorId -> Action ()
actorAttackActor source@(AHero _) target@(AHero _) =
-- Select adjacent hero by bumping into him. Takes no time.
selectPlayer target
>>= assert `trueM` (source, target, "player bumps into himself")
actorAttackActor source target = do
state <- get
sm <- gets (getActor source)
tm <- gets (getActor target)
per <- currentPerception
let groupName = "sword"
verb = attackToVerb groupName
sloc = bloc sm
-- The hand-to-hand "weapon", equivalent to +0 sword.
h2h = Item Item.fistKindId 0 Nothing 1
str = strongestItem (bitems sm) groupName
stack = fromMaybe h2h str
single = stack { jcount = 1 }
-- The message describes the source part of the action.
-- TODO: right now it also describes the victim and weapon;
-- perhaps, when a weapon is equipped, just say "you hit" or "you miss"
-- and then "nose dies" or "nose yells in pain".
msg = subjectVerbMObject sm verb tm $
if isJust str then " with " ++ objectItem state single else ""
when (sloc `S.member` ptvisible per) $ messageAdd msg
-- Messages inside itemEffectAction describe the target part.
itemEffectAction 0 source target single
advanceTime source
attackToVerb :: String -> String
attackToVerb "sword" = "hit" -- TODO: "slash"? "pierce"? "swing"?
attackToVerb "mace" = "bludgeon"
attackToVerb _ = "hit"
-- | Resolves the result of an actor running into another.
-- This involves switching positions of the two actors.
actorRunActor :: ActorId -> ActorId -> Action ()
actorRunActor source target = do
pl <- gets splayer
sloc <- gets (bloc . getActor source) -- source location
tloc <- gets (bloc . getActor target) -- target location
updateAnyActor source $ \ m -> m { bloc = tloc }
updateAnyActor target $ \ m -> m { bloc = sloc }
if source == pl
then stopRunning -- do not switch positions repeatedly
else when (isAMonster source) $ focusIfAHero target
advanceTime source
-- | Generate a monster, possibly.
generateMonster :: Action ()
generateMonster = do
state <- get
nstate <- rndToAction $ rollMonster state
srandom <- gets srandom
put $ nstate{srandom}
-- | Possibly regenerate HP for all actors on the current level.
regenerateLevelHP :: Action ()
regenerateLevelHP =
do
time <- gets stime
let upd m =
let ak = Kind.getKind $ bkind m
regen = aregen ak `div`
case strongestItem (bitems m) "amulet" of
Just i -> jpower i
Nothing -> 1
in if time `mod` regen /= 0
then m
else addHp 1 m
-- We really want hero selection to be a purely UI distinction,
-- so all heroes need to regenerate, not just the player.
-- Only the heroes on the current level regenerate (others are frozen
-- in time together with their level). This prevents cheating
-- via sending one hero to a safe level and waiting there.
modify (updateLevel (updateHeroes (IM.map upd)))
modify (updateLevel (updateMonsters (IM.map upd)))