module Game.LambdaHack.Server.FovDigital
( scan
, Bump(..)
#ifdef EXPOSE_INTERNAL
, Distance, Progress
, LineOrdering, Line(..), ConvexHull(..), CHull(..), Edge, EdgeInterval
, steepestInHull, foldlCHull', addToHull, addToHullGo
, createLine, steepness, intersect
, _debugSteeper, _debugLine
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude hiding (intersect)
import Game.LambdaHack.Common.Point (PointI)
type Distance = Int
type Progress = Int
data Bump = B
{ Bump -> Int
bx :: Int
, Bump -> Int
by :: Int
}
deriving Int -> Bump -> ShowS
[Bump] -> ShowS
Bump -> String
(Int -> Bump -> ShowS)
-> (Bump -> String) -> ([Bump] -> ShowS) -> Show Bump
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bump] -> ShowS
$cshowList :: [Bump] -> ShowS
show :: Bump -> String
$cshow :: Bump -> String
showsPrec :: Int -> Bump -> ShowS
$cshowsPrec :: Int -> Bump -> ShowS
Show
data LineOrdering = Steeper | Shallower
data Line = Line Bump Bump
deriving Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show
data ConvexHull = ConvexHull Bump CHull
deriving Int -> ConvexHull -> ShowS
[ConvexHull] -> ShowS
ConvexHull -> String
(Int -> ConvexHull -> ShowS)
-> (ConvexHull -> String)
-> ([ConvexHull] -> ShowS)
-> Show ConvexHull
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConvexHull] -> ShowS
$cshowList :: [ConvexHull] -> ShowS
show :: ConvexHull -> String
$cshow :: ConvexHull -> String
showsPrec :: Int -> ConvexHull -> ShowS
$cshowsPrec :: Int -> ConvexHull -> ShowS
Show
data CHull =
CHNil
| CHCons Bump CHull
deriving Int -> CHull -> ShowS
[CHull] -> ShowS
CHull -> String
(Int -> CHull -> ShowS)
-> (CHull -> String) -> ([CHull] -> ShowS) -> Show CHull
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CHull] -> ShowS
$cshowList :: [CHull] -> ShowS
show :: CHull -> String
$cshow :: CHull -> String
showsPrec :: Int -> CHull -> ShowS
$cshowsPrec :: Int -> CHull -> ShowS
Show
type Edge = (Line, ConvexHull)
type EdgeInterval = (Edge, Edge)
scan :: Distance
-> (PointI -> Bool)
-> (Bump -> PointI)
-> [PointI]
{-# INLINE scan #-}
scan :: Int -> (Int -> Bool) -> (Bump -> Int) -> [Int]
scan !Int
r isClear :: Int -> Bool
isClear tr :: Bump -> Int
tr =
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> [Int] -> [Int]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Int -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` Int
r) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
#endif
Int -> EdgeInterval -> [Int]
dscan 1 ( (Bump -> Bump -> Line
Line (Int -> Int -> Bump
B 1 0) (Int -> Int -> Bump
B (-Int
r) Int
r), Bump -> CHull -> ConvexHull
ConvexHull (Int -> Int -> Bump
B 0 0) CHull
CHNil)
, (Bump -> Bump -> Line
Line (Int -> Int -> Bump
B 0 0) (Int -> Int -> Bump
B (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
r), Bump -> CHull -> ConvexHull
ConvexHull (Int -> Int -> Bump
B 1 0) CHull
CHNil) )
where
dscan :: Distance -> EdgeInterval -> [PointI]
{-# INLINE dscan #-}
dscan :: Int -> EdgeInterval -> [Int]
dscan !Int
d ( (sl :: Line
sl, sHull :: ConvexHull
sHull), (el :: Line
el, eHull :: ConvexHull
eHull) ) =
Int -> Line -> ConvexHull -> Line -> ConvexHull -> [Int]
dgo Int
d Line
sl ConvexHull
sHull Line
el ConvexHull
eHull
dgo :: Distance -> Line -> ConvexHull -> Line -> ConvexHull -> [PointI]
dgo :: Int -> Line -> ConvexHull -> Line -> ConvexHull -> [Int]
dgo !Int
d !Line
sl sHull :: ConvexHull
sHull !Line
el eHull :: ConvexHull
eHull =
let !ps0 :: Int
ps0 = let (n :: Int
n, k :: Int
k) = Line -> Int -> (Int, Int)
intersect Line
sl Int
d
in Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
k
!pe :: Int
pe = let (n :: Int
n, k :: Int
k) = Line -> Int -> (Int, Int)
intersect Line
el Int
d
in -1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUp` Int
k
outside :: [Int]
outside =
if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
r
then let !trBump :: Int
trBump = Int -> Int
bump Int
ps0
in if Int -> Bool
isClear Int
trBump
then Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Line -> ConvexHull -> Int -> [Int]
mscanVisible Line
sl ConvexHull
sHull (Int
ps0Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> [Int]
mscanShadowed (Int
ps0Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
bump [Int
ps0..Int
pe]
bump :: Progress -> PointI
bump :: Int -> Int
bump !Int
px = Bump -> Int
tr (Bump -> Int) -> Bump -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bump
B Int
px Int
d
mscanVisible :: Line -> ConvexHull -> Progress -> [PointI]
mscanVisible :: Line -> ConvexHull -> Int -> [Int]
mscanVisible line :: Line
line hull :: ConvexHull
hull = Int -> [Int]
goVisible
where
goVisible :: Progress -> [PointI]
goVisible :: Int -> [Int]
goVisible !Int
ps =
if Int
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pe
then let !trBump :: Int
trBump = Int -> Int
bump Int
ps
in if Int -> Bool
isClear Int
trBump
then Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> [Int]
goVisible (Int
psInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else let steepBump :: Bump
steepBump = Int -> Int -> Bump
B Int
ps Int
d
nep :: Bump
nep = LineOrdering -> Bump -> ConvexHull -> Bump
steepestInHull LineOrdering
Shallower Bump
steepBump ConvexHull
hull
neLine :: Line
neLine = Bump -> Bump -> Line
createLine Bump
nep Bump
steepBump
neHull :: ConvexHull
neHull = LineOrdering -> Bump -> ConvexHull -> ConvexHull
addToHull LineOrdering
Shallower Bump
steepBump ConvexHull
eHull
in Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Line -> ConvexHull -> Line -> ConvexHull -> [Int]
dgo (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Line
line ConvexHull
hull Line
neLine ConvexHull
neHull
[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
mscanShadowed (Int
psInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else Int -> Line -> ConvexHull -> Line -> ConvexHull -> [Int]
dgo (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Line
line ConvexHull
hull Line
el ConvexHull
eHull
mscanShadowed :: Progress -> [PointI]
mscanShadowed :: Int -> [Int]
mscanShadowed !Int
ps =
if Int
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pe
then let !trBump :: Int
trBump = Int -> Int
bump Int
ps
in if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
isClear Int
trBump
then Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> [Int]
mscanShadowed (Int
psInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else let shallowBump :: Bump
shallowBump = Int -> Int -> Bump
B Int
ps Int
d
nsp :: Bump
nsp = LineOrdering -> Bump -> ConvexHull -> Bump
steepestInHull LineOrdering
Steeper Bump
shallowBump ConvexHull
eHull
nsLine :: Line
nsLine = Bump -> Bump -> Line
createLine Bump
nsp Bump
shallowBump
nsHull :: ConvexHull
nsHull = LineOrdering -> Bump -> ConvexHull -> ConvexHull
addToHull LineOrdering
Steeper Bump
shallowBump ConvexHull
sHull
in Int
trBump Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Line -> ConvexHull -> Int -> [Int]
mscanVisible Line
nsLine ConvexHull
nsHull (Int
psInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else []
in
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> [Int] -> [Int]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
pe Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ps0
Bool
-> (Int, Int, Line, ConvexHull, Line, ConvexHull, Int, Int) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Int
r,Int
d,Line
sl,ConvexHull
sHull,Line
el,ConvexHull
eHull,Int
ps0,Int
pe))
#endif
[Int]
outside
steepestInHull :: LineOrdering -> Bump -> ConvexHull -> Bump
{-# NOINLINE steepestInHull #-}
steepestInHull :: LineOrdering -> Bump -> ConvexHull -> Bump
steepestInHull !LineOrdering
lineOrdering !Bump
new (ConvexHull !Bump
b !CHull
ch) = (Bump -> Bump -> Bump) -> Bump -> CHull -> Bump
forall a. (a -> Bump -> a) -> a -> CHull -> a
foldlCHull' Bump -> Bump -> Bump
max' Bump
b CHull
ch
where max' :: Bump -> Bump -> Bump
max' !Bump
x !Bump
y = if LineOrdering -> Bump -> Bump -> Bump -> Bool
steepness LineOrdering
lineOrdering Bump
new Bump
x Bump
y then Bump
x else Bump
y
foldlCHull' :: (a -> Bump -> a) -> a -> CHull -> a
{-# INLINE foldlCHull' #-}
foldlCHull' :: (a -> Bump -> a) -> a -> CHull -> a
foldlCHull' f :: a -> Bump -> a
f = a -> CHull -> a
fgo
where fgo :: a -> CHull -> a
fgo !a
z CHNil = a
z
fgo z :: a
z (CHCons b :: Bump
b ch :: CHull
ch) = a -> CHull -> a
fgo (a -> Bump -> a
f a
z Bump
b) CHull
ch
addToHull :: LineOrdering
-> Bump
-> ConvexHull
-> ConvexHull
{-# INLINE addToHull #-}
addToHull :: LineOrdering -> Bump -> ConvexHull -> ConvexHull
addToHull lineOrdering :: LineOrdering
lineOrdering new :: Bump
new (ConvexHull old :: Bump
old ch :: CHull
ch) =
Bump -> CHull -> ConvexHull
ConvexHull Bump
new (CHull -> ConvexHull) -> CHull -> ConvexHull
forall a b. (a -> b) -> a -> b
$ LineOrdering -> Bump -> CHull -> CHull
addToHullGo LineOrdering
lineOrdering Bump
new (CHull -> CHull) -> CHull -> CHull
forall a b. (a -> b) -> a -> b
$ Bump -> CHull -> CHull
CHCons Bump
old CHull
ch
addToHullGo :: LineOrdering -> Bump -> CHull -> CHull
{-# NOINLINE addToHullGo #-}
addToHullGo :: LineOrdering -> Bump -> CHull -> CHull
addToHullGo !LineOrdering
lineOrdering !Bump
new = CHull -> CHull
hgo
where
hgo :: CHull -> CHull
hgo :: CHull -> CHull
hgo (CHCons a :: Bump
a ch :: CHull
ch@(CHCons b :: Bump
b _)) | Bool -> Bool
not (LineOrdering -> Bump -> Bump -> Bump -> Bool
steepness LineOrdering
lineOrdering Bump
new Bump
b Bump
a) = CHull -> CHull
hgo CHull
ch
hgo ch :: CHull
ch = CHull
ch
createLine :: Bump -> Bump -> Line
{-# INLINE createLine #-}
createLine :: Bump -> Bump -> Line
createLine p1 :: Bump
p1 p2 :: Bump
p2 =
let line :: Line
line = Bump -> Bump -> Line
Line Bump
p1 Bump
p2
in
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> Line -> Line
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((Bool -> String -> Bool) -> (Bool, String) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> String -> Bool
forall a. Show a => Bool -> a -> Bool
blame ((Bool, String) -> Bool) -> (Bool, String) -> Bool
forall a b. (a -> b) -> a -> b
$ Line -> (Bool, String)
_debugLine Line
line)
#endif
Line
line
steepness :: LineOrdering -> Bump -> Bump -> Bump -> Bool
{-# INLINE steepness #-}
steepness :: LineOrdering -> Bump -> Bump -> Bump -> Bool
steepness lineOrdering :: LineOrdering
lineOrdering (B xf :: Int
xf yf :: Int
yf) (B x1 :: Int
x1 y1 :: Int
y1) (B x2 :: Int
x2 y2 :: Int
y2) =
let y2x1 :: Int
y2x1 = (Int
yf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
xf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x1)
y1x2 :: Int
y1x2 = (Int
yf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
xf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x2)
res :: Bool
res = case LineOrdering
lineOrdering of
Steeper -> Int
y2x1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
y1x2
Shallower -> Int
y2x1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y1x2
in
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
res Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== LineOrdering -> Bump -> Bump -> Bump -> Bool
_debugSteeper LineOrdering
lineOrdering (Int -> Int -> Bump
B Int
xf Int
yf) (Int -> Int -> Bump
B Int
x1 Int
y1) (Int -> Int -> Bump
B Int
x2 Int
y2))
#endif
Bool
res
intersect :: Line -> Distance -> (Int, Int)
{-# INLINE intersect #-}
intersect :: Line -> Int -> (Int, Int)
intersect (Line (B x :: Int
x y :: Int
y) (B xf :: Int
xf yf :: Int
yf)) d :: Int
d =
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> (Int, Int) -> (Int, Int)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((Int -> Bool) -> [Int] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0) [Int
y, Int
yf])
#endif
((Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
xf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
yf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y), Int
yf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)
_debugSteeper :: LineOrdering -> Bump -> Bump -> Bump -> Bool
{-# INLINE _debugSteeper #-}
_debugSteeper :: LineOrdering -> Bump -> Bump -> Bump -> Bool
_debugSteeper lineOrdering :: LineOrdering
lineOrdering f :: Bump
f@(B _xf :: Int
_xf yf :: Int
yf) p1 :: Bump
p1@(B _x1 :: Int
_x1 y1 :: Int
y1) p2 :: Bump
p2@(B _x2 :: Int
_x2 y2 :: Int
y2) =
Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((Int -> Bool) -> [Int] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0) [Int
yf, Int
y1, Int
y2]) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
let (n1 :: Int
n1, k1 :: Int
k1) = Line -> Int -> (Int, Int)
intersect (Bump -> Bump -> Line
Line Bump
p1 Bump
f) 0
(n2 :: Int
n2, k2 :: Int
k2) = Line -> Int -> (Int, Int)
intersect (Bump -> Bump -> Line
Line Bump
p2 Bump
f) 0
sign :: Ordering
sign = case LineOrdering
lineOrdering of
Steeper -> Ordering
GT
Shallower -> Ordering
LT
in Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int
k1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n2) (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k2) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
sign
_debugLine :: Line -> (Bool, String)
{-# INLINE _debugLine #-}
_debugLine :: Line -> (Bool, String)
_debugLine line :: Line
line@(Line (B x1 :: Int
x1 y1 :: Int
y1) (B x2 :: Int
x2 y2 :: Int
y2))
| Bool -> Bool
not ((Int -> Bool) -> [Int] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0) [Int
y1, Int
y2]) =
(Bool
False, "negative Y coordinates: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> String
forall a. Show a => a -> String
show Line
line)
| Int
y1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y2 Bool -> Bool -> Bool
&& Int
x1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x2 =
(Bool
False, "ill-defined line: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> String
forall a. Show a => a -> String
show Line
line)
| Int
y1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y2 =
(Bool
False, "horizontal line: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> String
forall a. Show a => a -> String
show Line
line)
| Bool
crossL0 =
(Bool
False, "crosses the X axis below 0: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> String
forall a. Show a => a -> String
show Line
line)
| Bool
crossG1 =
(Bool
False, "crosses the X axis above 1: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> String
forall a. Show a => a -> String
show Line
line)
| Bool
otherwise = (Bool
True, "")
where
(n :: Int
n, k :: Int
k) = Line
line Line -> Int -> (Int, Int)
`intersect` 0
(q :: Int
q, r :: Int
r) = if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then (0, 0) else Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
k
crossL0 :: Bool
crossL0 = Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0
crossG1 :: Bool
crossG1 = Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 Bool -> Bool -> Bool
&& (Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
|| Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)