data-spacepart-20090126.0: src/Data/QuadTree.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
module Data.QuadTree where
import Math.Geometry
import Data.Maybe
import Data.List ( sortBy )
import qualified Data.List as List
{- A hierarchical space subdivision of a region.
- Query for elements matching a certain criteria
- Needs to support intersecting elements in the region.
- Each node in the quadtree is composed of
-}
data QuadTree e where
QuadTree :: (Intersectable e Boundary)
-- A list of elements who's shape can be queried for intersection with the quad.
=> [e]
-- And the quadrants of the axis aligned boundary square
-> Boundary
-> ( Maybe (QuadTree e) , Maybe (QuadTree e)
, Maybe (QuadTree e) , Maybe (QuadTree e)
)
-> QuadTree e
instance HasBoundary (QuadTree e) where
boundary_points (QuadTree _ bounds _) = boundary_points bounds
boundary_edges (QuadTree _ bounds _) = boundary_edges bounds
boundary_extents (QuadTree _ bounds _) = boundary_extents bounds
boundary_square (QuadTree _ bounds _) = bounds
data Quadrant =
NPQuad | PPQuad
| NNQuad | PNQuad
deriving (Eq, Show)
{- As an element of a quadtree can intersect multiple leaf nodes in the quadtree it's best if each
- node in the quadtree could contain a reference to the element. This permits the property: forall
- p <: paths to a leaf node, forall e <: elements in the universe p will countain no more than 1
- reference to e.
-
- Which, I think, greatly simplifies things?
- EG:
- let qt = QuadTree.empty
- qt' = QuadTree.insert qt e0
- qt'' = QuadTree.insert q' e1
- In the case where e1 entirely encompasses qt' there would be greater sharing betwee qt'' and qt'
- than if each node in the tree contained references to all elements that intersect that node.
-
- On the other hand the query "All elements intersecting this child node of this quadtree." would
- require a full descent from the root to collect the list of elements. I could see this being a
- useful query.
-
- I think this is resolvable. The query necessitates a cursor like structure: The reference to a
- specific child node in a quadtree. Which could transparently cache the parent node element
- references.
-}
pp_quad (QuadTree _ _
( _, mq,
_, _
)
)
= mq
pn_quad (QuadTree _ _
( _, _,
_, mq
)
)
= mq
nn_quad (QuadTree _ _
( _, _,
mq, _
)
)
= mq
np_quad (QuadTree _ _
( mq, _,
_, _
)
)
= mq
{- | Returns an empty QuadTree. Which is centered around (0,0) with a size of 2
-}
empty :: Intersectable e Boundary => QuadTree e
empty = QuadTree [] (Boundary (-1,-1) 2) empty_children
empty_children = ( Nothing, Nothing
, Nothing, Nothing
)
singleton_child NPQuad q = ( Just q , Nothing
, Nothing, Nothing
)
singleton_child PPQuad q = ( Nothing, Just q
, Nothing, Nothing
)
singleton_child NNQuad q = ( Nothing, Nothing
, Just q , Nothing
)
singleton_child PNQuad q = ( Nothing, Nothing
, Nothing, Just q
)
{- | Inserts the given element into the quadtree.
- If all boundary points of an element are not contained within the QuadTree's boundary then a
- insert_as_parent is performed.
- If only a single quadrant intersects the element then a insert_as_child is performed.
- Otherwise the element is inserted into the current node's element reference list.
-}
insert :: (Intersectable e Boundary, HasBoundary e) => e -> QuadTree e -> QuadTree e
insert e q =
if q `encloses` e
then insert_self_or_child e q
else insert_via_parent e q
encloses :: (Intersectable e Boundary, HasBoundary e) => QuadTree e -> e -> Bool
encloses q@(QuadTree _ bounds _) e = all (intersects bounds) (boundary_points $ boundary_square e)
insert_self_or_child e q@(QuadTree es bounds quadrants) =
case intersections e (quadrant_bounds q) of
[child] -> insert_child child e q
_ -> QuadTree (e : es) bounds quadrants
quadrant_bounds :: QuadTree e -> [(Boundary, Quadrant)]
quadrant_bounds (QuadTree _ (Boundary p size) _) =
let child_size = size / 2
nn_p = p
np_p = p ^+^ (0 , child_size)
pp_p = p ^+^ (child_size, child_size)
pn_p = p ^+^ (child_size, 0 )
in map (\(p, q) -> (Boundary p child_size, q))
[ (nn_p, NNQuad)
, (np_p, NPQuad)
, (pp_p, PPQuad)
, (pn_p, PNQuad)
]
-- Which are intersectable as the paired boundary is intersectable
instance Intersectable s Boundary => Intersectable s (Boundary, Quadrant) where
intersects s (bounds, _) = intersects s bounds
{- insert_via_parent adds the given element to a new quadtree, q_e, that is connected to the given
- quadtree, q, through a parent tree, q_root.
-
- The two quadtrees q and q_e are both children on some path from q_root.
-
- There is at least one path from q_root to q and q_e. There may be multiple paths?
- let q = (-1, -1) -> 1
- q_e = (0,0) -> 1
- q_root = (-1,-1) -> 2
- In the above case there is only one possible q_root with minimum bounds. However there are multiple
- mays to connect q and q_e through a parent node.
- q_p_0 = (-2, -2) -> 2 [PP => q]
- q_p_1 = (0,0) -> 2 [NN => q_e]
- q_root = (-2, -2) -> 4 [NN => q_p_0, PP => q_p_1]
-
- I'm not really sure of how to optimally introduce a node for q_e and connect them through a
- parent node. There are incorrect methods. EG: Always picking the parent quadtree such that the
- given quadtree is at a fixed position. This could result in a search for a new encompasing
- parent that never converges.
-
- The method used here is to add parent nodes to q until a parent node is found that encompass e.
- This is a breadth first search of the generated graph
- Nodes are parent quadtrees containing q as a child and encompasing e
- Edges are directional (q_u, q_v). Each edge represents the operation of adding a parent to q_u
- such that q_u is a specific quadrant of the parent.
-
- Given quadtree q and an element e:
- There is an edge from q for each of PNQuad, PPQuad, NPQuad, NNQuad to a parent quadtree with q
- as the given quadrant.
- This parent quadtree can be generated from q and the quadrant identifier.
-}
-- parent_trees generates all possible parent trees of the given tree (Without memoization) in the
-- order suitable for a breadth first search.
parent_trees q = parent_trees' [q]
where
parent_trees' (q : qs) =
let parents = imm_parents q
in parents ++ parent_trees' (qs ++ parents)
imm_parents q_child = map (quadtree_with_child_in_quad q_child) [PNQuad, PPQuad, NPQuad, NNQuad]
quadtree_with_child_in_quad q@(QuadTree _ (Boundary (child_x,child_y) child_size) _) quad
| quad == NPQuad = QuadTree [] (Boundary (child_x, child_y - child_size) parent_size) $ singleton_child quad q
| quad == PPQuad = QuadTree [] (Boundary (child_x - child_size, child_y - child_size) parent_size) $ singleton_child quad q
| quad == PNQuad = QuadTree [] (Boundary (child_x - child_size, child_y) parent_size) $ singleton_child quad q
| quad == NNQuad = QuadTree [] (Boundary (child_x, child_y) parent_size) $ singleton_child quad q
where parent_size = child_size * 2
-- The parent to add e to is then the first of parent_trees that encloses e.
insert_via_parent :: (Intersectable e Boundary, HasBoundary e)
=> e
-> QuadTree e
-> QuadTree e
insert_via_parent e q =
let q_root = first (flip encloses e) (parent_trees q)
in insert_self_or_child e q_root
where first f = fromJust . List.find f
{-
- I wonder if there is a closed form solution to this search?
-
- For all Integer i =>
- The size of the quadrants at this level are equal to
- size_i = base_size * 2^i
- For all Integer u,v =>
- The corner points of the quadrants are given by
- ( base_point.x + size_i * u, base_point.y + size_i * v)
- The search is for an (i,u,v) such that the quadrant identified by (i,u,v) completely encompases
- the element being inserted.
- For a given i it is possible to find a quadrant that either encompasses the element or
- intersects the elements boundary.
-}
{- Inserts the element in the child identified by the given boundary and Quadrant.
- If there is no child at the given quadrant then a child is added and the element is inserted into
- the new child.
-}
insert_child :: (Intersectable e Boundary, HasBoundary e)
=> (Boundary, Quadrant)
-> e
-> QuadTree e
-> QuadTree e
insert_child (cb, quad) e q@(QuadTree es b cs) =
let update_child = Just . insert_self_or_child e . maybe (QuadTree [] cb empty_children) id
in QuadTree es b $ map_child update_child quad cs
map_child :: (Maybe (QuadTree e) -> Maybe (QuadTree e))
-> Quadrant
-> (Maybe (QuadTree e), Maybe (QuadTree e)
,Maybe (QuadTree e), Maybe (QuadTree e)
)
-> (Maybe (QuadTree e), Maybe (QuadTree e)
,Maybe (QuadTree e), Maybe (QuadTree e)
)
map_child f NPQuad ( np_c, pp_c
, nn_c, pn_c
) = ( f np_c, pp_c
, nn_c , pn_c
)
map_child f PPQuad ( np_c, pp_c
, nn_c, pn_c
) = ( np_c, f pp_c
, nn_c, pn_c
)
map_child f NNQuad ( np_c, pp_c
, nn_c, pn_c
) = ( np_c , pp_c
, f nn_c, pn_c
)
map_child f PNQuad ( np_c, pp_c
, nn_c, pn_c
) = ( np_c, pp_c
, nn_c, f pn_c
)
instance Show (QuadTree Boundary) where
show (QuadTree es b cq) = show es ++ " " ++ show b ++ " " ++ show cq ++ "\n"
{-
instance Show ( Maybe (QuadTree Boundary), Maybe (QuadTree Boundary)
, Maybe (QuadTree Boundary), Maybe (QuadTree Boundary) ) where
show (mq0, mq1, mq2, mq3) = "( " ++ show (fmap show mq0) ++ "," ++ show (fmap show mq1) ++
"," ++ show (fmap show mq2) ++ "," ++ show (fmap show mq3) ++ ")"
-}