RayCast.hs

{-# LANGUAGE PatternGuards, 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 p1 p2 extent tree
        | cells@(_:_)   <- traceSegIntoCellularQuadTree p1 p2 extent tree
        , c : _         <- sortBy ((compareDistanceTo p1) `on` (\(a, _, _) -> a) ) cells
        = Just c
        
        | otherwise
        = Nothing
        
compareDistanceTo :: Point -> Point -> Point -> Ordering
compareDistanceTo p0 p1 p2
 = let  d1      = distance p0 p1
        d2      = distance p0 p2
   in   compare d1 d2

distance :: Point -> Point -> Float
distance (x1, y1) (x2, y2)      
 = let  xd      = x2 - x1
        yd      = y2 - y1
   in   sqrt (xd * xd + yd * 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 p1 p2 extent tree 
 = case tree of
        TNil    -> []
        TLeaf a
         -> case intersectSegExtent p1 p2 extent of
                Just pos        -> [(pos, extent, a)]
                Nothing         -> []
                                        
        TNode nw ne sw se
         | touchesSegExtent p1 p2 extent 
         -> concat
             [ traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NW extent) nw
             , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NE extent) ne
             , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SW extent) sw
             , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SE extent) se ]
        
        _ -> []