module Game.LambdaHack.ItemAction 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.Grammar
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 Game.LambdaHack.EffectAction
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Content.ItemKind
import qualified Game.LambdaHack.Feature as F
import qualified Game.LambdaHack.Tile as Tile
inventory :: Action ()
inventory = do
items <- gets getPlayerItem
if L.null items
then abortWith "Not carrying anything."
else do
displayItems "Carrying:" True items
abort
getGroupItem :: [Item]
-> Object
-> [Char]
-> String
-> String
-> Action (Maybe Item)
getGroupItem is object syms prompt packName = do
Kind.Ops{osymbol} <- contentf Kind.coitem
let choice i = osymbol (jkind i) `elem` syms
header = capitalize $ suffixS object
getItem prompt choice header is packName
applyGroupItem :: ActorId
-> Verb
-> Item
-> Action ()
applyGroupItem actor verb item = do
cops <- contentOps
state <- get
body <- gets (getActor actor)
per <- currentPerception
let consumed = item { jcount = 1 }
msg = actorVerbItemExtra cops state body verb consumed ""
loc = bloc body
removeFromInventory actor consumed loc
when (loc `IS.member` totalVisible per) $ msgAdd msg
itemEffectAction 5 actor actor consumed
advanceTime actor
playerApplyGroupItem :: Verb -> Object -> [Char] -> Action ()
playerApplyGroupItem verb object syms = do
Kind.Ops{okind} <- contentf Kind.coitem
is <- gets getPlayerItem
iOpt <- getGroupItem is object syms
("What to " ++ verb ++ "?") "in inventory"
pl <- gets splayer
case iOpt of
Just i -> applyGroupItem pl (iverbApply $ okind $ jkind i) i
Nothing -> neverMind True
projectGroupItem :: ActorId
-> Point
-> Verb
-> Item
-> Action ()
projectGroupItem source loc verb item = do
cops@Kind.COps{coactor, cotile} <- contentOps
state <- get
sm <- gets (getActor source)
per <- currentPerception
lvl <- gets slevel
let
locWalkable = Tile.hasFeature cotile F.Walkable (lvl `at` loc)
consumed = item { jcount = 1 }
sloc = bloc sm
subject =
if sloc `IS.member` totalVisible per
then sm
else template (heroKindId coactor)
Nothing (Just "somebody") 99 sloc
msg = actorVerbItemExtra cops state subject verb consumed ""
removeFromInventory source consumed sloc
case locToActor loc state of
Just ta -> do
when (sloc `IS.member` totalVisible per || isAHero ta) $ msgAdd msg
b <- itemEffectAction 10 source ta consumed
unless b $ modify (updateLevel (dropItemsAt [consumed] loc))
Nothing | locWalkable -> do
when (sloc `IS.member` totalVisible per) $ msgAdd msg
modify (updateLevel (dropItemsAt [consumed] loc))
_ -> abortWith "blocked"
advanceTime source
playerProjectGroupItem :: Verb -> Object -> [Char] -> Action ()
playerProjectGroupItem verb object syms = do
ms <- gets (lmonsters . slevel)
lxsize <- gets (lxsize . slevel)
ploc <- gets (bloc . getPlayerBody)
if L.any (adjacent lxsize ploc) (L.map bloc $ IM.elems ms)
then abortWith "You can't aim in melee."
else playerProjectGI verb object syms
playerProjectGI :: Verb -> Object -> [Char] -> Action ()
playerProjectGI verb object syms = do
state <- get
pl <- gets splayer
ploc <- gets (bloc . getPlayerBody)
per <- currentPerception
let retarget msg = do
msgAdd msg
updatePlayerBody (\ p -> p { btarget = TCursor })
let upd cursor = cursor {clocation=ploc}
modify (updateCursor upd)
targetMonster TgtAuto
case targetToLoc (totalVisible per) state of
Just loc | actorReachesLoc pl loc per (Just pl) -> do
Kind.Ops{okind} <- contentf Kind.coitem
is <- gets getPlayerItem
iOpt <- getGroupItem is object syms
("What to " ++ verb ++ "?") "in inventory"
targeting <- gets (ctargeting . scursor)
when (targeting == TgtAuto) $ endTargeting True
case iOpt of
Just i -> projectGroupItem pl loc (iverbProject $ okind $ jkind i) i
Nothing -> neverMind True
Just _ -> retarget "Last target unreachable."
Nothing -> retarget "Last target invalid."
targetMonster :: TgtMode -> Action ()
targetMonster tgtMode = 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 /= TgtOff -> n
TEnemy (AMonster n) _ -> n 1
_ -> 1
dms = case pl of
AMonster n -> IM.delete n ms
AHero _ -> ms
(lt, gt) = IM.split i dms
gtlt = IM.assocs gt ++ IM.assocs lt
seen (_, m) =
let mloc = bloc m
in mloc `IS.member` totalVisible per
&& actorReachesLoc pl mloc per (Just pl)
lf = L.filter seen gtlt
tgt = case lf of
[] -> target
(na, nm) : _ -> TEnemy (AMonster na) (bloc nm)
updatePlayerBody (\ p -> p { btarget = tgt })
setCursor tgtMode
targetFloor :: TgtMode -> Action ()
targetFloor tgtMode = do
ploc <- gets (bloc . getPlayerBody)
target <- gets (btarget . getPlayerBody)
targeting <- gets (ctargeting . scursor)
let tgt = case target of
_ | targeting /= TgtOff -> TLoc ploc
TEnemy _ _ -> TCursor
t -> t
updatePlayerBody (\ p -> p { btarget = tgt })
setCursor tgtMode
setCursor :: TgtMode -> Action ()
setCursor tgtMode = assert (tgtMode /= TgtOff) $ do
state <- get
per <- currentPerception
ploc <- gets (bloc . getPlayerBody)
clocLn <- gets slid
let upd cursor@Cursor{ctargeting} =
let clocation = fromMaybe ploc (targetToLoc (totalVisible per) state)
newTgtMode = if ctargeting == TgtOff then tgtMode else ctargeting
in cursor { ctargeting = newTgtMode, clocation, clocLn }
modify (updateCursor upd)
doLook
endTargeting :: Bool -> Action ()
endTargeting accept = do
returnLn <- gets (creturnLn . scursor)
target <- gets (btarget . getPlayerBody)
per <- currentPerception
cloc <- gets (clocation . scursor)
ms <- gets (lmonsters . slevel)
modify (\ state -> state {slid = returnLn})
modify (updateCursor (\ c -> c { ctargeting = TgtOff }))
case target of
TEnemy _ _ -> do
let canSee = IS.member cloc (totalVisible per)
when (accept && canSee) $
case L.find (\ (_im, m) -> bloc m == cloc) (IM.assocs ms) of
Just (im, m) ->
let tgt = TEnemy (AMonster im) (bloc m)
in updatePlayerBody (\ p -> p { btarget = tgt })
Nothing -> return ()
_ ->
if accept
then updatePlayerBody (\ p -> p { btarget = TLoc cloc })
else updatePlayerBody (\ p -> p { btarget = TCursor })
endTargetingMsg
endTargetingMsg :: Action ()
endTargetingMsg = do
cops <- contentf Kind.coactor
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 cops $ getActor a state
else "a fear of the past"
TLoc loc -> "location " ++ showPoint lxsize loc
TCursor -> "current cursor position continuously"
msgAdd $ actorVerbExtra cops pbody verb targetMsg
cancelCurrent :: Action ()
cancelCurrent = do
targeting <- gets (ctargeting . scursor)
if targeting /= TgtOff
then endTargeting False
else abortWith "Press Q to quit."
acceptCurrent :: Action () -> Action ()
acceptCurrent h = do
targeting <- gets (ctargeting . scursor)
if targeting /= TgtOff
then endTargeting True
else h
dropItem :: Action ()
dropItem = do
cops <- contentOps
pl <- gets splayer
state <- get
pbody <- gets getPlayerBody
ploc <- gets (bloc . getPlayerBody)
items <- gets getPlayerItem
iOpt <- getAnyItem "What to drop?" items "inventory"
case iOpt of
Just stack -> do
let i = stack { jcount = 1 }
removeOnlyFromInventory pl i (bloc pbody)
msgAdd (actorVerbItemExtra cops state pbody "drop" i "")
modify (updateLevel (dropItemsAt [i] ploc))
Nothing -> neverMind True
playerAdvanceTime
removeOnlyFromInventory :: ActorId -> Item -> Point -> Action ()
removeOnlyFromInventory actor i _loc =
modify (updateAnyActorItem actor (removeItemByLetter i))
removeFromInventory :: ActorId -> Item -> Point -> Action ()
removeFromInventory actor i loc = do
b <- removeFromLoc i loc
unless b $
modify (updateAnyActorItem actor (removeItemByLetter i))
removeFromLoc :: Item -> Point -> Action Bool
removeFromLoc i loc = do
lvl <- gets slevel
if not $ L.any (equalItemIdentity i) (lvl `atI` loc)
then return False
else
modify (updateLevel (updateIMap adj)) >>
return True
where
rib Nothing = assert `failure` (i, loc)
rib (Just (is, irs)) =
case (removeItemByIdentity i is, irs) of
([], []) -> Nothing
iss -> Just iss
adj = IM.alter rib loc
actorPickupItem :: ActorId -> Action ()
actorPickupItem actor = do
cops@Kind.COps{coitem} <- contentOps
state <- get
pl <- gets splayer
per <- currentPerception
lvl <- gets slevel
body <- gets (getActor actor)
bitems <- gets (getActorItem actor)
let loc = bloc body
perceived = loc `IS.member` totalVisible per
isPlayer = actor == pl
case lvl `atI` loc of
[] -> abortIfWith isPlayer "nothing here"
i:is ->
case assignLetter (jletter i) (bletter body) bitems of
Just l -> do
let (ni, nitems) = joinItem (i { jletter = Just l }) bitems
if isPlayer
then msgAdd (letterLabel (jletter ni)
++ objectItem coitem state ni)
else when perceived $
msgAdd $
actorVerbExtraItemExtra cops state body "pick" "up" i ""
removeFromLoc i loc
>>= assert `trueM` (i, is, loc, "item is stuck")
updateAnyActor actor $ \ m ->
m { bletter = maxLetter l (bletter body) }
modify (updateAnyActorItem actor (const nitems))
Nothing -> abortIfWith isPlayer "cannot carry any more"
advanceTime actor
pickupItem :: Action ()
pickupItem = do
pl <- gets splayer
actorPickupItem pl
getAnyItem :: String
-> [Item]
-> String
-> Action (Maybe Item)
getAnyItem prompt = getItem prompt (const True) "Objects"
data ItemDialogState = INone | ISuitable | IAll deriving Eq
getItem :: String
-> (Item -> Bool)
-> String
-> [Item]
-> String
-> Action (Maybe Item)
getItem prompt p ptext is0 isn = do
lvl <- gets slevel
body <- gets getPlayerBody
let loc = bloc body
tis = lvl `atI` loc
floorMsg = if L.null tis then "" else " -,"
is = L.filter p is0
cmpItemLM i1 i2 = cmpLetterMaybe (jletter i1) (jletter i2)
choice ims =
if L.null ims
then "[?," ++ floorMsg ++ " ESC]"
else let mls = mapMaybe jletter ims
r = letterRange mls
ret = maybe "" (\ l -> ['(', l, ')']) $
jletter $ L.maximumBy cmpItemLM ims
in "[" ++ r ++ ", ?," ++ floorMsg ++ " RET" ++ ret ++ ", ESC]"
ask = do
when (L.null is0 && L.null tis) $
abortWith "Not carrying anything."
msgReset (prompt ++ " " ++ choice is)
displayAll
session nextCommand >>= perform ISuitable
perform itemDialogState command = do
let ims = if itemDialogState == INone then is0 else is
msgClear
case command of
K.Char '?' | itemDialogState == ISuitable -> do
b <- displayItems
(ptext ++ " " ++ isn ++ ". " ++ choice is) True is
if b then session (getOptionalConfirm (const ask)
(perform IAll))
else ask
K.Char '?' | itemDialogState == IAll -> do
b <- displayItems
("Objects " ++ isn ++ ". " ++ choice is0) True is0
if b then session (getOptionalConfirm (const ask)
(perform INone))
else ask
K.Char '?' | itemDialogState == INone -> ask
K.Char '-' ->
case tis of
[] -> return Nothing
i:_rs ->
return $ Just i
K.Char l ->
return (L.find (maybe False (== l) . jletter) ims)
K.Return ->
if L.null ims
then return Nothing
else return $ Just $ L.maximumBy cmpItemLM ims
_ -> return Nothing
ask