module Game.LambdaHack.Server.Fov
(
FovValid(..), PerValidFid
, PerReachable(..), CacheBeforeLucid(..), PerActor
, PerceptionCache(..), PerCacheLid, PerCacheFid
, FovShine(..), FovLucid(..), FovLucidLid
, FovClear(..), FovClearLid, FovLit (..), FovLitLid
, perceptionFromPTotal, perActorFromLevel, boundSightByCalm
, totalFromPerActor, lucidFromLevel, perFidInDungeon
#ifdef EXPOSE_INTERNAL
, cacheBeforeLucidFromActor, shineFromLevel, floorLightSources, lucidFromItems
, litFromLevel, litInDungeon, clearFromLevel, clearInDungeon, lucidInDungeon
, perLidFromFaction, perceptionCacheFromLevel
, Matrix, fullscan
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Int (Int64)
import GHC.Exts (inline)
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Server.FovDigital
data FovValid a =
FovValid a
| FovInvalid
deriving (Show, Eq)
type PerValidFid = EM.EnumMap FactionId (EM.EnumMap LevelId Bool)
newtype PerReachable = PerReachable {preachable :: ES.EnumSet Point}
deriving (Show, Eq)
data CacheBeforeLucid = CacheBeforeLucid
{ creachable :: PerReachable
, cnocto :: PerVisible
, csmell :: PerSmelled
}
deriving (Show, Eq)
type PerActor = EM.EnumMap ActorId (FovValid CacheBeforeLucid)
data PerceptionCache = PerceptionCache
{ ptotal :: FovValid CacheBeforeLucid
, perActor :: PerActor
}
deriving (Show, Eq)
type PerCacheLid = EM.EnumMap LevelId PerceptionCache
type PerCacheFid = EM.EnumMap FactionId PerCacheLid
newtype FovShine = FovShine {fovShine :: EM.EnumMap Point Int}
deriving (Show, Eq)
newtype FovLucid = FovLucid {fovLucid :: ES.EnumSet Point}
deriving (Show, Eq)
type FovLucidLid = EM.EnumMap LevelId (FovValid FovLucid)
newtype FovClear = FovClear {fovClear :: PointArray.Array Bool}
deriving (Show, Eq)
type FovClearLid = EM.EnumMap LevelId FovClear
newtype FovLit = FovLit {fovLit :: ES.EnumSet Point}
deriving (Show, Eq)
type FovLitLid = EM.EnumMap LevelId FovLit
perceptionFromPTotal :: FovLucid -> CacheBeforeLucid -> Perception
perceptionFromPTotal FovLucid{fovLucid} ptotal =
let nocto = pvisible $ cnocto ptotal
reach = preachable $ creachable ptotal
psight = PerVisible $ nocto `ES.union` (reach `ES.intersection` fovLucid)
psmell = csmell ptotal
in Perception{..}
perActorFromLevel :: PerActor -> (ActorId -> Actor) -> ActorAspect -> FovClear
-> PerActor
perActorFromLevel perActorOld getActorB actorAspect fovClear =
let f _ fv@FovValid{} = fv
f aid FovInvalid =
let ar = actorAspect EM.! aid
b = getActorB aid
in FovValid $ cacheBeforeLucidFromActor fovClear b ar
in EM.mapWithKey f perActorOld
boundSightByCalm :: Int -> Int64 -> Int
boundSightByCalm sight calm =
min (fromEnum $ calm `div` (5 * oneM)) sight
cacheBeforeLucidFromActor :: FovClear -> Actor -> IA.AspectRecord
-> CacheBeforeLucid
cacheBeforeLucidFromActor clearPs body IA.AspectRecord{..} =
let radius = boundSightByCalm aSight (bcalm body)
creachable = PerReachable $ fullscan clearPs radius (bpos body)
cnocto = PerVisible $ fullscan clearPs aNocto (bpos body)
smellRadius = if aSmell >= 2 then 2 else 0
csmell = PerSmelled $ fullscan clearPs smellRadius (bpos body)
in CacheBeforeLucid{..}
totalFromPerActor :: PerActor -> CacheBeforeLucid
totalFromPerActor perActor =
let as = map (\case
FovValid x -> x
FovInvalid -> error $ "" `showFailure` perActor)
$ EM.elems perActor
in CacheBeforeLucid
{ creachable = PerReachable
$ ES.unions $ map (preachable . creachable) as
, cnocto = PerVisible
$ ES.unions $ map (pvisible . cnocto) as
, csmell = PerSmelled
$ ES.unions $ map (psmelled . csmell) as }
lucidFromLevel :: FovClearLid -> FovLitLid -> State -> LevelId -> Level
-> FovLucid
lucidFromLevel fovClearLid fovLitLid s lid lvl =
let shine = shineFromLevel s lid lvl
lucids = lucidFromItems (fovClearLid EM.! lid)
$ EM.assocs $ fovShine shine
litTiles = fovLitLid EM.! lid
in FovLucid $ ES.unions $ fovLit litTiles : map fovLucid lucids
shineFromLevel :: State -> LevelId -> Level -> FovShine
shineFromLevel s lid lvl =
let actorLights =
[ (bpos b, radius)
| (aid, b) <- inline actorAssocs (const True) lid s
, let radius = IA.aShine $ sactorAspect s EM.! aid
, radius > 0 ]
floorLights = floorLightSources (sdiscoAspect s) lvl
allLights = floorLights ++ actorLights
in FovShine $ EM.fromListWith max allLights
floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)]
floorLightSources discoAspect lvl =
let processIid (accLight, accDouse) (iid, _) =
let IA.AspectRecord{aShine} = discoAspect EM.! iid
in case compare aShine 0 of
EQ -> (accLight, accDouse)
GT -> (max aShine accLight, accDouse)
LT -> (accLight, min aShine accDouse)
processBag bag acc = foldl' processIid acc $ EM.assocs bag
in [ (p, radius)
| (p, bag) <- EM.assocs $ lfloor lvl
, let (maxLight, maxDouse) = processBag bag (0, 0)
radius = maxLight + maxDouse
, radius > 0 ]
lucidFromItems :: FovClear -> [(Point, Int)] -> [FovLucid]
lucidFromItems clearPs allItems =
let lucidPos (p, shine) = FovLucid $ fullscan clearPs shine p
in map lucidPos allItems
perFidInDungeon :: State -> ( FovLitLid, FovClearLid, FovLucidLid
, PerValidFid, PerCacheFid, PerFid)
perFidInDungeon s =
let fovLitLid = litInDungeon s
fovClearLid = clearInDungeon s
fovLucidLid = lucidInDungeon fovClearLid fovLitLid s
perValidLid = EM.map (const True) (sdungeon s)
perValidFid = EM.map (const perValidLid) (sfactionD s)
f fid _ = perLidFromFaction fovLucidLid fovClearLid fid s
em = EM.mapWithKey f $ sfactionD s
in ( fovLitLid, fovClearLid, fovLucidLid
, perValidFid, EM.map snd em, EM.map fst em)
litFromLevel :: COps -> Level -> FovLit
litFromLevel COps{coTileSpeedup} Level{ltile} =
let litSet p t set = if Tile.isLit coTileSpeedup t then p : set else set
in FovLit $ ES.fromDistinctAscList $ PointArray.ifoldrA' litSet [] ltile
litInDungeon :: State -> FovLitLid
litInDungeon s = EM.map (litFromLevel (scops s)) $ sdungeon s
clearFromLevel :: COps -> Level -> FovClear
clearFromLevel COps{coTileSpeedup} Level{ltile} =
FovClear $ PointArray.mapA (Tile.isClear coTileSpeedup) ltile
clearInDungeon :: State -> FovClearLid
clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s
lucidInDungeon :: FovClearLid -> FovLitLid -> State-> FovLucidLid
lucidInDungeon fovClearLid fovLitLid s =
EM.mapWithKey
(\lid lvl -> FovValid $
lucidFromLevel fovClearLid fovLitLid s lid lvl)
$ sdungeon s
perLidFromFaction :: FovLucidLid -> FovClearLid -> FactionId -> State
-> (PerLid, PerCacheLid)
perLidFromFaction fovLucidLid fovClearLid fid s =
let em = EM.mapWithKey (\lid _ ->
perceptionCacheFromLevel fovClearLid fid lid s)
(sdungeon s)
fovLucid lid = case EM.lookup lid fovLucidLid of
Just (FovValid fl) -> fl
_ -> error $ "" `showFailure` (lid, fovLucidLid)
getValid (FovValid pc) = pc
getValid FovInvalid = error $ "" `showFailure` fid
in ( EM.mapWithKey (\lid pc ->
perceptionFromPTotal (fovLucid lid) (getValid (ptotal pc))) em
, em )
perceptionCacheFromLevel :: FovClearLid -> FactionId -> LevelId -> State
-> PerceptionCache
perceptionCacheFromLevel fovClearLid fid lid s =
let fovClear = fovClearLid EM.! lid
lvlBodies = inline actorAssocs (== fid) lid s
f (aid, b) =
let ar@IA.AspectRecord{..} = sactorAspect s EM.! aid
in if aSight <= 0 && aNocto <= 0 && aSmell <= 0
then Nothing
else Just (aid, FovValid $ cacheBeforeLucidFromActor fovClear b ar)
lvlCaches = mapMaybe f lvlBodies
perActor = EM.fromDistinctAscList lvlCaches
total = totalFromPerActor perActor
in PerceptionCache{ptotal = FovValid total, perActor}
type Matrix = (Int, Int, Int, Int)
fullscan :: FovClear
-> Int
-> Point
-> ES.EnumSet Point
fullscan FovClear{fovClear} radius spectatorPos =
if | radius <= 0 -> ES.empty
| radius == 1 -> ES.singleton spectatorPos
| radius == 2 -> inline squareUnsafeSet spectatorPos
| otherwise ->
mapTr (1, 0, 0, -1)
$ mapTr (0, 1, 1, 0)
$ mapTr (-1, 0, 0, 1)
$ mapTr (0, -1, -1, 0)
$ ES.singleton spectatorPos
where
mapTr :: Matrix -> ES.EnumSet Point -> ES.EnumSet Point
mapTr m@(!_, !_, !_, !_) es = scan es (radius - 1) fovClear (trV m)
trV :: Matrix -> Bump -> Point
{-# INLINE trV #-}
trV (x1, y1, x2, y2) B{..} =
shift spectatorPos $ Vector (x1 * bx + y1 * by) (x2 * bx + y2 * by)