module Game.LambdaHack.ActorState where
import Control.Monad
import qualified Data.List as L
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import Data.Maybe
import qualified Data.Char as Char
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Point
import Game.LambdaHack.Vector
import Game.LambdaHack.Actor
import Game.LambdaHack.Level
import Game.LambdaHack.Dungeon
import Game.LambdaHack.State
import Game.LambdaHack.Grammar
import Game.LambdaHack.Item
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.TileKind
import Game.LambdaHack.Content.ItemKind
import qualified Game.LambdaHack.Config as Config
import qualified Game.LambdaHack.Tile as Tile
import qualified Game.LambdaHack.Kind as Kind
import qualified Game.LambdaHack.Feature as F
import Game.LambdaHack.Time
isAHero :: State -> ActorId -> Bool
isAHero s a =
let (_, actor, _) = findActorAnyLevel a s
in bparty actor == heroParty
isAMonster :: State -> ActorId -> Bool
isAMonster s a =
let (_, actor, _) = findActorAnyLevel a s
in bparty actor == enemyParty
smellTimeout :: State -> Time
smellTimeout s =
let smellTurns = Config.get (sconfig s) "monsters" "smellTimeout"
in timeScale timeTurn smellTurns
findActorAnyLevel :: ActorId -> State -> (LevelId, Actor, [Item])
findActorAnyLevel actor State{slid, sdungeon} =
let chk (ln, lvl) =
let (m, mi) = (IM.lookup actor (lactor lvl),
IM.lookup actor (linv lvl))
in fmap (\ a -> (ln, a, fromMaybe [] mi)) m
in case mapMaybe chk (currentFirst slid sdungeon) of
[] -> assert `failure` actor
res : _ -> res
tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor)
tryFindActor State{slid, sdungeon} p =
let chk (_ln, lvl) = L.find (p . snd) $ IM.assocs $ lactor lvl
in case mapMaybe chk (currentFirst slid sdungeon) of
[] -> Nothing
res : _ -> Just res
getPlayerBody :: State -> Actor
getPlayerBody s@State{splayer} =
let (_, actor, _) = findActorAnyLevel splayer s
in actor
getPlayerItem :: State -> [Item]
getPlayerItem s@State{splayer} =
let (_, _, items) = findActorAnyLevel splayer s
in items
allHeroesAnyLevel :: State -> [ActorId]
allHeroesAnyLevel State{slid, sdungeon} =
let one (_, lvl) = L.map fst (heroAssocs lvl)
in L.concatMap one (currentFirst slid sdungeon)
updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State
updateAnyActorBody actor f state =
let (ln, _, _) = findActorAnyLevel actor state
in updateAnyLevel (updateActorDict $ IM.adjust f actor) ln state
updateAnyActorItem :: ActorId -> ([Item] -> [Item]) -> State -> State
updateAnyActorItem actor f state =
let (ln, _, _) = findActorAnyLevel actor state
g Nothing = Just $ f []
g (Just is) = Just $ f is
in updateAnyLevel (updateInv $ IM.alter g actor) ln state
updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State
updateAnyLevel f ln s@State{slid, sdungeon}
| ln == slid = updateLevel f s
| otherwise = updateDungeon (const $ adjust f ln sdungeon) s
targetToLoc :: IS.IntSet -> State -> Point -> Maybe Point
targetToLoc visible s@State{slid, scursor} aloc =
case btarget (getPlayerBody s) of
TLoc loc -> Just loc
TPath [] -> Nothing
TPath (dir:_) -> Just $ shift aloc dir
TCursor ->
if slid == clocLn scursor
then Just $ clocation scursor
else Nothing
TEnemy a _ll -> do
guard $ memActor a s
let loc = bloc (getActor a s)
guard $ IS.member loc visible
return loc
memActor :: ActorId -> State -> Bool
memActor a state = IM.member a (lactor (slevel state))
getActor :: ActorId -> State -> Actor
getActor a state = lactor (slevel state) IM.! a
getActorItem :: ActorId -> State -> [Item]
getActorItem a state = fromMaybe [] $ IM.lookup a (linv (slevel state))
deleteActor :: ActorId -> State -> State
deleteActor a =
updateLevel (updateActorDict (IM.delete a) . updateInv (IM.delete a))
insertActor :: ActorId -> Actor -> State -> State
insertActor a m = updateLevel (updateActorDict (IM.insert a m))
deletePlayer :: State -> State
deletePlayer s@State{splayer} = deleteActor splayer s
heroAssocs, hostileAssocs, dangerousAssocs, friendlyAssocs, allButHeroesAssocs
:: Level -> [(ActorId, Actor)]
heroAssocs lvl =
filter (\ (_, m) -> bparty m == heroParty) $ IM.toList $ lactor lvl
hostileAssocs lvl =
filter (\ (_, m) -> bparty m `elem` [enemyParty, animalParty]) $
IM.toList $ lactor lvl
dangerousAssocs lvl =
filter (\ (_, m) -> bparty m `elem`
[enemyParty, animalParty,
enemyProjectiles, animalProjectiles]) $
IM.toList $ lactor lvl
friendlyAssocs lvl =
filter (\ (_, m) -> bparty m `elem` [heroParty, heroProjectiles]) $
IM.toList $ lactor lvl
allButHeroesAssocs lvl =
filter (\ (_, m) -> bparty m `elem`
[heroProjectiles, enemyParty, animalParty,
enemyProjectiles, animalProjectiles]) $
IM.toList $ lactor lvl
heroList, hostileList, dangerousList, friendlyList :: State -> [Actor]
heroList state =
filter (\ m -> bparty m == heroParty) $ IM.elems $ lactor $ slevel state
hostileList state =
filter (\ m -> bparty m `elem` [enemyParty, animalParty]) $
IM.elems $ lactor $ slevel state
dangerousList state =
filter (\ m -> bparty m `elem`
[enemyParty, animalParty,
enemyProjectiles, animalProjectiles]) $
IM.elems $ lactor $ slevel state
friendlyList state =
filter (\ m -> bparty m `elem` [heroParty, heroProjectiles]) $
IM.elems $ lactor $ slevel state
locToActor :: Point -> State -> Maybe ActorId
locToActor loc state =
let l = locToActors loc state
in assert (L.length l <= 1 `blame` l) $
listToMaybe l
locToActors :: Point -> State -> [ActorId]
locToActors loc state =
let l = IM.assocs $ lactor $ slevel state
im = L.filter (\ (_i, m) -> bloc m == loc) l
in fmap fst im
nearbyFreeLoc :: Kind.Ops TileKind -> Point -> State -> Point
nearbyFreeLoc cotile start state =
let lvl@Level{lxsize, lysize, lactor} = slevel state
locs = start : L.nub (concatMap (vicinity lxsize lysize) locs)
good loc = Tile.hasFeature cotile F.Walkable (lvl `at` loc)
&& unoccupied (IM.elems lactor) loc
in fromMaybe (assert `failure` "too crowded map") $ L.find good locs
calculateTotal :: Kind.Ops ItemKind -> State -> ([Item], Int)
calculateTotal coitem s =
let ha = heroAssocs $ slevel s
heroInv = L.concat $ catMaybes $
L.map ( \ (k, _) -> IM.lookup k $ linv $ slevel s) ha
in (heroInv, L.sum $ L.map (itemPrice coitem) heroInv)
tryFindHeroK :: State -> Int -> Maybe ActorId
tryFindHeroK s k =
let c | k == 0 = '@'
| k > 0 && k < 10 = Char.intToDigit k
| otherwise = assert `failure` k
in fmap fst $ tryFindActor s ((== Just c) . bsymbol)
addHero :: Kind.COps -> Point -> State -> State
addHero Kind.COps{coactor, cotile} ploc state@State{scounter} =
let config = sconfig state
bHP = Config.get config "heroes" "baseHP"
loc = nearbyFreeLoc cotile ploc state
freeHeroK = L.elemIndex Nothing $ map (tryFindHeroK state) [0..9]
n = fromMaybe 10 freeHeroK
symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n
name = findHeroName config n
startHP = bHP `div` min 5 (n + 1)
m = template (heroKindId coactor) (Just symbol) (Just name)
startHP loc (stime state) heroParty
cstate = state { scounter = scounter + 1 }
in updateLevel (updateActorDict (IM.insert scounter m)) cstate
initialHeroes :: Kind.COps -> Point -> State -> State
initialHeroes cops ploc state =
let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes"
in iterate (addHero cops ploc) state !! k
addMonster :: Kind.Ops TileKind -> Kind.Id ActorKind -> Int -> Point -> State
-> State
addMonster cotile mk hp ploc state@State{scounter} = do
let loc = nearbyFreeLoc cotile ploc state
m = template mk Nothing Nothing hp loc (stime state) enemyParty
cstate = state {scounter = scounter + 1}
updateLevel (updateActorDict (IM.insert scounter m)) cstate
addProjectile :: Kind.COps -> Item -> Point -> PartyId -> [Point] -> Time
-> State -> State
addProjectile Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}}
item loc bparty path btime state@State{scounter} =
let ik = okind (jkind item)
object = objectItem coitem state item
name = "a flying " ++ unwords (tail (words object))
speed = speedFromWeight (iweight ik) (itoThrow ik)
range = rangeFromSpeed speed
dirPath = take range $ displacePath path
m = Actor
{ bkind = projectileKindId coactor
, bsymbol = Nothing
, bname = Just name
, bcolor = Nothing
, bspeed = Just speed
, bhp = 0
, bdir = Nothing
, btarget = TPath dirPath
, bloc = loc
, bletter = 'a'
, btime
, bparty
}
cstate = state { scounter = scounter + 1 }
upd = updateActorDict (IM.insert scounter m)
. updateInv (IM.insert scounter [item])
in updateLevel upd cstate