module Game.LambdaHack.Perception
( DungeonPerception, Perception
, totalVisible, debugTotalReachable, dungeonPerception
, actorReachesLoc, actorReachesActor, actorSeesActor
) where
import qualified Data.IntSet as IS
import qualified Data.List as L
import qualified Data.IntMap as IM
import Data.Maybe
import Control.Monad
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Point
import Game.LambdaHack.State
import Game.LambdaHack.Level
import Game.LambdaHack.Actor
import Game.LambdaHack.ActorState
import Game.LambdaHack.Dungeon
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.FOV
import qualified Game.LambdaHack.Config as Config
import qualified Game.LambdaHack.Tile as Tile
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Content.TileKind
newtype PerceptionReachable = PerceptionReachable
{ preachable :: IS.IntSet
}
newtype PerceptionVisible = PerceptionVisible
{ pvisible :: IS.IntSet
}
type DungeonPerception = [(LevelId, Perception)]
data Perception = Perception
{ pplayer :: Maybe PerceptionReachable
, pheroes :: IM.IntMap PerceptionReachable
, ptotal :: PerceptionVisible
}
totalVisible :: Perception -> IS.IntSet
totalVisible = pvisible . ptotal
debugTotalReachable :: Perception -> IS.IntSet
debugTotalReachable per =
let lpers = maybeToList (pplayer per) ++ IM.elems (pheroes per)
in IS.unions (map preachable lpers)
actorReachesLoc :: ActorId -> Point -> Perception -> Maybe ActorId -> Bool
actorReachesLoc actor loc per pl =
let tryHero = do
hper <- IM.lookup actor (pheroes per)
return $ loc `IS.member` preachable hper
tryPl = do
guard $ Just actor == pl
pper <- pplayer per
return $ loc `IS.member` preachable pper
tryAny = tryHero `mplus` tryPl
in fromMaybe False tryAny
actorReachesActor :: ActorId -> ActorId -> Point -> Point
-> Perception -> Maybe ActorId
-> Bool
actorReachesActor actor1 actor2 loc1 loc2 per pl =
actorReachesLoc actor1 loc2 per pl ||
actorReachesLoc actor2 loc1 per pl
monsterSeesHero :: Kind.Ops TileKind -> Perception -> Level
-> ActorId -> ActorId -> Point -> Point -> Bool
monsterSeesHero cotile per lvl _source target sloc tloc =
let rempty = PerceptionReachable IS.empty
reachable@PerceptionReachable{preachable} =
fromMaybe rempty $ IM.lookup target $ pheroes per
in sloc `IS.member` preachable
&& isVisible cotile reachable lvl IS.empty tloc
actorSeesActor :: Kind.Ops TileKind -> Perception -> Level
-> ActorId -> ActorId -> Point -> Point -> ActorId -> Bool
actorSeesActor cotile per lvl source target sloc tloc pl =
let heroReaches = actorReachesLoc source tloc per (Just pl)
visByHeroes = tloc `IS.member` totalVisible per
monsterSees = monsterSeesHero cotile per lvl source target sloc tloc
in heroReaches && visByHeroes || monsterSees
dungeonPerception :: Kind.COps -> State -> DungeonPerception
dungeonPerception cops s@State{slid, sdungeon} =
let lvlPer (ln, lvl) = (ln, levelPerception cops s lvl)
in map lvlPer $ currentFirst slid sdungeon
levelPerception :: Kind.COps -> State -> Level -> Perception
levelPerception cops@Kind.COps{cotile}
state@State{ splayer
, sconfig
, sfaction
, sdebug = DebugMode{smarkVision}
}
lvl@Level{lactor} =
let mode = Config.get sconfig "engine" "fovMode"
radius = let r = Config.get sconfig "engine" "fovRadius"
in if r < 1
then assert `failure`
"FOV radius is " ++ show r ++ ", should be >= 1"
else r
mLocPer =
if not (isAHero state splayer) && IM.member splayer lactor
then let m = getPlayerBody state
in Just (bloc m,
computeReachable cops radius mode smarkVision m lvl)
else Nothing
(mLoc, mPer) = (fmap fst mLocPer, fmap snd mLocPer)
hs = IM.filter (\ m -> bfaction m == sfaction && not (bproj m)) lactor
pers = IM.map (\ h ->
computeReachable cops radius mode smarkVision h lvl) hs
locs = map bloc $ IM.elems hs
lpers = maybeToList mPer ++ IM.elems pers
reachable = PerceptionReachable $ IS.unions (map preachable lpers)
playerControlledMonsterLight = maybeToList mLoc
lights = IS.fromList $ playerControlledMonsterLight ++ locs
visible = computeVisible cotile reachable lvl lights
in Perception { pplayer = mPer
, pheroes = pers
, ptotal = visible
}
computeVisible :: Kind.Ops TileKind -> PerceptionReachable
-> Level -> IS.IntSet -> PerceptionVisible
computeVisible cops reachable@PerceptionReachable{preachable} lvl lights' =
let lights = IS.intersection lights' preachable
isV = isVisible cops reachable lvl lights
in PerceptionVisible $ IS.filter isV preachable
isVisible :: Kind.Ops TileKind -> PerceptionReachable
-> Level -> IS.IntSet -> Point -> Bool
isVisible cotile PerceptionReachable{preachable}
lvl@Level{lxsize, lysize} lights loc0 =
let litDirectly loc = Tile.isLit cotile (lvl `at` loc)
|| loc `IS.member` lights
l_and_R loc = litDirectly loc && loc `IS.member` preachable
in litDirectly loc0 || L.any l_and_R (vicinity lxsize lysize loc0)
computeReachable :: Kind.COps -> Int -> String -> Maybe FovMode
-> Actor -> Level -> PerceptionReachable
computeReachable Kind.COps{cotile, coactor=Kind.Ops{okind}}
radius mode smarkVision actor lvl =
let fovMode m =
if not $ asight $ okind $ bkind m
then Blind
else case smarkVision of
Just fm -> fm
Nothing -> case mode of
"shadow" -> Shadow
"permissive" -> Permissive
"digital" -> Digital radius
_ -> assert `failure` "Unknown FOV mode: " ++ show mode
ploc = bloc actor
in PerceptionReachable $
IS.insert ploc $ IS.fromList $ fullscan cotile (fovMode actor) ploc lvl