module Game.LambdaHack.Server.Fov
(
FovValid(..)
, PerValidFid
, PerReachable(..)
, CacheBeforeLucid(..)
, PerActor
, PerceptionCache(..)
, PerCacheLid
, PerCacheFid
, FovShine(..), FovLucid(..), FovLucidLid
, FovClear(..), FovClearLid, FovLit (..), FovLitLid
, perceptionFromPTotal, perActorFromLevel, totalFromPerActor, lucidFromLevel
, perFidInDungeon, aspectRecordFromActorServer, boundSightByCalm
#ifdef EXPOSE_INTERNAL
, cacheBeforeLucidFromActor
, perceptionCacheFromLevel, perLidFromFaction
, clearFromLevel, clearInDungeon
, litFromLevel, litInDungeon, shineFromLevel
, floorLightSources, lucidFromItems, lucidInDungeon
, 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.Kind as 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 -> AspectRecord
-> CacheBeforeLucid
cacheBeforeLucidFromActor clearPs body 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 (\a -> case a of
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 :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid
-> State -> LevelId -> Level
-> FovLucid
lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl =
let shine = shineFromLevel discoAspect actorAspect 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 :: DiscoveryAspect -> ActorAspect -> State -> LevelId -> Level
-> FovShine
shineFromLevel discoAspect actorAspect s lid lvl =
let actorLights =
[ (bpos b, radius)
| (aid, b) <- inline actorAssocs (const True) lid s
, let radius = aShine $ actorAspect EM.! aid
, radius > 0 ]
floorLights = floorLightSources discoAspect lvl
allLights = floorLights ++ actorLights
in FovShine $ EM.fromListWith max allLights
floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)]
floorLightSources discoAspect lvl =
let processIid (accLight, accDouse) (iid, _) =
let 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 :: DiscoveryAspect -> State
-> ( ActorAspect, FovLitLid, FovClearLid, FovLucidLid
, PerValidFid, PerCacheFid, PerFid)
perFidInDungeon discoAspect s =
let actorAspect = actorAspectInDungeon discoAspect s
fovLitLid = litInDungeon s
fovClearLid = clearInDungeon s
fovLucidLid =
lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s
perValidLid = EM.map (const True) (sdungeon s)
perValidFid = EM.map (const perValidLid) (sfactionD s)
f fid _ = perLidFromFaction actorAspect fovLucidLid fovClearLid fid s
em = EM.mapWithKey f $ sfactionD s
in ( actorAspect, fovLitLid, fovClearLid, fovLucidLid
, perValidFid, EM.map snd em, EM.map fst em)
aspectRecordFromActorServer :: DiscoveryAspect -> Actor -> AspectRecord
aspectRecordFromActorServer discoAspect b =
let processIid (iid, (k, _)) = (discoAspect EM.! iid, k)
processBag ass = sumAspectRecord $ map processIid ass
in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b)
actorAspectInDungeon :: DiscoveryAspect -> State -> ActorAspect
actorAspectInDungeon discoAspect s =
EM.map (aspectRecordFromActorServer discoAspect) $ sactorD s
litFromLevel :: Kind.COps -> Level -> FovLit
litFromLevel Kind.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 :: Kind.COps -> Level -> FovClear
clearFromLevel Kind.COps{coTileSpeedup} Level{ltile} =
FovClear $ PointArray.mapA (Tile.isClear coTileSpeedup) ltile
clearInDungeon :: State -> FovClearLid
clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s
lucidInDungeon :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid
-> State
-> FovLucidLid
lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s =
EM.mapWithKey
(\lid lvl -> FovValid $
lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl)
$ sdungeon s
perLidFromFaction :: ActorAspect -> FovLucidLid -> FovClearLid
-> FactionId -> State
-> (PerLid, PerCacheLid)
perLidFromFaction actorAspect fovLucidLid fovClearLid fid s =
let em = EM.mapWithKey (\lid _ ->
perceptionCacheFromLevel actorAspect 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 :: ActorAspect -> FovClearLid
-> FactionId -> LevelId -> State
-> PerceptionCache
perceptionCacheFromLevel actorAspect fovClearLid fid lid s =
let fovClear = fovClearLid EM.! lid
lvlBodies = inline actorAssocs (== fid) lid s
f (aid, b) =
let ar@AspectRecord{..} = actorAspect 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)