module Game.LambdaHack.Actions where
import Control.Monad
import Control.Monad.State hiding (State, state)
import qualified Data.List as L
import qualified Data.IntMap as IM
import Data.Maybe
import qualified Data.IntSet as IS
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Action
import Game.LambdaHack.Point
import Game.LambdaHack.Vector
import Game.LambdaHack.Grammar
import qualified Game.LambdaHack.Dungeon as Dungeon
import qualified Game.LambdaHack.HighScore as H
import Game.LambdaHack.Item
import qualified Game.LambdaHack.Key as K
import Game.LambdaHack.Level
import Game.LambdaHack.Actor
import Game.LambdaHack.ActorState
import Game.LambdaHack.Perception
import Game.LambdaHack.State
import qualified Game.LambdaHack.Effect as Effect
import Game.LambdaHack.EffectAction
import qualified Game.LambdaHack.Tile as Tile
import qualified Game.LambdaHack.Kind as Kind
import qualified Game.LambdaHack.Feature as F
import Game.LambdaHack.DungeonState
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.TileKind as TileKind
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Random
import Game.LambdaHack.Msg
import Game.LambdaHack.Binding
import Game.LambdaHack.Time
import qualified Game.LambdaHack.Color as Color
import Game.LambdaHack.Draw
saveGame :: Action ()
saveGame = do
b <- displayYesNo "Really save?"
if b
then modify (\ s -> s {squit = Just (True, H.Camping)})
else abortWith "Game resumed."
quitGame :: Action ()
quitGame = do
b <- displayYesNo "Really quit?"
if b
then let status = H.Killed $ Dungeon.levelDefault 0
in modify (\ s -> s {squit = Just (False, status)})
else abortWith "Game resumed."
moveCursor :: Vector -> Int -> ActionFrame ()
moveCursor dir n = do
lxsize <- gets (lxsize . slevel)
lysize <- gets (lysize . slevel)
let upd cursor =
let shiftB loc =
shiftBounded lxsize (1, 1, lxsize 2, lysize 2) loc dir
cloc = iterate shiftB (clocation cursor) !! n
in cursor { clocation = cloc }
modify (updateCursor upd)
doLook
move :: Vector -> ActionFrame ()
move dir = do
pl <- gets splayer
targeting <- gets (ctargeting . scursor)
if targeting /= TgtOff
then do
frs <- moveCursor dir 1
modify (\ s -> s {snoTime = True})
return frs
else
inFrame $ moveOrAttack True pl dir
ifRunning :: ((Vector, Int) -> Action a) -> Action a -> Action a
ifRunning t e = do
ad <- gets (bdir . getPlayerBody)
maybe e t ad
guessBump :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Action ()
guessBump cotile F.Openable t | Tile.hasFeature cotile F.Closable t =
abortWith "already open"
guessBump _ F.Openable _ =
abortWith "not a door"
guessBump cotile F.Closable t | Tile.hasFeature cotile F.Openable t =
abortWith "already closed"
guessBump _ F.Closable _ =
abortWith "not a door"
guessBump cotile F.Ascendable t | Tile.hasFeature cotile F.Descendable t =
abortWith "the way goes down, not up"
guessBump _ F.Ascendable _ =
abortWith "no stairs up"
guessBump cotile F.Descendable t | Tile.hasFeature cotile F.Ascendable t =
abortWith "the way goes up, not down"
guessBump _ F.Descendable _ =
abortWith "no stairs down"
guessBump _ _ _ = neverMind True
bumpTile :: Point -> F.Feature -> Action ()
bumpTile dloc feat = do
Kind.COps{cotile} <- getCOps
lvl <- gets slevel
let t = lvl `at` dloc
if Tile.hasFeature cotile feat t
then triggerTile dloc
else guessBump cotile feat t
triggerTile :: Point -> Action ()
triggerTile dloc = do
Kind.COps{cotile=Kind.Ops{okind, opick}} <- getCOps
lvl <- gets slevel
let f (F.Cause effect) = do
pl <- gets splayer
void $ effectToAction effect 0 pl pl 0
return ()
f (F.ChangeTo group) = do
Level{lactor} <- gets slevel
case lvl `atI` dloc of
[] -> if unoccupied (IM.elems lactor) dloc
then do
newTileId <- rndToAction $ opick group (const True)
let adj = (Kind.// [(dloc, newTileId)])
modify (updateLevel (updateLMap adj))
else abortWith "blocked"
_ : _ -> abortWith "jammed"
f _ = return ()
mapM_ f $ TileKind.tfeature $ okind $ lvl `at` dloc
playerTriggerDir :: F.Feature -> Verb -> Action ()
playerTriggerDir feat verb = do
let keys = zip K.dirAllMoveKey $ repeat K.NoModifier
e <- displayChoiceUI ("What to " ++ verb ++ "? [movement key") [] keys
lxsize <- gets (lxsize . slevel)
K.handleDir lxsize e (playerBumpDir feat) (neverMind True)
playerBumpDir :: F.Feature -> Vector -> Action ()
playerBumpDir feat dir = do
pl <- gets splayer
body <- gets (getActor pl)
let dloc = bloc body `shift` dir
bumpTile dloc feat
playerTriggerTile :: F.Feature -> Action ()
playerTriggerTile feat = do
ploc <- gets (bloc . getPlayerBody)
bumpTile ploc feat
actorOpenDoor :: ActorId -> Vector -> Action ()
actorOpenDoor actor dir = do
Kind.COps{ cotile
, coitem
, coactor=Kind.Ops{okind}
} <- getCOps
lvl <- gets slevel
pl <- gets splayer
body <- gets (getActor actor)
bitems <- gets (getActorItem actor)
let dloc = shift (bloc body) dir
t = lvl `at` dloc
isPlayer = actor == pl
isVerbose = isPlayer
iq = aiq $ okind $ bkind body
openPower = timeScale timeTurn $
if isPlayer
then 0
else case strongestSearch coitem bitems of
Just i -> iq + jpower i
Nothing -> iq
unless (openable cotile lvl openPower dloc) $ neverMind isVerbose
if Tile.hasFeature cotile F.Closable t
then abortIfWith isVerbose "already open"
else if not (Tile.hasFeature cotile F.Closable t ||
Tile.hasFeature cotile F.Openable t ||
Tile.hasFeature cotile F.Hidden t)
then neverMind isVerbose
else triggerTile dloc
tgtAscend :: Int -> ActionFrame ()
tgtAscend k = do
Kind.COps{cotile} <- getCOps
cursor <- gets scursor
targeting <- gets (ctargeting . scursor)
slid <- gets slid
lvl <- gets slevel
st <- get
dungeon <- gets sdungeon
let loc = clocation cursor
tile = lvl `at` loc
rightStairs =
k == 1 && Tile.hasFeature cotile (F.Cause Effect.Ascend) tile ||
k == 1 && Tile.hasFeature cotile (F.Cause Effect.Descend) tile
if rightStairs
then case whereTo st k of
Nothing ->
abortWith "no more levels in this direction"
Just (nln, nloc) ->
assert (nln /= slid `blame` (nln, "stairs looped")) $ do
switchLevel nln
lvl2 <- gets slevel
let upd cur =
let clocation =
if Tile.hasFeature cotile F.Exit (lvl2 `rememberAt` nloc)
then nloc
else loc
in cur { clocation, clocLn = nln }
modify (updateCursor upd)
else do
let n = Dungeon.levelNumber slid
depth = Dungeon.depth dungeon
nln = Dungeon.levelDefault $ min depth $ max 1 $ n k
when (nln == slid) $ abortWith "no more levels in this direction"
switchLevel nln
let upd cur = cur {clocLn = nln}
modify (updateCursor upd)
when (targeting == TgtOff) $ do
let upd cur = cur {ctargeting = TgtExplicit}
modify (updateCursor upd)
doLook
cycleHero :: Action ()
cycleHero = do
pl <- gets splayer
s <- get
let hs = map (tryFindHeroK s) [0..9]
i = fromMaybe (1) $ L.findIndex (== Just pl) hs
(lt, gt) = (take i hs, drop (i + 1) hs)
case L.filter (flip memActor s) $ catMaybes gt ++ catMaybes lt of
[] -> abortWith "Cannot select any other hero on this level."
ni : _ -> selectPlayer ni
>>= assert `trueM` (pl, ni, "hero duplicated")
search :: Action ()
search = do
Kind.COps{coitem, cotile} <- getCOps
lvl <- gets slevel
le <- gets (lsecret . slevel)
lxsize <- gets (lxsize . slevel)
ploc <- gets (bloc . getPlayerBody)
pitems <- gets getPlayerItem
let delta = timeScale timeTurn $
case strongestSearch coitem pitems of
Just i -> 1 + jpower i
Nothing -> 1
searchTile sle mv =
let loc = shift ploc mv
t = lvl `at` loc
k = timeAdd (le IM.! loc) $ timeNegate delta
in if Tile.hasFeature cotile F.Hidden t
then if k > timeZero
then IM.insert loc k sle
else IM.delete loc sle
else sle
leNew = L.foldl' searchTile le (moves lxsize)
modify (updateLevel (\ l -> l {lsecret = leNew}))
lvlNew <- gets slevel
let triggerHidden mv = do
let dloc = shift ploc mv
t = lvlNew `at` dloc
when (Tile.hasFeature cotile F.Hidden t && IM.notMember dloc leNew) $
triggerTile dloc
mapM_ triggerHidden (moves lxsize)
moveOrAttack :: Bool
-> ActorId
-> Vector
-> Action ()
moveOrAttack allowAttacks actor dir = do
cops@Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getCOps
state <- get
pl <- gets splayer
lvl <- gets slevel
sm <- gets (getActor actor)
let sloc = bloc sm
tloc = sloc `shift` dir
tgt <- gets (locToActor tloc)
case tgt of
Just target
| allowAttacks ->
actorAttackActor actor target
| accessible cops lvl sloc tloc -> do
when (actor == pl) $
msgAdd $ lookAt cops False True state lvl tloc ""
actorRunActor actor target
| otherwise -> abortWith "blocked"
Nothing
| accessible cops lvl sloc tloc -> do
updateAnyActor actor $ \ body -> body {bloc = tloc}
when (actor == pl) $
msgAdd $ lookAt cops False True state lvl tloc ""
| allowAttacks && actor == pl
&& Tile.canBeHidden cotile (okind $ lvl `rememberAt` tloc) -> do
msgAdd "You search your surroundings."
search
| otherwise ->
actorOpenDoor actor dir
actorAttackActor :: ActorId -> ActorId -> Action ()
actorAttackActor source target = do
sm <- gets (getActor source)
tm <- gets (getActor target)
if bparty sm == heroParty && bparty tm == heroParty
then do
selectPlayer target
>>= assert `trueM` (source, target, "player bumps into himself")
modify (\ s -> s {snoTime = True})
else do
cops@Kind.COps{coactor, coitem=coitem@Kind.Ops{opick, okind}} <- getCOps
state <- get
per <- getPerception
bitems <- gets (getActorItem source)
let h2hGroup = if isAHero state source then "unarmed" else "monstrous"
h2hKind <- rndToAction $ opick h2hGroup (const True)
let h2hItem = Item h2hKind 0 Nothing 1
sloc = bloc sm
(stack, tell, verbosity, verb) =
if bparty sm `elem` allProjectiles
then assert (length bitems == 1) $
(head bitems, False, 10, "hit")
else case strongestSword cops bitems of
Nothing -> (h2hItem, False, 0,
iverbApply $ okind $ h2hKind)
Just w -> (w, True, 0,
iverbApply $ okind $ jkind w)
single = stack { jcount = 1 }
msg = actorVerbActor coactor sm verb tm $
if tell
then "with " ++ objectItem coitem state single
else ""
visible = sloc `IS.member` totalVisible per
when visible $ msgAdd msg
itemEffectAction verbosity source target single
actorRunActor :: ActorId -> ActorId -> Action ()
actorRunActor source target = do
pl <- gets splayer
sm <- gets (getActor source)
tm <- gets (getActor target)
let sloc = bloc sm
tloc = bloc tm
updateAnyActor source $ \ m -> m { bloc = tloc }
updateAnyActor target $ \ m -> m { bloc = sloc }
cops@Kind.COps{coactor} <- getCOps
per <- getPerception
let visible = sloc `IS.member` totalVisible per ||
tloc `IS.member` totalVisible per
msg = actorVerbActor coactor sm "displace" tm ""
when visible $ msgAdd msg
diary <- getDiary
s <- get
let locs = [tloc, sloc]
anim = map (IM.fromList . zip locs)
[ [Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) '.',
Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'o']
, [Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) 'd',
Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'p']
, [Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'p',
Color.AttrChar (Color.Attr Color.BrMagenta Color.defBG) 'd']
, [Color.AttrChar (Color.Attr Color.Magenta Color.defBG) 'o']
, []
]
animFrs = animate s diary cops per anim
when visible $ mapM_ displayFramePush $ Nothing : animFrs
if source == pl
then stopRunning
else void $ focusIfOurs target
rollMonster :: Kind.COps -> Perception -> State -> Rnd State
rollMonster Kind.COps{cotile, coactor=Kind.Ops{opick, okind}} per state = do
let lvl@Level{lactor} = slevel state
ms = hostileList state
hs = heroList state
isLit = Tile.isLit cotile
rc <- monsterGenChance (Dungeon.levelNumber $ slid state) (L.length ms)
if not rc
then return state
else do
let distantAtLeast d =
\ l _ -> L.all (\ h -> chessDist (lxsize lvl) (bloc h) l > d) hs
loc <-
findLocTry 20 (lmap lvl)
[ \ _ t -> not (isLit t)
, distantAtLeast 30
, distantAtLeast 20
, \ l t -> not (isLit t) || distantAtLeast 20 l t
, distantAtLeast 10
, \ l _ -> not $ l `IS.member` totalVisible per
, distantAtLeast 5
, \ l t -> Tile.hasFeature cotile F.Walkable t
&& unoccupied (IM.elems lactor) l
]
mk <- opick "monster" (const True)
hp <- rollDice $ ahp $ okind mk
return $ addMonster cotile mk hp loc state
generateMonster :: Action ()
generateMonster = do
cops <- getCOps
state <- get
per <- getPerception
nstate <- rndToAction $ rollMonster cops per state
srandom <- gets srandom
put $ nstate {srandom}
regenerateLevelHP :: Action ()
regenerateLevelHP = do
Kind.COps{ coitem
, coactor=coactor@Kind.Ops{okind}
} <- getCOps
time <- gets stime
let upd itemIM a m =
let ak = okind $ bkind m
bitems = fromMaybe [] $ IM.lookup a itemIM
regen = max 1 $
aregen ak `div`
case strongestRegen coitem bitems of
Just i -> 5 * jpower i
Nothing -> 1
in if (time `timeFit` timeTurn) `mod` regen /= 0
then m
else addHp coactor 1 m
hi <- gets (linv . slevel)
modify (updateLevel (updateActorDict (IM.mapWithKey (upd hi))))
displayHelp :: ActionFrame ()
displayHelp = do
keyb <- getBinding
displayOverlays "Basic keys. [press SPACE or ESC]" $ keyHelp keyb
displayHistory :: ActionFrame ()
displayHistory = do
Diary{shistory} <- getDiary
time <- gets stime
lysize <- gets (lysize . slevel)
let turn = show $ time `timeFit` timeTurn
msg = "Your adventuring lasts " ++ turn
++ " half-second turns. Past messages:"
displayOverlays msg $ splitOverlay lysize $ renderHistory shistory
dumpConfig :: Action ()
dumpConfig = do
config <- gets sconfig
let fn = "config.dump"
msg = "Current configuration dumped to file " ++ fn ++ "."
dumpCfg fn config
abortWith msg
redraw :: Action ()
redraw = return ()
addSmell :: Action ()
addSmell = do
s <- get
pl <- gets splayer
let time = stime s
ploc = bloc (getPlayerBody s)
upd = IM.insert ploc $ timeAdd time $ smellTimeout s
when (isAHero s pl) $
modify $ updateLevel $ updateSmell upd