data-spacepart 0.1.1 → 20090126.0

raw patch · 11 files changed

+328/−483 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• data-spacepart.cabal +20/−9
• src/Data/AABB.hs +0/−193
• src/Data/QuadTree.hs +90/−124
• src/Math/Geometry.hs +167/−0
• test/QuadTreeVisualize.hs +44/−23
• test/Verify.hs +0/−14
• test/Verify/Data/AABB.hs +0/−45
• test/Verify/Data/QuadTree.hs +0/−61
• test/run_test +7/−0
• test/run_verify +0/−7
• test/run_visualize +0/−7

@@ -1,5 +1,5 @@ Name:           data-spacepart-Version:        0.1.1+Version:        20090126.0 License:        BSD3 License-File:   LICENSE Author:         Corey O'Connor <coreyoconnor@gmail.com>@@ -13,21 +13,32 @@ Description:     Space partition data structures. Currently only a QuadTree.     .-    darcs get --partial http:\/\/code.haskell.org\/data-spacepart\/+    darcs get --partial http://www.tothepowerofdisco.com/repo/data-spacepart/     .     TODO:     .         lots.+        .+        Move test/QuadTreeVisualize to a separate package.     .-    See README: http:\/\/code.haskell.org\/data-spacepart\/README+    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.      Extra-Source-Files: test/QuadTreeVisualize.hs-                    test/run_visualize+                    test/run_test                     test/Render.hs-                    test/run_verify-                    test/Verify.hs-                    test/Verify/Data/AABB.hs-                    test/Verify/Data/QuadTree.hs  Cabal-Version:  >= 1.6 @@ -35,6 +46,6 @@     hs-source-dirs:         src     build-depends:          base, vector-space == 0.5.*, mersenne-random == 0.1.*     exposed-modules:        Data.QuadTree-                            Data.AABB+                            Math.Geometry                             System.Random.Utils 

@@ -1,193 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-module Data.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)-

@@ -5,44 +5,28 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} module Data.QuadTree where-import Data.AABB+import Math.Geometry  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.---+{- 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 :: (HasBoundary e)-                => [e]+    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 -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@@ -54,12 +38,12 @@       | 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.+{- 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, simplifies things. Maybe?+ - Which, I think, greatly simplifies things?  - EG:  -  let qt = QuadTree.empty  -      qt' = QuadTree.insert qt e0@@ -101,58 +85,11 @@         )      = 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. +{- | Returns an empty QuadTree. Which is centered around (0,0) with a size of 2  -}-empty :: HasBoundary e => QuadTree e+empty :: Intersectable e Boundary => 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                  ) @@ -170,24 +107,23 @@                            , 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.+{- | 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 :: (HasBoundary e) => e -> QuadTree e -> QuadTree e+insert :: (Intersectable e Boundary, HasBoundary e) => e -> QuadTree e -> QuadTree e insert e q =-    if (boundary_square q) `encloses` (boundary_square e)+    if q `encloses` 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+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 filter (\(cqb, _) -> cqb `encloses` (boundary_square e)) (quadrant_bounds q) of+    case intersections e (quadrant_bounds q) of         [child]      -> insert_child child e q          _            -> QuadTree (e : es) bounds quadrants @@ -205,6 +141,12 @@         , (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.   -@@ -237,18 +179,7 @@  -  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+-- 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 @@ -264,7 +195,18 @@     | 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+-- 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 @@ -278,10 +220,11 @@  -  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) +{- 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@@ -290,19 +233,42 @@     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)+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,167 @@+{-# 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+

@@ -3,7 +3,7 @@  import Data.QuadTree -import Data.AABB+import Math.Geometry  import Render ( init_display               , new_viewer@@ -20,31 +20,25 @@ 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 (empty :: QuadTree Elem) 5+    (rq, gen) <- random_quadtree gen q 2000     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 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 e = Boundary (x, y) s     let q' = insert e q     random_quadtree gen q' (n - 1)     @@ -63,9 +57,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-    render_elements q-    outline_quadtree q+    maybe_outline_quadtree gen q     flush  outline_quadtree q = do@@ -77,15 +71,42 @@             mapM_ (maybe (return ()) $ \cq -> outline_quadtree' cq) [cq0, cq1, cq2, cq3]             render_boundary b -render_elements q = do-    polygonMode $= (Fill, Fill)+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)     renderPrimitive Quads $ outline_elements' q     where-        outline_elements' (QuadTree es _ (cq0, cq1, cq2, cq3)) = do+        outline_elements' (QuadTree bs _ (cq0, cq1, cq2, cq3)) = do             mapM_ (maybe (return ()) $ \cq -> outline_elements' cq) [cq0, cq1, cq2, cq3]-            forM_ es $ \(Elem b c) -> do-                color c-                render_boundary b+            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]  random_color_gen gen = sequence $ repeat $ do     r :: Double <- randomRange 0.0 1.0 gen

@@ -1,14 +0,0 @@-module Main where--import Verify.Data.QuadTree-import Verify.Data.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"-

@@ -1,45 +0,0 @@-module Verify.Data.AABB ( module Verify.Data.AABB-                        , module Data.AABB-                        )--    where--import Data.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-

@@ -1,61 +0,0 @@-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}-module Verify.Data.QuadTree ( module Data.QuadTree-                            , module Verify.Data.QuadTree-                            )-    where--import Data.QuadTree--import Verify.Data.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) ++ ")"---}-

@@ -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"

@@ -1,7 +0,0 @@-#!/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"

@@ -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"