module Game.LambdaHack.Server.FovDigital
( scan
, Bump(..)
#ifdef EXPOSE_INTERNAL
, Distance, Progress
, Line(..), ConvexHull, Edge, EdgeInterval
, steeper, addHull
, dline, dsteeper, intersect, _debugSteeper, _debugLine
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude hiding (intersect)
import qualified Data.EnumSet as ES
import Game.LambdaHack.Common.Point hiding (inside)
import qualified Game.LambdaHack.Common.PointArray as PointArray
type Distance = Int
type Progress = Int
data Bump = B
{ bx :: Int
, by :: Int
}
deriving Show
data Line = Line Bump Bump
deriving Show
type ConvexHull = [Bump]
type Edge = (Line, ConvexHull)
type EdgeInterval = (Edge, Edge)
scan :: ES.EnumSet Point
-> Distance
-> PointArray.Array Bool
-> (Bump -> Point)
-> ES.EnumSet Point
{-# INLINE scan #-}
scan accScan r fovClear tr = assert (r > 0 `blame` r) $
dscan accScan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])
, (Line (B 0 0) (B (r+1) r), [B 1 0]) )
where
isClear :: Point -> Bool
isClear = (fovClear PointArray.!)
dscan :: ES.EnumSet Point -> Distance -> EdgeInterval -> ES.EnumSet Point
dscan !accDscan !d ( s0@(!sl, !sHull)
, e0@(!el, !eHull) ) =
let !ps0 = let (n, k) = intersect sl d
in n `div` k
!pe = let (n, k) = intersect el d
in -1 + n `divUp` k
outside =
if d < r
then let !trBump = bump ps0
!accBump = ES.insert trBump accDscan
in if isClear trBump
then mscanVisible accBump s0 (ps0+1)
else mscanShadowed accBump (ps0+1)
else foldl' (\acc ps -> ES.insert (bump ps) acc) accDscan [ps0..pe]
bump px = tr $ B px d
mscanVisible :: ES.EnumSet Point -> Edge -> Progress -> ES.EnumSet Point
mscanVisible !acc !s !ps =
if ps <= pe
then let !trBump = bump ps
!accBump = ES.insert trBump acc
in if isClear trBump
then mscanVisible accBump s (ps+1)
else let {-# INLINE steepBump #-}
steepBump = B ps d
cmp :: Bump -> Bump -> Ordering
{-# INLINE cmp #-}
cmp = flip $ dsteeper steepBump
nep = maximumBy cmp (snd s)
neHull = addHull cmp steepBump eHull
ne = (dline nep steepBump, neHull)
accNew = dscan accBump (d+1) (s, ne)
in mscanShadowed accNew (ps+1)
else dscan acc (d+1) (s, e0)
mscanShadowed :: ES.EnumSet Point -> Progress -> ES.EnumSet Point
mscanShadowed !acc !ps =
if ps <= pe
then let !trBump = bump ps
!accBump = ES.insert trBump acc
in if not $ isClear trBump
then mscanShadowed accBump (ps+1)
else let {-# INLINE shallowBump #-}
shallowBump = B ps d
cmp :: Bump -> Bump -> Ordering
{-# INLINE cmp #-}
cmp = dsteeper shallowBump
nsp = maximumBy cmp eHull
nsHull = addHull cmp shallowBump sHull
ns = (dline nsp shallowBump, nsHull)
in mscanVisible accBump ns (ps+1)
else acc
in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e0,ps0,pe))
outside
steeper :: Bump -> Bump -> Bump -> Ordering
{-# INLINE steeper #-}
steeper (B xf yf) (B x1 y1) (B x2 y2) =
compare ((yf - y2)*(xf - x1)) ((yf - y1)*(xf - x2))
addHull :: (Bump -> Bump -> Ordering)
-> Bump
-> ConvexHull
-> ConvexHull
{-# INLINE addHull #-}
addHull cmp new = (new :) . go
where
go (a:b:cs) | cmp b a /= GT = go (b:cs)
go l = l
dline :: Bump -> Bump -> Line
{-# INLINE dline #-}
dline p1 p2 =
let line = Line p1 p2
in
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (uncurry blame $ _debugLine line)
#endif
line
dsteeper :: Bump -> Bump -> Bump -> Ordering
{-# INLINE dsteeper #-}
dsteeper = \f p1 p2 ->
let res = steeper f p1 p2
in
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (res == _debugSteeper f p1 p2)
#endif
res
intersect :: Line -> Distance -> (Int, Int)
{-# INLINE intersect #-}
intersect (Line (B x y) (B xf yf)) d =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (allB (>= 0) [y, yf])
#endif
((d - y)*(xf - x) + x*(yf - y), yf - y)
_debugSteeper :: Bump -> Bump -> Bump -> Ordering
{-# INLINE _debugSteeper #-}
_debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =
assert (allB (>= 0) [yf, y1, y2]) $
let (n1, k1) = intersect (Line p1 f) 0
(n2, k2) = intersect (Line p2 f) 0
in compare (k1 * n2) (n1 * k2)
_debugLine :: Line -> (Bool, String)
{-# INLINE _debugLine #-}
_debugLine line@(Line (B x1 y1) (B x2 y2))
| not (allB (>= 0) [y1, y2]) =
(False, "negative coordinates: " ++ show line)
| y1 == y2 && x1 == x2 =
(False, "ill-defined line: " ++ show line)
| y1 == y2 =
(False, "horizontal line: " ++ show line)
| crossL0 =
(False, "crosses the X axis below 0: " ++ show line)
| crossG1 =
(False, "crosses the X axis above 1: " ++ show line)
| otherwise = (True, "")
where
(n, k) = line `intersect` 0
(q, r) = if k == 0 then (0, 0) else n `divMod` k
crossL0 = q < 0
crossG1 = q >= 1 && (q > 1 || r /= 0)