diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. + diff --git a/data-spacepart.cabal b/data-spacepart.cabal --- a/data-spacepart.cabal +++ b/data-spacepart.cabal @@ -1,51 +1,47 @@ Name: data-spacepart -Version: 20090126.0 +Version: 20090215.0 License: BSD3 License-File: LICENSE Author: Corey O'Connor Maintainer: Corey O'Connor -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 diff --git a/src/Data/QuadTree.hs b/src/Data/QuadTree.hs deleted file mode 100644 --- a/src/Data/QuadTree.hs +++ /dev/null @@ -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) ++ ")" - --} diff --git a/src/Data/SpacePart/AABB.hs b/src/Data/SpacePart/AABB.hs new file mode 100644 --- /dev/null +++ b/src/Data/SpacePart/AABB.hs @@ -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) + diff --git a/src/Data/SpacePart/QuadTree.hs b/src/Data/SpacePart/QuadTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/SpacePart/QuadTree.hs @@ -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) + diff --git a/src/Math/Geometry.hs b/src/Math/Geometry.hs deleted file mode 100644 --- a/src/Math/Geometry.hs +++ /dev/null @@ -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 - diff --git a/src/System/Random/Utils.hs b/src/System/Random/Utils.hs deleted file mode 100644 --- a/src/System/Random/Utils.hs +++ /dev/null @@ -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 diff --git a/test/QuadTreeVisualize.hs b/test/QuadTreeVisualize.hs --- a/test/QuadTreeVisualize.hs +++ b/test/QuadTreeVisualize.hs @@ -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 diff --git a/test/System/Random/Utils.hs b/test/System/Random/Utils.hs new file mode 100644 --- /dev/null +++ b/test/System/Random/Utils.hs @@ -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 diff --git a/test/Verify.hs b/test/Verify.hs new file mode 100644 --- /dev/null +++ b/test/Verify.hs @@ -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" + diff --git a/test/Verify/Data/SpacePart/AABB.hs b/test/Verify/Data/SpacePart/AABB.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Data/SpacePart/AABB.hs @@ -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 + diff --git a/test/Verify/Data/SpacePart/QuadTree.hs b/test/Verify/Data/SpacePart/QuadTree.hs new file mode 100644 --- /dev/null +++ b/test/Verify/Data/SpacePart/QuadTree.hs @@ -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) ++ ")" + +-} + diff --git a/test/run_test b/test/run_test deleted file mode 100644 --- a/test/run_test +++ /dev/null @@ -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" diff --git a/test/run_verify b/test/run_verify new file mode 100644 --- /dev/null +++ b/test/run_verify @@ -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" diff --git a/test/run_visualize b/test/run_visualize new file mode 100644 --- /dev/null +++ b/test/run_visualize @@ -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"