data-spacepart 20090126.0 → 20090215.0

raw patch · 16 files changed

+764/−530 lines, 16 filesdep −mersenne-randomPVP ok

version bump matches the API change (PVP)

Dependencies removed: mersenne-random

API changes (from Hackage documentation)

Files

• CHANGELOG +20/−0
• README +52/−0
• data-spacepart.cabal +22/−26
• src/Data/QuadTree.hs +0/−274
• src/Data/SpacePart/AABB.hs +193/−0
• src/Data/SpacePart/QuadTree.hs +308/−0
• src/Math/Geometry.hs +0/−167
• src/System/Random/Utils.hs +0/−12
• test/QuadTreeVisualize.hs +23/−44
• test/System/Random/Utils.hs +12/−0
• test/Verify.hs +14/−0
• test/Verify/Data/SpacePart/AABB.hs +45/−0
• test/Verify/Data/SpacePart/QuadTree.hs +61/−0
• test/run_test +0/−7
• test/run_verify +7/−0
• test/run_visualize +7/−0

@@ -0,0 +1,20 @@+    - Renamed Math.Geometry to Data.SpacePart.AABB+    - Renamed Data.QuadTree to Data.SpacePart.QuadTree+    - Added Data.SpacePart.QuadTree.query. Returns all elements that intersect a given boundary.+    - The inclusive nature of the boundary's min extent should take precedence of the exclusive+      nature of the max extent.+        Before this change many of the tests failed when boundaries of 0 area were involved. One case+        that did not work was constructing a quadtree containing elements of 0 area. This change+        corrected this.+        The tests all_elements_inserted_query_prop and element_bounds_query_is_element_prop stil+        fail if the element is of 0 area. +    - Cannot create quadtrees with initial bounds of 0 area.+    - Removed requirement on elements being an instance of the Intersectable class. The only+      required instance is of Data.SpacePart.AABB.HasBoundary.+    - Changed version number to 3000.B.C to follow the standard package version policy and be+      greater than the previous date-based releases.+    - Added some QuickCheck based checks. Run with test/run_verify+    - Cleaned up the module exports.++20090126.0+    - Initial release.

@@ -0,0 +1,52 @@+This library is still in the early stages. Expect the interface to change.++TODO:+    - rename Boundary data type +    - rename HasBoundary type class.+    - query should accept any suitable region. +        - At least any axis aligned boxes not just square ones+    - partition query into two forms:+        - inclusive: Any element with bounds entirely within or partially the query bounds.+        - exclusive: Any element with bounds entirely within the query bounds.+    - Improve verification tests +        - Test for proper distribution of inserted elements to nodes.+    - Improve visualization tool+        - interactive querying+        - interactive insert+        - remove FBO dependency.++    Optimization:+        - The following element_bounds_query_is_element_prop instance takes a significant amount of+          time:+        Boundary {boundary_corner = (-8.6,-25.0), boundary_size = 0.1875}+        Boundary {boundary_corner = (-23.541666666666668,11.666666666666666), boundary_size = 20.7}++verification:+    The script "run_verify" compiles and executes the Verify.hs program. This is done in such a way+    that any data-spacepart package installed is hidden and the modules are sourced directly from+    the src folder. +    The Verify.hs program just runs whatever QuickCheck tests I have thrown together. For each+    module under src there is a corresponding module under Verify that contains it's Arbitrary+    instances and verification properties.++    The script "run_visualize" compiles and executes the QuadTreeVisualize program. This will be+    compiled against the installed data-spacepart package. +    The purpose of QuadTreeVisualize is to, well, visualize a random quadtree instance. in order to+    run this program it's necessary to have OpenGL bindings that support FBO. I have a branch with+    the required patches here:+        http://www.tothepowerofdisco.com/repo/OpenGL/++    The controls are:+        - arrow keys move left, up, right, down.+        - Shift-up and shift-down zoom in and zoom out respectively.++    This visualization program should not require the FBO dependency. However it was pulled from a+    different visualization system which did require FBOs. Removing this dependency is on the TODO+    list.++The version number of the library tries to follow the standard package version policy:+    http://www.haskell.org/haskellwiki/Package_versioning_policy++with the following addition: For the versiom number A.B.C.D D will be even for production releases+and odd for development versions.+

@@ -1,51 +1,47 @@ Name:           data-spacepart-Version:        20090126.0+Version:        20090215.0 License:        BSD3 License-File:   LICENSE Author:         Corey O'Connor <coreyoconnor@gmail.com> Maintainer:     Corey O'Connor <coreyoconnor@gmail.com>-Homepage:       http://www.tothepowerofdisco.com/repo/data-spacepart/-Package-URL:    http://www.tothepowerofdisco.com/repo/data-spacepart/+Homepage:       http://code.haskell.org/data-spacepart+Package-URL:    http://code.haskell.org/data-spacepart Category:       Data Build-Type:     Simple-Synopsis:       Space partition data structures. Currently only a QuadTree.+Synopsis:       Deprecated. Now called "spacepart". Space partitioning data structures.  Stability:      alpha Description:+    Package "data-spacepart" is now called just "spacepart". This was due to issues with the version+    number used for the first release of data-spacepart.+    .+    http:\/\/hackage.haskell.org\/cgi-bin\/hackage-scripts\/package\/spacepart+    .     Space partition data structures. Currently only a QuadTree.     .-    darcs get --partial http://www.tothepowerofdisco.com/repo/data-spacepart/+    darcs get --partial http:\/\/code.haskell.org\/data-spacepart\/     .     TODO:     .         lots.-        .-        Move test/QuadTreeVisualize to a separate package.     .-    The only example is test/QuadTreeVisualize. This can be run with:-    .-        chmod u+x test/run_test-        .-        cd test && ./run_test-    .-    This isn't actually a "test". QuadTreeVisualize renders a random quadtree in-    a heavily stylized fashion using OpenGL. Arrows to move about. Shift-Up/Down-    to zoom in and out. This requires a non-standard branch of the OpenGL-    libraries from here: -    .-    http:\/\/www.tothepowerofdisco.com\/repo\/OpenGL\/-    .-    Due to the framebuffer object requirement of the test/Render module.+    See README: http:\/\/code.haskell.org\/data-spacepart\/README      Extra-Source-Files: test/QuadTreeVisualize.hs-                    test/run_test+                    test/run_visualize                     test/Render.hs+                    test/run_verify+                    test/Verify.hs+                    test/Verify/Data/SpacePart/AABB.hs+                    test/Verify/Data/SpacePart/QuadTree.hs+                    test/System/Random/Utils.hs+                    README+                    CHANGELOG  Cabal-Version:  >= 1.6  library     hs-source-dirs:         src-    build-depends:          base, vector-space == 0.5.*, mersenne-random == 0.1.*-    exposed-modules:        Data.QuadTree-                            Math.Geometry-                            System.Random.Utils+    build-depends:          base, vector-space == 0.5.*+    exposed-modules:        Data.SpacePart.QuadTree+                            Data.SpacePart.AABB 

@@ -1,274 +0,0 @@-{-# 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) ++ ")"---}

@@ -0,0 +1,193 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module Data.SpacePart.AABB+    ( Boundary(..)+    , HasBoundary(..)+    , encloses+    , intersects+    )+    where++import Data.VectorSpace+import Data.List (foldl')++type Vertex2 a = (a, a)+vec2 :: Double -> Double -> Vertex2 Double+vec2 x y = (x, y)++vx :: VectorSpace (v, v) => (v, v) -> v+vx (x, _) = x++vy :: VectorSpace (v, v) => (v, v) -> v+vy (_, y) = y++type Edge2 a = (Vertex2 a, Vertex2 a)+type LineSegment = Edge2 Double++-- "intersects" is a commutative binary predicate on two shapes. +class Intersectable s0 s1 where+   intersects :: s0 -> s1 -> Bool++--instance Intersectable s0 s1 => Intersectable s1 s0 where+--   intersects s1 s0 = intersects s0 s1++intersections e es = filter (intersects e) es++-- | A 2D axis aligned square.+-- The boundary_corner defines the lower bound.+-- The boundary_size is the length of any edge of the square.+--+-- The boundary is inclusive on the low extent and exclusive on the max extent.+--+-- Used to represent both the +-- 0. 2D axis aligned minimum bounding square of an element.+--+-- 1. The boundary of a quadtree element+--+data Boundary = Boundary+    {+        boundary_corner :: Vertex2 Double,+        boundary_size   :: Double+    }+    deriving (Eq, Show)++-- Boundaries b0 and b1 intersect if the min extent of the intersection of b1 with (the plane +x+-- including b0.p unioned with the plane +y including b0.p) is within b0.+instance Intersectable Boundary Boundary where+    intersects b0 b1 = +        let c = (MinExtentPlanes $ boundary_corner b0)+        in if b1 `intersects` c+            then let (Boundary p _) = intersection b1 c+                 in intersects b0 p+            else False++newtype MinExtentPlanes = MinExtentPlanes (Vertex2 Double)+    deriving (Eq, Show)++-- A boundary intersects the min extent planes if the far extent of the boundary is within the range+-- defined by the min extent planes.  The comparison is > and not >= since the far extent is the+-- point just beyond the boundary. Which needs to be just inside the planes in order for the+-- boundary to be inside the planes.+instance Intersectable Boundary MinExtentPlanes where+    intersects b (MinExtentPlanes (min_x, min_y)) =+        let ((b_min_x, b_min_y), (b_max_x, b_max_y)) = boundary_extents b+        in if b_min_x == min_x && b_min_y == min_y+            then True+            else (b_max_x > min_x) && (b_max_y > min_y)++intersection :: Boundary -> MinExtentPlanes -> Boundary+intersection (Boundary p size) (MinExtentPlanes min_p) = Boundary (ext_max min_p p) size++instance Intersectable Boundary LineSegment where+   intersects b l@(p0, p1) =+-- If any point of the line segment is contained in the boundary then the line segment intersects the+-- element.+       intersects b p0 || intersects b p1+-- If niether point is in the element the line segment could still intersect the boundary. The line+-- segment must, in this case, intersect an edge of the boundary.+       || any (intersects l) (boundary_edges b)++--The equations for line intersection are pulled from +--  http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/+-- without much thought.++instance Intersectable LineSegment LineSegment where+   intersects (p0a, p0b) (p1a, p1b) = +       let x1 = vx p0a+           y1 = vy p0a+           x2 = vx p0b+           y2 = vy p0b+           x3 = vx p1a+           y3 = vy p1a+           x4 = vx p1b+           y4 = vy p1b+           div = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1)+       in if div < 1e-9 +           then False+           else+           let t0n = (x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3)+               t0 = t0n / div+               t1n = (x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3)+               t1 = t1n / div+           in t0 > 0.0 && t0 < 1.0 && t1 > 0.0 && t1 < 1.0++union_boundaries :: Boundary -> Boundary -> Boundary+union_boundaries b0 b1 =+    let (min0, max0) = boundary_extents b0+        (min1, max1) = boundary_extents b1+        p = ext_min min0 min1+        ext = ext_max max0 max1+        (w,h) = ext ^-^ p+        size = max w h+    in Boundary p size++ext_min (x0,y0) (x1,y1) = (min x0 x1, min y0 y1)+ext_max (x0,y0) (x1,y1) = (max x0 x1, max y0 y1)++--instance Show Boundary where+--    show (Boundary p size) = show p ++ " -> " ++ show size++instance Intersectable Boundary (Vertex2 Double) where+    intersects bounds (px, py) =+        let (x, y) = boundary_corner bounds+            s = boundary_size bounds+        -- If the point is equal to the corner point then consider it intersecting.+        -- The inclusive nature of the min extent "wins out" over the exclusive nature of the max+        -- extent.+        in if x == px && y == py+            then True+            else px < (x + s) && px >= x && py < (y + s) && py >= y++{- | A instance of HasBoundary has an axis aligned boundign square defined that entirely encloses+ - the space represented by the type.+ -}+class HasBoundary s where+    boundary_points :: s -> [Vertex2 Double]+    boundary_edges :: s -> [Edge2 Double]+    boundary_edges s = +        let ps@(p0 : ps') = boundary_points s+        in zip ps (ps' ++ [p0])+    boundary_extents :: s -> (Vertex2 Double, Vertex2 Double)+    boundary_extents s =+        let (p0 : ps) = boundary_points s+            initial_min_extent = p0+            initial_max_extent = p0+            union_extents ((min_x, min_y), (max_x,max_y)) (x, y) =+                let min_x' = min min_x x+                    min_y' = min min_y y+                    max_x' = max max_x x+                    max_y' = max max_y y+                in ((min_x', min_y'), (max_x', max_y'))+        in foldl' union_extents (initial_min_extent, initial_max_extent) ps+    boundary_square :: s -> Boundary+    boundary_square s =+        let (min_extent, max_extent) = boundary_extents s+            width  = fst max_extent - fst min_extent+            height = snd max_extent - snd min_extent+            size = max width height+        in Boundary (fst min_extent, snd min_extent) size++-- A boundary cleary has itself as it's boundary.+instance HasBoundary Boundary where+    boundary_points (Boundary p s) = +        [ p+        , p ^+^ (0, s)+        , p ^+^ (s, s)+        , p ^+^ (s, 0)+        ]+    boundary_extents (Boundary p s) = (p, p ^+^ (s,s))+    boundary_square b = b++{-| Returns true if the first boundary entirely encloses the second boundary.+ - This is expected to be reflexive.+ -}+encloses :: Boundary -> Boundary -> Bool+encloses (Boundary (x0,y0) s0) (Boundary (x1,y1) s1) = (x0 <= x1 && x0 + s0 >= x1 + s1) && (y0 <= y1 && y0 + s0 >= y1 + s1)+

@@ -0,0 +1,308 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+module Data.SpacePart.QuadTree where+import Data.SpacePart.AABB++import Data.Maybe+import Data.List ( sortBy )+import qualified Data.List as List+import Data.VectorSpace++-- | A 2D binary hierarchical space subdivision of a region. +-- All elements contained in the quadtree are required to have a Boundary. This is an axis aligned+-- box with congruent sides.+--+-- Each node of the quadtree is composed of:+-- +-- 0. A list of elements who's shape can be queried for intersection with the quad.  These are all+-- the elements with a boundary that are fully enclosed by the boundary of this node but not fully+-- enclosed by a quadrant of this node. +--+-- 1. The Boundary of this node.+--+-- 2. The child nodes of this node. Each is a quadrant of this nodes boundary.+--+data QuadTree e where+    QuadTree :: (HasBoundary e)+                => [e]+                -> Boundary+                -> ( Maybe (QuadTree e) , Maybe (QuadTree e)+                   , Maybe (QuadTree e) , Maybe (QuadTree e)+                   ) +                -> QuadTree e++elements :: QuadTree e -> [e]+elements (QuadTree es _ _) = es++children :: QuadTree e -> ( Maybe (QuadTree e) , Maybe (QuadTree e)+                          , Maybe (QuadTree e) , Maybe (QuadTree e)+                          )+children (QuadTree _ _ c) = c++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)++{- An element of a quadtree can intersect the boundary of multiple nodes in the quadtree. This+ - only associates an element with a single node.  This permits the property: forall p. p <: paths+ - to a leaf node, forall e <: elements in the universe => p will enounter no more than one element+ - that references e.+ -+ - Which, I think, simplifies things. Maybe?+ - 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++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+                       )++non_empty_children q =+    let (np_c, pp_c, nn_c, pn_c) = children q+    in catMaybes [np_c, pp_c, nn_c, pn_c]++{- | Returns an empty QuadTree without a specific boundary. The default bounds are centered around+ - (0,0) with a size of 2+ -+ - TODO: Alternatively an empty quadtree could have no defined bounds. The bounds would then be+ - defined on the first insertion. + -}+empty :: HasBoundary e => QuadTree e+empty = QuadTree [] (Boundary (-1,-1) 2) empty_children++{- | Returns an empty QuadTree with the given bounds.+ - The given bounds cannot have a size of 0. This will error out on that case.+ -+ - TODO: The user may find it easier for this to accept a 0 sized boundary which is transparently+ - changed to a non-0 sized boundary on insert.+ -}+empty_with_bounds :: HasBoundary e => Boundary -> QuadTree e+empty_with_bounds (Boundary _ 0.0) = error "Cannot construct a quadtree with 0 sized boundary."+empty_with_bounds bounds = QuadTree [] bounds 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. + - This inserts the element into a this node or a child quadrant node if the current node encloses+ - the element.  Otherwise this inserts the element into a new node that is a parent of the given+ - node.+ -}+insert :: (HasBoundary e) => e -> QuadTree e -> QuadTree e+insert e q =+    if (boundary_square q) `encloses` (boundary_square e)+        then insert_self_or_child e q+        else insert_via_parent e q++{-| Inserts the given element into either a child node of the current node if one of the quadrants+ - encloses the element.+ - Otherwise the element is added to the current node's list of elements.+ -}+insert_self_or_child :: (HasBoundary e) => e -> QuadTree e -> QuadTree e+insert_self_or_child e q@(QuadTree es bounds quadrants) =+    case filter (\(cqb, _) -> cqb `encloses` (boundary_square 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)+        ]++{- 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.+ -}++-- | Adds the element to quadtree via a parent node to the given quadtree.+-- The parent to add e to is then the first of the possible parents nodes that enclose e.+insert_via_parent :: (HasBoundary e) +                    => e+                    -> QuadTree e +                    -> QuadTree e+insert_via_parent e q = +    let q_root = first (\pq ->  (boundary_square pq) `encloses` (boundary_square e)) (parent_trees q)+    in insert_self_or_child e q_root+    where first f = fromJust . List.find f++-- | 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++{- I wonder if there is a closed form solution to the search performed by insert_via_parent+ -+ -  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 :: (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++{- | Returns all elements with boundaries that intersect the given boundary+ - By case:+ -  Boundary does not intersect quadtree+ -  Boundary intersects the quadtree+ -      All elements at the level of the quadtree could intersect the boundary. Test each element+ -      for intersection. + -      Descend into the quadrants+ -}+query :: (HasBoundary e) => Boundary -> QuadTree e -> [e]+query query_boundary = query' []+    where query' out q+            | not $ query_boundary `intersects` (boundary_square q) = out+            | otherwise = +                let es = filter (\e -> (boundary_square e) `intersects` query_boundary) $ elements q+                in foldl (\out' cq -> query' out' cq) (out ++ es) (non_empty_children q)+

@@ -1,167 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-module Math.Geometry -    ( module Math.Geometry-     ,module Data.VectorSpace-    )-    where--import Data.VectorSpace-import Data.List (foldl')--type Vertex2 a = (a, a)-vec2 :: Double -> Double -> Vertex2 Double-vec2 x y = (x, y)--vx :: VectorSpace (v, v) => (v, v) -> v-vx (x, _) = x--vy :: VectorSpace (v, v) => (v, v) -> v-vy (_, y) = y--type Edge2 a = (Vertex2 a, Vertex2 a)-type LineSegment = Edge2 Double---- "intersects" is a commutative binary predicate on two shapes. -class Intersectable s0 s1 where-   intersects :: s0 -> s1 -> Bool----instance Intersectable s0 s1 => Intersectable s1 s0 where---   intersects s1 s0 = intersects s0 s1--intersections e es = filter (intersects e) es---- A Boundary describes an inclusive lower bound with a corner point and an exclusive upper bound--- with a size.-data Boundary = Boundary-    {-        boundary_corner :: Vertex2 Double,-        boundary_size   :: Double-    }-    deriving (Show)---- Boundaries b0 and b1 intersect if the min extent of the intersection of b1 with (the plane +x--- including b0.p unioned with the plane +y including b0.p) is within b0.-instance Intersectable Boundary Boundary where-    intersects b0 b1 = -        let c = union_min_extent_planes_of b0-        in if b1 `intersects` c-            then let (Boundary p _) = intersection b1 c-                 in intersects b0 p-            else False---- The union of the min extent planes of a boundary is represented by the min extent-newtype MinExtentPlanes = MinExtentPlanes (Vertex2 Double)-union_min_extent_planes_of (Boundary p _) = MinExtentPlanes p---- A boundary intersects the min extent planes if the far extent extent of the boundary is within--- the range defined by the min extent planes.--- The comparison is > and not >= since the far extent is the point just beyond the boundary. Which--- needs to be just inside the planes in order for the boundary to be inside the planes.-instance Intersectable Boundary MinExtentPlanes where-    intersects b (MinExtentPlanes (min_x, min_y)) =-        let (_, (b_max_x, b_max_y)) = boundary_extents b-        in (b_max_x > min_x) && (b_max_y > min_y)--intersection :: Boundary -> MinExtentPlanes -> Boundary-intersection (Boundary p size) (MinExtentPlanes min_p) = Boundary (ext_max min_p p) size--instance Intersectable Boundary LineSegment where-   intersects b l@(p0, p1) =--- If any point of the line segment is contained in the boundary then the line segment intersects the--- element.-       intersects b p0 || intersects b p1--- If niether point is in the element the line segment could still intersect the boundary. The line--- segment must, in this case, intersect an edge of the boundary.-       || any (intersects l) (boundary_edges b)----The equations for line intersection are pulled from ---  http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/--- without much thought.--instance Intersectable LineSegment LineSegment where-   intersects (p0a, p0b) (p1a, p1b) = -       let x1 = vx p0a-           y1 = vy p0a-           x2 = vx p0b-           y2 = vy p0b-           x3 = vx p1a-           y3 = vy p1a-           x4 = vx p1b-           y4 = vy p1b-           div = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1)-       in if div < 1e-9 -           then False-           else-           let t0n = (x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3)-               t0 = t0n / div-               t1n = (x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3)-               t1 = t1n / div-           in t0 > 0.0 && t0 < 1.0 && t1 > 0.0 && t1 < 1.0--union_boundaries :: Boundary -> Boundary -> Boundary-union_boundaries b0 b1 =-    let (min0, max0) = boundary_extents b0-        (min1, max1) = boundary_extents b1-        p = ext_min min0 min1-        ext = ext_max max0 max1-        (w,h) = ext ^-^ p-        size = max w h-    in Boundary p size--ext_min (x0,y0) (x1,y1) = (min x0 x1, min y0 y1)-ext_max (x0,y0) (x1,y1) = (max x0 x1, max y0 y1)----instance Show Boundary where---    show (Boundary p size) = show p ++ " -> " ++ show size--instance Intersectable Boundary (Vertex2 Double) where-    intersects bounds (px, py) =-        let (x, y) = boundary_corner bounds-            s = boundary_size bounds-        in px < (x + s) && px >= x && py < (y + s) && py >= y--class HasBoundary s where-    boundary_points :: s -> [Vertex2 Double]-    boundary_edges :: s -> [Edge2 Double]-    boundary_edges s = -        let ps@(p0 : ps') = boundary_points s-        in zip ps (ps' ++ [p0])-    boundary_extents :: s -> (Vertex2 Double, Vertex2 Double)-    boundary_extents s =-        let (p0 : ps) = boundary_points s-            initial_min_extent = p0-            initial_max_extent = p0-            union_extents ((min_x, min_y), (max_x,max_y)) (x, y) =-                let min_x' = min min_x x-                    min_y' = min min_y y-                    max_x' = max max_x x-                    max_y' = max max_y y-                in ((min_x', min_y'), (max_x', max_y'))-        in foldl' union_extents (initial_min_extent, initial_max_extent) ps-    boundary_square :: s -> Boundary-    boundary_square s =-        let (min_extent, max_extent) = boundary_extents s-            width  = fst max_extent - fst min_extent-            height = snd max_extent - snd min_extent-            size = max width height-        in Boundary (fst min_extent, snd min_extent) size---- A boundary cleary has itself as it's boundary.-instance HasBoundary Boundary where-    boundary_points (Boundary p s) = -        [ p-        , p ^+^ (0, s)-        , p ^+^ (s, s)-        , p ^+^ (s, 0)-        ]-    boundary_extents (Boundary p s) = (p, p ^+^ (s,s))-    boundary_square b = b-

@@ -1,12 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module System.Random.Utils where-import System.Random.Mersenne--randomElement a gen = do-    v :: Double <- random gen-    let i :: Int = floor $ v * (fromIntegral $ length a)-    return $ a !! i--randomRange low high gen = do-    v <- random gen-    return $ low * (1 - v) + high * v

@@ -3,7 +3,7 @@  import Data.QuadTree -import Math.Geometry+import Data.AABB  import Render ( init_display               , new_viewer@@ -20,25 +20,31 @@ import System.Random.Mersenne import System.Random.Utils -q :: QuadTree Boundary = empty-e0 = Boundary (1.0, 1.0) 2.0-e1 = Boundary (0.0, 0.0) 0.5- main = do      (viewer, _) <- new_viewer-    let q' = insert e0 q-    let q'' = insert e1 q'     gen <- newMTGen Nothing-    (rq, gen) <- random_quadtree gen q 2000+    (rq, gen) <- random_quadtree gen (empty :: QuadTree Elem) 5     view_quadtree viewer gen rq     return () +data Elem = Elem Boundary (Color3 Double)++instance HasBoundary Elem where+    boundary_points (Elem b _) = boundary_points b+    boundary_edges (Elem b _) = boundary_edges b+    boundary_extents (Elem b _) = boundary_extents b+    boundary_square (Elem b _) = boundary_square b+ random_quadtree gen q 0 = return (q, gen) random_quadtree gen q n = do     x :: Double <- randomRange (-10.0) 10.0 gen     y :: Double <- randomRange (-10.0) 10.0 gen     s :: Double <- randomRange 0.001 1.0 gen-    let e = Boundary (x, y) s+    let eb = Boundary (x, y) s+    r :: Double <- randomRange 0.0 1.0 gen+    g :: Double <- randomRange 0.0 1.0 gen+    b :: Double <- randomRange 0.0 1.0 gen+    let e = Elem eb (Color3 r g b)     let q' = insert e q     random_quadtree gen q' (n - 1)     @@ -57,9 +63,9 @@     -- Scale the entire quadtree to the display.     scale (1.0 / bsize) (1.0 / bsize) 1.0     translate $ Vector3 (-bx) (-by) 0.0-    mondrian_quadtree gen q     lineWidth $= 2.0-    maybe_outline_quadtree gen q+    render_elements q+    outline_quadtree q     flush  outline_quadtree q = do@@ -71,42 +77,15 @@             mapM_ (maybe (return ()) $ \cq -> outline_quadtree' cq) [cq0, cq1, cq2, cq3]             render_boundary b -maybe_outline_quadtree gen q = do-    color $ Color3 (0.0 :: Float) 0.0 0.0-    polygonMode $= (Line, Line)-    renderPrimitive Lines $ outline_quadtree' q-    where -        outline_quadtree' (QuadTree _ b (cq0, cq1, cq2, cq3)) = do-            mapM_ (maybe (return ()) $ \cq -> outline_quadtree' cq) [cq0, cq1, cq2, cq3]-            mapM_ maybe_render_edge (boundary_edges b)-        maybe_render_edge ((x0,y0), (x1,y1)) = do-            p <- flip randomElement gen $ True : replicate 6 False-            if p then vertex (Vertex2 x0 y0) >> vertex (Vertex2 x1 y1)-                 else return ()--outline_elements q = do-    color $ Color3 (1.0 :: Float) 0.0 0.0-    polygonMode $= (Line, Line)+render_elements q = do+    polygonMode $= (Fill, Fill)     renderPrimitive Quads $ outline_elements' q     where-        outline_elements' (QuadTree bs _ (cq0, cq1, cq2, cq3)) = do+        outline_elements' (QuadTree es _ (cq0, cq1, cq2, cq3)) = do             mapM_ (maybe (return ()) $ \cq -> outline_elements' cq) [cq0, cq1, cq2, cq3]-            mapM_ render_boundary bs--mondrian_quadtree gen q = do-    polygonMode $= (Fill, Line)-    renderPrimitive Quads $ mondrian_quadtree' gen q-    where-        mondrian_quadtree' gen (QuadTree bs bounds (cq0, cq1, cq2, cq3)) = do-            p <- flip randomElement gen $ True : replicate 2 False-            r :: Double <- randomRange 0.0 1.0 gen-            g :: Double <- randomRange 0.0 1.0 gen-            b :: Double <- randomRange 0.0 1.0 gen-            if p-                then color $ Color3 r g b-                else color $ Color3 (1.0 :: Double) 1.0 1.0-            render_boundary bounds-            mapM_ (maybe (return ()) $ \cq -> mondrian_quadtree' gen cq) [cq0, cq1, cq2, cq3]+            forM_ es $ \(Elem b c) -> do+                color c+                render_boundary b  random_color_gen gen = sequence $ repeat $ do     r :: Double <- randomRange 0.0 1.0 gen

@@ -0,0 +1,12 @@+{-# LANGUAGE ScopedTypeVariables #-}+module System.Random.Utils where+import System.Random.Mersenne++randomElement a gen = do+    v :: Double <- random gen+    let i :: Int = floor $ v * (fromIntegral $ length a)+    return $ a !! i++randomRange low high gen = do+    v <- random gen+    return $ low * (1 - v) + high * v

@@ -0,0 +1,14 @@+module Main where++import Verify.Data.SpacePart.QuadTree+import Verify.Data.SpacePart.AABB+import Test.QuickCheck++main = do+    quickCheck $ label "intersects_is_reflexive_prop" intersects_is_reflexive_prop+    quickCheck $ label "encloses_is_reflexive_prop" encloses_is_reflexive_prop+    quickCheck $ label "element_bounds_query_is_element_prop" element_bounds_query_is_element_prop+    quickCheck $ label "oob_bounds_query_is_empty_prop" oob_bounds_query_is_empty_prop+    quickCheck $ label "all_elements_inserted_query_prop " all_elements_inserted_query_prop +    putStrLn "DONE"+

@@ -0,0 +1,45 @@+module Verify.Data.SpacePart.AABB ( module Verify.Data.SpacePart.AABB+                                  , module Data.SpacePart.AABB+                                  )++    where++import Data.SpacePart.AABB++import Control.Monad+import Test.QuickCheck++instance Arbitrary Boundary where+    arbitrary = do+        corner <- arbitrary+        s <- liftM abs arbitrary+        return $ Boundary corner s++data NonIntersectingBounds = NonIntersectingBounds Boundary Boundary+    deriving (Eq, Show)++{- Two non-intersecting bounds can be generated by generating an arbitrary rectange defined by a min+ - extent and max extent.+ - The min extent is the corner of one boundary, p_0. The max extent is the corner of the other boundary, p_1.+ - The boundary with a corner at p_1 can have any size.+ - While the boundary with a corner at p_0 can not be given a size that could imply a boundary+ - intersection.+ -}+instance Arbitrary NonIntersectingBounds where+    arbitrary = do+        x_0 <- arbitrary+        y_0 <- arbitrary+        x_1 <- arbitrary+        y_1 <- arbitrary+        let p_0 = (min x_0 x_1, min y_0 y_1)+            p_1 = (max x_0 x_1, max y_0 y_1)+        s_0 <- choose (0.0, min (fst p_1 - fst p_0) (snd p_1 - snd p_0))+        s_1 <- arbitrary+        return $ NonIntersectingBounds (Boundary p_0 s_0) (Boundary p_1 s_1)++intersects_is_reflexive_prop :: Boundary -> Bool+intersects_is_reflexive_prop b = b `intersects` b++encloses_is_reflexive_prop :: Boundary -> Bool+encloses_is_reflexive_prop b = b `encloses` b+

@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}+module Verify.Data.SpacePart.QuadTree ( module Data.SpacePart.QuadTree+                                      , module Verify.Data.SpacePart.QuadTree+                                      )+    where++import Data.SpacePart.QuadTree++import Verify.Data.SpacePart.AABB++import Control.Monad+import Data.List hiding (insert)+import Test.QuickCheck++data BoundaryQTConstruction = BoundaryQTConstruction [Boundary] (QuadTree Boundary)+    deriving (Show)++instance Arbitrary BoundaryQTConstruction where+    arbitrary = do+        element_count <- choose (1,100)+        (q, es) <- foldM (\(q, es) _ -> do+                           e <- arbitrary+                           return (insert e q, e : es)+                         ) +                         (empty, []) +                         [1 :: Int .. element_count]+        return $ BoundaryQTConstruction es q++-- All elements inserted into the quadtree should be returned by a query for all elements within the+-- boundaries of the quadtree+all_elements_inserted_query_prop :: BoundaryQTConstruction -> Bool+all_elements_inserted_query_prop (BoundaryQTConstruction es q) = es \\ query (boundary_square q) q == []++element_bounds_query_is_element_prop :: Boundary -> Boundary -> Property+element_bounds_query_is_element_prop initial_bounds element_bounds = +    boundary_size initial_bounds /= 0.0 ==>+    let q = empty_with_bounds initial_bounds+        q' = insert element_bounds q+    in case query element_bounds q' of+        []  -> False+        [e] -> e == element_bounds+        _   -> False++oob_bounds_query_is_empty_prop :: NonIntersectingBounds -> Property+oob_bounds_query_is_empty_prop (NonIntersectingBounds b_0 b_1) = +    boundary_size b_0 /= 0.0 ==>+    let q :: QuadTree Boundary = empty_with_bounds b_0+    in  [] ==  query b_1 q ++-- An easy quadtree to test is one where the elements contained in the quadtree are boundaries.+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) ++ ")"++-}+

@@ -1,7 +0,0 @@-#!/usr/bin/env runhaskell-import System.Console.GetOpt-import System.Cmd-import System.Environment-import Control.Monad--main = system "ghc -O3 --make QuadTreeVisualize.hs && ./QuadTreeVisualize"

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell+import System.Console.GetOpt+import System.Cmd+import System.Environment+import Control.Monad++main = system "ghc -ignore-package data-spacepart -i../src -o VerifyDriver --make Verify.hs && ./VerifyDriver"

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell+import System.Console.GetOpt+import System.Cmd+import System.Environment+import Control.Monad++main = system "ghc -O3 --make QuadTreeVisualize.hs && ./QuadTreeVisualize"