{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes    #-}

-- | Various ray casting algorithms.
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


-- | The quadtree contains cells of unit extent (NetHack style).
--   Given a line segement (P1-P2) through the tree, get the cell
--   closest to P1 that intersects the segment, if any.
---
--   TODO: This currently uses a naive algorithm. It just calls
--         `traceSegIntoCellularQuadTree` and sorts the results
--         to get the one closest to P1. It'd be better to do a
--         proper walk over the tree in the direction of the ray.
--
castSegIntoCellularQuadTree
        :: forall a
        .  Point                        -- ^ (P1) Starting point of seg.
        -> Point                        -- ^ (P2) Final point of seg.
        -> Extent                       -- ^ Extent convering the whole tree.
        -> QuadTree a                   -- ^ The tree.
        -> Maybe (Point, Extent, a)     -- ^ Intersection point, extent of cell, value of cell (if any).

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)


-- | The quadtree contains cells of unit extent (NetHack style).
--   Given a line segment (P1-P2) through the tree, return the list of cells
--   that intersect the segment.
--
traceSegIntoCellularQuadTree
        :: forall a
        .  Point                        -- ^ (P1) Starting point of seg.
        -> Point                        -- ^ (P2) Final point of seg.
        -> Extent                       -- ^ Extent covering the whole tree.
        -> QuadTree a                   -- ^ The tree.
        -> [(Point, Extent, a)]         -- ^ Intersection point, extent of cell, value of cell.

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
_ -> []