{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
module Graphics.Gloss.Algorithms.RayCast
( castSegIntoCellularQuadTree
, traceSegIntoCellularQuadTree)
where
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Data.Quad
import Graphics.Gloss.Data.Extent
import Graphics.Gloss.Data.QuadTree
import Data.List
import Data.Function
castSegIntoCellularQuadTree
:: forall a
. Point
-> Point
-> Extent
-> QuadTree a
-> Maybe (Point, Extent, a)
castSegIntoCellularQuadTree :: Point -> Point -> Extent -> QuadTree a -> Maybe (Point, Extent, a)
castSegIntoCellularQuadTree Point
p1 Point
p2 Extent
extent QuadTree a
tree
| cells :: [(Point, Extent, a)]
cells@((Point, Extent, a)
_:[(Point, Extent, a)]
_) <- Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
forall a.
Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 Extent
extent QuadTree a
tree
, (Point, Extent, a)
c : [(Point, Extent, a)]
_ <- ((Point, Extent, a) -> (Point, Extent, a) -> Ordering)
-> [(Point, Extent, a)] -> [(Point, Extent, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Point -> Point -> Point -> Ordering
compareDistanceTo Point
p1) (Point -> Point -> Ordering)
-> ((Point, Extent, a) -> Point)
-> (Point, Extent, a)
-> (Point, Extent, a)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Point
a, Extent
_, a
_) -> Point
a) ) [(Point, Extent, a)]
cells
= (Point, Extent, a) -> Maybe (Point, Extent, a)
forall a. a -> Maybe a
Just (Point, Extent, a)
c
| Bool
otherwise
= Maybe (Point, Extent, a)
forall a. Maybe a
Nothing
compareDistanceTo :: Point -> Point -> Point -> Ordering
compareDistanceTo :: Point -> Point -> Point -> Ordering
compareDistanceTo Point
p0 Point
p1 Point
p2
= let d1 :: Float
d1 = Point -> Point -> Float
distance Point
p0 Point
p1
d2 :: Float
d2 = Point -> Point -> Float
distance Point
p0 Point
p2
in Float -> Float -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Float
d1 Float
d2
distance :: Point -> Point -> Float
distance :: Point -> Point -> Float
distance (Float
x1, Float
y1) (Float
x2, Float
y2)
= let xd :: Float
xd = Float
x2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x1
yd :: Float
yd = Float
y2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y1
in Float -> Float
forall a. Floating a => a -> a
sqrt (Float
xd Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
xd Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
yd Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
yd)
traceSegIntoCellularQuadTree
:: forall a
. Point
-> Point
-> Extent
-> QuadTree a
-> [(Point, Extent, a)]
traceSegIntoCellularQuadTree :: Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 Extent
extent QuadTree a
tree
= case QuadTree a
tree of
QuadTree a
TNil -> []
TLeaf a
a
-> case Point -> Point -> Extent -> Maybe Point
intersectSegExtent Point
p1 Point
p2 Extent
extent of
Just Point
pos -> [(Point
pos, Extent
extent, a
a)]
Maybe Point
Nothing -> []
TNode QuadTree a
nw QuadTree a
ne QuadTree a
sw QuadTree a
se
| Point -> Point -> Extent -> Bool
touchesSegExtent Point
p1 Point
p2 Extent
extent
-> [[(Point, Extent, a)]] -> [(Point, Extent, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
forall a.
Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 (Quad -> Extent -> Extent
cutQuadOfExtent Quad
NW Extent
extent) QuadTree a
nw
, Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
forall a.
Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 (Quad -> Extent -> Extent
cutQuadOfExtent Quad
NE Extent
extent) QuadTree a
ne
, Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
forall a.
Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 (Quad -> Extent -> Extent
cutQuadOfExtent Quad
SW Extent
extent) QuadTree a
sw
, Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
forall a.
Point -> Point -> Extent -> QuadTree a -> [(Point, Extent, a)]
traceSegIntoCellularQuadTree Point
p1 Point
p2 (Quad -> Extent -> Extent
cutQuadOfExtent Quad
SE Extent
extent) QuadTree a
se ]
QuadTree a
_ -> []