├── .gitignore ├── Data ├── QuadTree.hs └── QuadTree │ └── Internal.hs ├── LICENSE ├── QuadTree.cabal ├── README.md ├── Setup.hs ├── Test └── quadtree-tests.hs ├── hackage-upload-docs.sh └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | /Data/QuadTree/#Internal.hs# 2 | /Data/QuadTree/.#Internal.hs 3 | /Test/#quadtree-tests.hs# 4 | .stack-work 5 | *#* 6 | -------------------------------------------------------------------------------- /Data/QuadTree.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | 3 | {-# LANGUAGE Safe #-} 4 | 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | {-| 9 | Module : Data.QuadTree 10 | Description : Region quadtrees with lens support. 11 | Copyright : (c) Ashley Moni, 2015 12 | License : BSD3 13 | Maintainer : Ashley Moni 14 | Stability : Stable 15 | 16 | The purpose of this module is to provide discrete region quadtrees 17 | that can be used as simple functional alternatives to 2D arrays, 18 | with lens support. 19 | 20 | @ 21 | test = set ('atLocation' (0,0)) \'d\' $ 22 | set ('atLocation' (5,5)) \'c\' $ 23 | set ('atLocation' (3,2)) \'b\' $ 24 | set ('atLocation' (2,4)) \'a\' $ 25 | 'makeTree' (6,6) \'.\' 26 | @ 27 | 28 | >>> printTree id test 29 | d..... 30 | ...... 31 | ...b.. 32 | ...... 33 | ..a... 34 | .....c 35 | -} 36 | 37 | module Data.QuadTree ( 38 | -- * Data Type & Constructor 39 | QuadTree, makeTree, 40 | -- * Index access 41 | -- $locations 42 | Location, atLocation, getLocation, setLocation, mapLocation, 43 | -- * Functor 44 | fuseTree, tmap, 45 | -- * Foldable 46 | -- $foldables 47 | filterTree, sortTreeBy, 48 | -- ** Tiles 49 | -- $tiles 50 | Region, Tile, 51 | -- ** Tile functions 52 | -- $tileuse 53 | tile, expand, foldTiles, 54 | filterTiles, sortTilesBy, 55 | -- * Printers 56 | showTree, printTree, 57 | -- * Miscellaneous helpers 58 | outOfBounds, treeDimensions, regionArea, inRegion ) where 59 | 60 | import Data.QuadTree.Internal 61 | 62 | 63 | -- $locations 64 | -- This provides an array-style interface to the 'QuadTree', albeit 65 | -- with an O(log n) lookup and insertion speed. This is both faster 66 | -- and slower than an actual array (O(1) lookup and O(n) insertion 67 | -- respectively). 68 | -- 69 | -- The user can imagine a two dimensional grid that can be modified 70 | -- or queried via co-ordinate pair indices. 71 | 72 | 73 | -- $foldables 74 | -- 'QuadTree's can be folded just like lists. If you simply replace 75 | -- the "Prelude" fold functions with "Data.Foldable" ones... 76 | -- 77 | -- @ 78 | -- import "Data.Foldable" 79 | -- import "Prelude" hiding (foldr, foldl, any, sum, find...) 80 | -- @ 81 | -- 82 | -- ... Then you can directly call them on 'QuadTree's without 83 | -- qualification. No list functionality will be lost since the 84 | -- "Data.Foldable" functions also work exactly like the "Prelude" 85 | -- folds for list processing. 86 | -- 87 | -- In addition you also get some extras like 'Data.Foldable.toList'. 88 | 89 | 90 | -- $tiles 91 | -- Directly folding a 'QuadTree' will expand it into a sequence of 92 | -- elements that are then folded over. For some types of operations 93 | -- this can be incredibly inefficient; it may be faster to simply 94 | -- manipulate a sequence of leaves and then later decompose the 95 | -- results into a list of elements. 96 | -- 97 | -- For these operations, we can use 'Tile's. 'Tile's are simply 98 | -- blocks of elements, represented by a tuple of the leaf data and 99 | -- some information on the spatial location and dimensions of the 100 | -- block. 101 | 102 | 103 | -- $tileuse 104 | -- The bread and butter method of manipulating 'Tile's is to first 105 | -- decompose a 'QuadTree' with 'tile', process the intermediate 106 | -- representation, and then decompose it into a final list of elements 107 | -- with 'expand'. 108 | -- 109 | -- @ 110 | -- 'expand' . fn . 'tile' $ tree 111 | -- @ 112 | 113 | -------------------------------------------------------------------------------- /Data/QuadTree/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | 3 | {-# LANGUAGE Safe #-} 4 | 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | {-| 9 | Module : Data.QuadTree.Internal 10 | Description : Internals for the Data.QuadTree library. 11 | Copyright : (c) Ashley Moni, 2015 12 | License : BSD3 13 | Maintainer : Ashley Moni 14 | Stability : Stable 15 | 16 | The QuadTree.Internals library is a separately encapsulated subset of 17 | the QuadTree library, strictly for the purpose of exposing inner 18 | structure and functions to the testing suites. 19 | |-} 20 | 21 | module Data.QuadTree.Internal where 22 | 23 | import Control.Lens.Type (Lens') 24 | import Control.Lens.Setter (over, set) 25 | import Control.Lens.Getter (view) 26 | 27 | import Data.List (find, sortBy) 28 | import Data.Function (on) 29 | import Data.Composition ((.:)) 30 | 31 | ---- Structures: 32 | 33 | -- |Tuple corresponds to (X, Y) co-ordinates. 34 | 35 | type Location = (Int, Int) 36 | 37 | -- |The eponymous data type. 38 | -- 39 | -- 'QuadTree' is itself a wrapper around an internal tree structure 40 | -- along with spatial metadata about the boundaries and depth of the 41 | -- 2D area it maps to. 42 | 43 | data QuadTree a = Wrapper { wrappedTree :: Quadrant a 44 | , treeLength :: Int 45 | , treeWidth :: Int 46 | , treeDepth :: Int } 47 | deriving (Show, Read, Eq) 48 | 49 | -- |'QuadTree's are 'Functor's, and their elements can be fmapped over. 50 | instance Functor QuadTree where 51 | fmap fn = onQuads $ fmap fn 52 | 53 | -- |'QuadTree's are 'Foldable', though the traversal path is a complex 54 | -- recursive enumeration of internal 'Quadrant's. Don't use folds that aren't 55 | -- ordering agnostic. 56 | instance Foldable QuadTree where 57 | foldr = foldTree 58 | 59 | -- Quadrants: 60 | 61 | -- |The internal data structure of a 'QuadTree'. 62 | -- 63 | -- Each 'Quadrant' consists of either a terminating Leaf node, or 64 | -- four further 'Quadrant's. 65 | 66 | data Quadrant a = Leaf a 67 | | Node (Quadrant a) 68 | (Quadrant a) 69 | (Quadrant a) 70 | (Quadrant a) 71 | deriving (Show, Read, Eq) 72 | 73 | -- |'Quadrant's are 'Functor's. -- You can fmap all their recursive leaf node. 74 | instance Functor Quadrant where 75 | fmap fn (Leaf x) = Leaf (fn x) 76 | fmap fn (Node a b c d) = Node (fmap fn a) 77 | (fmap fn b) 78 | (fmap fn c) 79 | (fmap fn d) 80 | 81 | 82 | instance Applicative Quadrant where 83 | pure = Leaf 84 | Leaf f <*> Leaf x = Leaf $ f x 85 | f@Leaf {} <*> Node a b c d = 86 | Node (f <*> a) (f <*> b) (f <*> c) (f <*> d) 87 | Node fa fb fc fd <*> x@Leaf {} = 88 | Node (fa <*> x) (fb <*> x) (fc <*> x) (fd <*> x) 89 | Node fa fb fc fd <*> Node a b c d = 90 | Node (fa <*> a) (fb <*> b) (fc <*> c) (fd <*> d) 91 | 92 | 93 | instance Monad Quadrant where 94 | return = pure 95 | Leaf a >>= f = f a 96 | Node a b c d >>= f = Node (a >>= f) (b >>= f) (c >>= f) (d >>= f) 97 | 98 | 99 | ---- Quadrant lenses: 100 | 101 | -- |Lens for the top left 'Quadrant' of a node. 102 | _a :: forall a. Eq a => Lens' (Quadrant a) (Quadrant a) 103 | _a f (Node a b c d) = fmap (\x -> fuse $ Node x b c d) (f a) 104 | _a f leaf = fmap embed (f leaf) 105 | where embed :: Quadrant a -> Quadrant a 106 | embed x | x == leaf = leaf 107 | | otherwise = Node x leaf leaf leaf 108 | 109 | -- |Lens for the top right 'Quadrant' of a node. 110 | _b :: forall a. Eq a => Lens' (Quadrant a) (Quadrant a) 111 | _b f (Node a b c d) = fmap (\x -> fuse $ Node a x c d) (f b) 112 | _b f leaf = fmap embed (f leaf) 113 | where embed :: Quadrant a -> Quadrant a 114 | embed x | x == leaf = leaf 115 | | otherwise = Node leaf x leaf leaf 116 | 117 | -- |Lens for the bottom left 'Quadrant' of a node. 118 | _c :: forall a. Eq a => Lens' (Quadrant a) (Quadrant a) 119 | _c f (Node a b c d) = fmap (\x -> fuse $ Node a b x d) (f c) 120 | _c f leaf = fmap embed (f leaf) 121 | where embed :: Quadrant a -> Quadrant a 122 | embed x | x == leaf = leaf 123 | | otherwise = Node leaf leaf x leaf 124 | 125 | -- |Lens for the bottom right 'Quadrant' of a node. 126 | _d :: forall a. Eq a => Lens' (Quadrant a) (Quadrant a) 127 | _d f (Node a b c d) = fmap (fuse . Node a b c) (f d) 128 | _d f leaf = fmap embed (f leaf) 129 | where embed :: Quadrant a -> Quadrant a 130 | embed x | x == leaf = leaf 131 | | otherwise = Node leaf leaf leaf x 132 | 133 | -- |Lens for a terminate leaf value of a node. 134 | _leaf :: Lens' (Quadrant a) a 135 | _leaf f (Leaf leaf) = Leaf <$> f leaf 136 | _leaf _ _ = error "Wrapped tree is deeper than cached tree depth." 137 | 138 | -- |Lens to zoom into the internal data structure of a 'QuadTree', 139 | -- lensing past the metadata to reveal the 'Quadrant' inside. 140 | _wrappedTree :: Lens' (QuadTree a) (Quadrant a) 141 | _wrappedTree f qt = (\x -> qt {wrappedTree = x}) <$> f (wrappedTree qt) 142 | 143 | -- |Unsafe sanity test lens that makes sure a given location index exists 144 | -- within the relevant 'QuadTree'. 145 | verifyLocation :: Location -> Lens' (QuadTree a) (QuadTree a) 146 | verifyLocation index f qt 147 | | index `outOfBounds` qt = error "Location index out of QuadTree bounds." 148 | | otherwise = f qt 149 | 150 | ---- Index access: 151 | 152 | -- |Lens for accessing and manipulating data at a specific 153 | -- location. 154 | atLocation :: forall a. Eq a => Location -> Lens' (QuadTree a) a 155 | atLocation index fn qt = (verifyLocation index . _wrappedTree . 156 | go (offsetIndex qt index) (treeDepth qt)) fn qt 157 | where 158 | go :: Eq a => Location -> Int -> Lens' (Quadrant a) a 159 | go _ 0 = _leaf 160 | go (x,y) n | y < mid = if x < mid then _a . recurse 161 | else _b . recurse 162 | | otherwise = if x < mid then _c . recurse 163 | else _d . recurse 164 | where recurse = go (x `mod` mid, y `mod` mid) (n - 1) 165 | mid = 2 ^ (n - 1) 166 | 167 | -- |Getter for the value at a given location for a 'QuadTree'. 168 | getLocation :: Eq a => Location -> QuadTree a -> a 169 | getLocation = view . atLocation 170 | 171 | -- |Setter for the value at a given location for a 'QuadTree'. 172 | -- 173 | -- This automatically compresses the 'QuadTree' nodes if possible with 174 | -- the new value. 175 | setLocation :: Eq a => Location -> a -> QuadTree a -> QuadTree a 176 | setLocation = set . atLocation 177 | 178 | -- |Modifies value at a given location for a 'QuadTree'. 179 | -- 180 | -- This automatically compresses the 'QuadTree' nodes if possible with 181 | -- the new value. 182 | mapLocation :: Eq a => Location -> (a -> a) -> QuadTree a -> QuadTree a 183 | mapLocation = over . atLocation 184 | 185 | ---- Helpers: 186 | 187 | -- |Checks if a 'Location' is outside the boundaries of a 'QuadTree'. 188 | outOfBounds :: Location -> QuadTree a -> Bool 189 | outOfBounds (x,y) tree = x < 0 || y < 0 190 | || x >= treeLength tree 191 | || y >= treeWidth tree 192 | 193 | -- |Dimensions of a 'QuadTree', as an Int pair. 194 | treeDimensions :: QuadTree a 195 | -> (Int, Int) -- ^ (Length, Width) 196 | treeDimensions tree = (treeLength tree, treeWidth tree) 197 | 198 | -- |Add offsets to a location index for the purpose of querying 199 | -- the 'QuadTree' 's true reference frame. 200 | offsetIndex :: QuadTree a -> Location -> Location 201 | offsetIndex tree (x,y) = (x + xOffset, y + yOffset) 202 | where (xOffset, yOffset) = offsets tree 203 | 204 | -- |Offsets added to a 'QuadTree' 's true reference frame 205 | -- to reference elements in the centralized width and height. 206 | offsets :: QuadTree a -> (Int, Int) 207 | offsets tree = (xOffset, yOffset) 208 | where xOffset = (dimension - treeLength tree) `div` 2 209 | yOffset = (dimension - treeWidth tree) `div` 2 210 | dimension = 2 ^ treeDepth tree 211 | 212 | -- |Merge 'Quadrant' into a leaf node if possible. 213 | fuse :: Eq a => Quadrant a -> Quadrant a 214 | fuse (Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)) 215 | | allEqual [a,b,c,d] = Leaf a 216 | fuse oldNode = oldNode 217 | 218 | -- |Test if all elements in a list are equal. 219 | allEqual :: Eq a => [a] -> Bool 220 | allEqual = and . (zipWith (==) <*> tail) 221 | 222 | ---- Functor: 223 | 224 | -- |Apply a function to a 'QuadTree's internal 'Quadrant'. 225 | onQuads :: (Quadrant a -> Quadrant b) -> QuadTree a -> QuadTree b 226 | onQuads fn tree = tree {wrappedTree = fn (wrappedTree tree)} 227 | 228 | -- |Cleanup function for use after any 'Control.Monad.fmap'. 229 | -- 230 | -- When elements of a 'QuadTree' are modified by 'setLocation' (or 231 | -- the 'atLocation' lens), it automatically compresses identical 232 | -- adjacent nodes into larger ones. This keeps the 'QuadTree' from 233 | -- bloating over constant use. 234 | -- 235 | -- 'Control.Monad.fmap' does not do this. If you wish to treat the 236 | -- 'QuadTree' as a 'Control.Monad.Functor', you should compose this 237 | -- function after to collapse it down to its minimum size. 238 | -- 239 | -- Example: 240 | -- @ 241 | -- 'fuseTree' $ 'Control.Monad.fmap' fn tree 242 | -- @ 243 | -- This particular example is reified in the function below. 244 | 245 | fuseTree :: Eq a => QuadTree a -> QuadTree a 246 | fuseTree = onQuads fuseQuads 247 | where fuseQuads :: Eq a => Quadrant a -> Quadrant a 248 | fuseQuads (Node a b c d) = fuse $ Node (fuseQuads a) 249 | (fuseQuads b) 250 | (fuseQuads c) 251 | (fuseQuads d) 252 | fuseQuads leaf = leaf 253 | 254 | -- |tmap is simply 'Control.Monad.fmap' with 'fuseTree' applied after. 255 | -- 256 | -- prop> tmap fn tree == fuseTree $ fmap fn tree 257 | tmap :: Eq b => (a -> b) -> QuadTree a -> QuadTree b 258 | tmap = fuseTree .: fmap 259 | 260 | ---- Foldable: 261 | 262 | -- |Rectangular area, represented by a tuple of four Ints. 263 | -- 264 | -- They correspond to (X floor, Y floor, X ceiling, Y ceiling). 265 | -- 266 | -- The co-ordinates are inclusive of all the rows and columns in all 267 | -- four Ints. 268 | -- 269 | -- prop> regionArea (x, y, x, y) == 1 270 | 271 | type Region = (Int, Int, Int, Int) 272 | 273 | -- |Each 'Tile' is a tuple of an element from a 'QuadTree' and the 274 | -- 'Region' it subtends. 275 | 276 | type Tile a = (a, Region) 277 | 278 | -- |Foldr elements within a 'QuadTree', by first decomposing it into 279 | -- 'Tile's and then decomposing those into lists of identical data values. 280 | 281 | foldTree :: (a -> b -> b) -> b -> QuadTree a -> b 282 | foldTree fn z = foldr fn z . expand . tile 283 | 284 | -- |Takes a list of 'Tile's and then decomposes them into a list of 285 | -- all their elements, properly weighted by 'Tile' size. 286 | 287 | expand :: [Tile a] -> [a] 288 | expand = concatMap decompose 289 | where decompose :: Tile a -> [a] 290 | decompose (a, r) = replicate (regionArea r) a 291 | 292 | -- |Returns a list of 'Tile's. The block equivalent of 293 | -- 'Data.Foldable.toList'. 294 | 295 | tile :: QuadTree a -> [Tile a] 296 | tile = foldTiles (:) [] 297 | 298 | -- |Decomposes a 'QuadTree' into its constituent 'Tile's, before 299 | -- folding a 'Tile' consuming function over all of them. 300 | 301 | foldTiles :: forall a b. (Tile a -> b -> b) -> b -> QuadTree a -> b 302 | foldTiles fn z tree = go (treeRegion tree) (wrappedTree tree) z 303 | where go :: Region -> Quadrant a -> b -> b 304 | go r (Leaf a) = fn (a, normalizedIntersection) 305 | where normalizedIntersection = 306 | (interXl - xOffset, interYt - yOffset, 307 | interXr - xOffset, interYb - yOffset) 308 | (interXl, interYt, interXr, interYb) = 309 | treeIntersection r 310 | go (xl, yt, xr, yb) (Node a b c d) = 311 | go (xl, yt, midx, midy) a . 312 | go (midx + 1, yt, xr, midy) b . 313 | go (xl, midy + 1, midx, yb) c . 314 | go (midx + 1, midy + 1, xr, yb) d 315 | where midx = (xr + xl) `div` 2 316 | midy = (yt + yb) `div` 2 317 | 318 | (xOffset, yOffset) = offsets tree 319 | treeIntersection = regionIntersection $ boundaries tree 320 | 321 | -- |The region denoting an entire 'QuadTree'. 322 | treeRegion :: QuadTree a -> Region 323 | treeRegion tree = (0, 0, limit, limit) 324 | where limit = (2 ^ treeDepth tree) - 1 325 | 326 | -- |The boundary 'Region' of the internal 'QuadTree' 's true reference frame. 327 | boundaries :: QuadTree a -> Region 328 | boundaries tree = (left, top, right, bottom) 329 | where (left, top) = offsetIndex tree (0,0) 330 | (right, bottom) = offsetIndex tree (treeLength tree - 1, 331 | treeWidth tree - 1) 332 | 333 | -- |'Region' that's an intersection between two othe 'Region's. 334 | regionIntersection :: Region -> Region -> Region 335 | regionIntersection (xl , yt , xr , yb ) 336 | (xl', yt', xr', yb') = 337 | (max xl xl', max yt yt', 338 | min xr xr', min yb yb') 339 | 340 | -- |Simple helper function that lets you calculate the area of a 341 | -- 'Region', usually for 'Data.List.replicate' purposes. 342 | 343 | regionArea :: Region -> Int 344 | regionArea (xl,yt,xr,yb) = (xr + 1 - xl) * (yb + 1 - yt) 345 | 346 | -- |Does the region contain this location? 347 | 348 | inRegion :: Location -> Region -> Bool 349 | inRegion (x,y) (xl,yt,xr,yb) = xl <= x && x <= xr && 350 | yt <= y && y <= yb 351 | 352 | ---- Foldable extras: 353 | 354 | -- |'Data.List.filter's a list of the 'QuadTree' 's elements. 355 | 356 | filterTree :: (a -> Bool) -> QuadTree a -> [a] 357 | filterTree fn = expand . filterTiles fn . tile 358 | 359 | -- |'Data.List.sortBy's a list of the 'QuadTree' 's elements. 360 | 361 | sortTreeBy :: (a -> a -> Ordering) -> QuadTree a -> [a] 362 | sortTreeBy fn = expand . sortTilesBy fn . tile 363 | 364 | -- |'Data.List.filter's a list of the 'Tile's of a 'QuadTree'. 365 | 366 | filterTiles :: (a -> Bool) -> [Tile a] -> [Tile a] 367 | filterTiles _ [] = [] 368 | filterTiles fn ((a,r) : rs) 369 | | fn a = (a,r) : filterTiles fn rs 370 | | otherwise = filterTiles fn rs 371 | 372 | -- |'Data.List.sortBy's a list of the 'Tile's of a 'QuadTree'. 373 | 374 | sortTilesBy :: (a -> a -> Ordering) -> [Tile a] -> [Tile a] 375 | sortTilesBy fn = sortBy (fn `on` fst) 376 | 377 | ---- Constructor: 378 | 379 | -- |Constructor that generates a 'QuadTree' of the given dimensions, 380 | -- with all cells filled with a default value. 381 | 382 | makeTree :: (Int, Int) -- ^ (Length, Width) 383 | -> a -- ^ Initial element to fill 384 | -> QuadTree a 385 | makeTree (x,y) a 386 | | x <= 0 || y <= 0 = error "Invalid dimensions for tree." 387 | | otherwise = Wrapper { wrappedTree = Leaf a 388 | , treeLength = x 389 | , treeWidth = y 390 | , treeDepth = smallestDepth (x,y) } 391 | 392 | -- |Find the smallest tree depth that would encompass a given width and height. 393 | smallestDepth :: (Int, Int) -> Int 394 | smallestDepth (x,y) = depth 395 | where (depth, _) = smallestPower 396 | Just smallestPower = find bigEnough powersZip 397 | bigEnough (_, e) = e >= max x y 398 | powersZip = zip [0..] $ iterate (* 2) 1 399 | 400 | ---- Sample Printers: 401 | 402 | -- |Generates a newline delimited string representing a 'QuadTree' as 403 | -- a 2D block of characters. 404 | -- 405 | -- Note that despite the word 'show' in the function name, this does 406 | -- not 'Text.show' the 'QuadTree'. It pretty prints it. The name 407 | -- is simply a mnemonic for its @'QuadTree' -> String@ behaviour. 408 | 409 | showTree :: Eq a => (a -> Char) -- ^ Function to generate characters for each 410 | -- 'QuadTree' element. 411 | -> QuadTree a -> String 412 | showTree printer tree = breakString (treeLength tree) string 413 | where string = map printer grid 414 | grid = [getLocation (x,y) tree | 415 | y <- [0 .. treeWidth tree - 1], 416 | x <- [0 .. treeLength tree - 1]] 417 | breakString :: Int -> String -> String 418 | breakString _ [] = [] 419 | breakString n xs = a ++ "\n" ++ breakString n b 420 | where (a,b) = splitAt n xs 421 | 422 | -- |As 'showTree' above, but also prints it. 423 | 424 | printTree :: Eq a => (a -> Char) -- ^ Function to generate characters for each 425 | -- 'QuadTree' element. 426 | -> QuadTree a -> IO () 427 | printTree = putStr .: showTree 428 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Ashley Moni 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * The names of the contributors may not be used to endorse or promote products 12 | derived from this software without specific prior written permission. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 18 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /QuadTree.cabal: -------------------------------------------------------------------------------- 1 | -- Initial QuadTree.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: QuadTree 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.11.0 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: QuadTree library for Haskell, with lens support. 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | description: The purpose of this package is to provide discrete region quadtrees that can be used as effective functional alternatives to 2D arrays, with lens support. 21 | 22 | -- The license under which the package is released. 23 | license: BSD3 24 | 25 | -- The file containing the license text. 26 | license-file: LICENSE 27 | 28 | -- The package author(s). 29 | author: Ashley Moni 30 | 31 | -- An email address to which users can send suggestions, bug reports, and 32 | -- patches. 33 | maintainer: ashley.moni1@gmail.com 34 | 35 | -- A copyright notice. 36 | -- copyright: 37 | 38 | category: Data, Game 39 | 40 | build-type: Simple 41 | 42 | -- Constraint on the version of Cabal needed to build this package. 43 | cabal-version: >= 1.10 44 | 45 | 46 | library 47 | -- Modules exported by the library. 48 | exposed-modules: Data.QuadTree 49 | 50 | -- Modules included in this library but not exported. 51 | other-modules: Data.QuadTree.Internal 52 | 53 | -- Other library packages from which modules are imported. 54 | build-depends: base >= 4.6 && < 5, 55 | lens >= 4.1 && < 4.16, 56 | composition ==1.0.* 57 | 58 | -- http://www.vex.net/~trebla/haskell/cabal-cabal.xhtml 59 | default-language: Haskell2010 60 | 61 | Test-Suite quadtree-tests 62 | type: exitcode-stdio-1.0 63 | main-is: Test/quadtree-tests.hs 64 | build-depends: base, lens, composition, QuickCheck 65 | default-language: Haskell2010 66 | 67 | source-repository head 68 | type: git 69 | location: git@github.com:AshleyMoni/QuadTree.git 70 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | QuadTree 2 | ======== 3 | 4 | QuadTree library for Haskell, with lens support built in. 5 | 6 | You can find documentation for the library [here](https://hackage.haskell.org/package/QuadTree-0.11.0/docs/Data-QuadTree.html)! -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Test/quadtree-tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main where 6 | 7 | import Data.QuadTree.Internal 8 | 9 | import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) 10 | import Test.QuickCheck.Modifiers (Positive(..), NonNegative(..)) 11 | import Test.QuickCheck.Gen (Gen, choose, oneof, suchThat, 12 | listOf, infiniteListOf) 13 | import Test.QuickCheck.Property (Property, (==>)) 14 | import Test.QuickCheck.All (quickCheckAll) 15 | 16 | import Text.Show.Functions () 17 | import System.Exit (exitSuccess, exitFailure) 18 | 19 | import Control.Lens.Type (Lens') 20 | import Control.Lens.Setter (set) 21 | import Control.Lens.Getter (view) 22 | import Control.Monad (replicateM) 23 | import Data.Functor ((<$>)) 24 | import Data.Composition ((.:)) 25 | 26 | {- Structure 27 | 28 | The QuadTree type has two structural invariants/constraints: 29 | 30 | 1. The internal raw tree must not be deeper than its 31 | declared depth. 32 | 33 | 2. No branch node can have four leaves that are identical. 34 | These need to be fused into a single leaf node by the algorithms. 35 | 36 | We will acknowledge and manage these invariants by constructing 37 | two separate Arbitrary generators for QuadTrees: 38 | 39 | 1. The first generator will construct QuadTrees strictly using the 40 | exposed API (makeTree and setLocation). We'll use this to test if 41 | the invariant is consistently maintained across the subset of QuadTrees 42 | that the user can construct. 43 | 44 | 2. The second generator will generate QuadTrees ex nihilo that obey 45 | the invariants. We'll use this for our primary testing purposes, since 46 | it can theoretically generate valid non-user-constructable trees and 47 | because it can generate large complex trees far far more efficiently. 48 | 49 | -} 50 | 51 | ---- The API-constructable QuadTree generator 52 | 53 | newtype APITree a = Constructed (QuadTree a) 54 | 55 | instance Show a => Show (APITree a) where 56 | show (Constructed qt) = show qt 57 | 58 | instance (Eq a, Arbitrary a) => Arbitrary (APITree a) where 59 | arbitrary = do 60 | Positive len <- arbitrary 61 | Positive wid <- arbitrary 62 | baseValue <- arbitrary 63 | let baseTree = makeTree (len, wid) baseValue 64 | 65 | indices <- listOf $ generateIndexOf baseTree 66 | values <- infiniteListOf arbitrary 67 | let setList = zip indices values 68 | 69 | return . Constructed $ foldr (uncurry setLocation) baseTree setList 70 | 71 | -- Generates a random valid location index for a quadtree 72 | generateIndexOf :: QuadTree a -> Gen Location 73 | generateIndexOf qt = do 74 | x <- choose (0, treeLength qt - 1) 75 | y <- choose (0, treeWidth qt - 1) 76 | return (x,y) 77 | 78 | 79 | ---- Ex-nihilo QuadTree generator 80 | 81 | newtype GenTree a = Generated (QuadTree a) 82 | 83 | instance Show a => Show (GenTree a) where 84 | show (Generated qt) = show qt 85 | 86 | instance (Eq a, Arbitrary a) => Arbitrary (GenTree a) where 87 | arbitrary = do 88 | Positive len <- arbitrary 89 | Positive wid <- arbitrary 90 | let depth = smallestDepth (len, wid) 91 | tree <- generateQuadrant depth 92 | 93 | return . Generated $ Wrapper { treeLength = len, 94 | treeWidth = wid, 95 | treeDepth = depth, 96 | wrappedTree = tree } 97 | 98 | generateQuadrant :: (Eq a, Arbitrary a) => Int -> Gen (Quadrant a) 99 | generateQuadrant 0 = generateLeaf 100 | generateQuadrant n = oneof [generateLeaf, generateNode (n - 1)] 101 | 102 | generateLeaf :: Arbitrary a => Gen (Quadrant a) 103 | generateLeaf = Leaf <$> arbitrary 104 | 105 | generateNode :: (Eq a, Arbitrary a) => Int -> Gen (Quadrant a) 106 | generateNode n = do 107 | [a,b,c,d] <- replicateM 4 (generateQuadrant n) `suchThat` (not . equalLeaves) 108 | return (Node a b c d) 109 | where equalLeaves :: Eq a => [Quadrant a] -> Bool 110 | equalLeaves [Leaf a, Leaf b, Leaf c, Leaf d] = allEqual [a,b,c,d] 111 | equalLeaves _ = False 112 | 113 | 114 | -- Ex-nihilo Quadrant generator 115 | 116 | instance (Eq a, Arbitrary a) => Arbitrary (Quadrant a) where 117 | arbitrary = do 118 | NonNegative depth <- arbitrary 119 | generateQuadrant depth 120 | 121 | ---- General index generator 122 | 123 | -- Ideally, we'd be able to generate random dimensionally valid lenses as 124 | -- part of the arguments to property functions that take quadtrees. 125 | -- But we'd need dependent types for that, so we're just going to generate 126 | -- independent random lenses and only test the ones that would work with 127 | -- the tree. 128 | 129 | newtype Index = MkIndex (Int, Int) 130 | 131 | instance Arbitrary Index where 132 | arbitrary = do 133 | NonNegative x <- arbitrary 134 | NonNegative y <- arbitrary 135 | return $ MkIndex (x,y) 136 | 137 | instance Show Index where 138 | show (MkIndex index) = show index 139 | 140 | 141 | ---- APITree structural tests 142 | 143 | -- We use Bools here since they're the most trivial Eq type. 144 | -- A QuadTree constructed with Bool insertions is the fastest way 145 | -- to build/fuse up a complex set of nodes at various heights. 146 | 147 | -- Inner tree representation cannot be deeper than defined depth 148 | prop_APITreeDepth :: APITree Bool -> Bool 149 | prop_APITreeDepth (Constructed qt) = go (treeDepth qt) (wrappedTree qt) 150 | where go :: Int -> Quadrant a -> Bool 151 | go _ (Leaf _) = True 152 | go 0 _ = False 153 | go n (Node a b c d) = and $ fmap (go (n - 1)) [a,b,c,d] 154 | 155 | -- Inner tree representation cannot have branches holding four equal leaves 156 | prop_APITreeInequality :: APITree Bool -> Bool 157 | prop_APITreeInequality (Constructed qt) = go $ wrappedTree qt 158 | where go :: Eq a => Quadrant a -> Bool 159 | go (Leaf _) = True 160 | go (Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)) 161 | | allEqual [a,b,c,d] = False 162 | go (Node a b c d) = and $ fmap go [a,b,c,d] 163 | 164 | 165 | ---- Ex Nihilo QuadTree tests 166 | 167 | -- For completeness, we'll test the structural requirements here as well. 168 | -- The requirements are baked into the generator, but this lets us test 169 | -- that generator. 170 | 171 | -- Inner tree representation cannot be deeper than defined depth 172 | prop_treeDepth :: GenTree Bool -> Bool 173 | prop_treeDepth (Generated qt) = go (treeDepth qt) (wrappedTree qt) 174 | where go :: Int -> Quadrant a -> Bool 175 | go _ (Leaf _) = True 176 | go 0 _ = False 177 | go n (Node a b c d) = and $ fmap (go (n - 1)) [a,b,c,d] 178 | 179 | -- Inner tree representation cannot have branches holding four equal leaves 180 | prop_treeInequality :: GenTree Bool -> Bool 181 | prop_treeInequality (Generated qt) = go $ wrappedTree qt 182 | where go :: Eq a => Quadrant a -> Bool 183 | go (Leaf _) = True 184 | go (Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)) 185 | | allEqual [a,b,c,d] = False 186 | go (Node a b c d) = and $ fmap go [a,b,c,d] 187 | 188 | {- Functor laws 189 | 190 | fmap id = id 191 | fmap (f . g) = fmap f . fmap g -} 192 | 193 | prop_functor1 :: Eq a => GenTree a -> Bool 194 | prop_functor1 (Generated qt) = fmap id qt == qt 195 | 196 | prop_functor2 :: Eq c => GenTree a -> (b -> c) -> (a -> b) -> Bool 197 | prop_functor2 (Generated qt) f g = fmap (f . g) qt == (fmap f . fmap g) qt 198 | 199 | {- Lens laws 200 | 201 | view l (set l b a) = b 202 | set l (view l a) a = a 203 | set l c (set l b a) = set l c a -} 204 | 205 | prop_lens1 :: Eq a => GenTree a -> a -> Index -> Property 206 | prop_lens1 (Generated a) b (MkIndex location) = 207 | location `validIndexOf` a ==> view l (set l b a) == b 208 | where l :: Eq a => Lens' (QuadTree a) a 209 | l = atLocation location 210 | 211 | prop_lens2 :: Eq a => GenTree a -> Index -> Property 212 | prop_lens2 (Generated a) (MkIndex location) = 213 | location `validIndexOf` a ==> set l (view l a) a == a 214 | where l :: Eq a => Lens' (QuadTree a) a 215 | l = atLocation location 216 | 217 | prop_lens3 :: Eq a => GenTree a -> a -> a -> Index -> Property 218 | prop_lens3 (Generated a) b c (MkIndex location) = 219 | location `validIndexOf` a ==> set l c (set l b a) == set l c a 220 | where l :: Eq a => Lens' (QuadTree a) a 221 | l = atLocation location 222 | 223 | 224 | validIndexOf :: Location -> QuadTree a -> Bool 225 | validIndexOf = not .: outOfBounds 226 | 227 | 228 | ---- Collate and run tests: 229 | 230 | return [] -- Template Haskell splice. See QuickCheck hackage docs. 231 | runTests :: IO Bool 232 | runTests = $quickCheckAll 233 | 234 | main :: IO () 235 | main = do 236 | allClear <- runTests 237 | if allClear 238 | then exitSuccess 239 | else exitFailure 240 | 241 | --------- Manual repl test fragments: 242 | 243 | -- x' :: QuadTree Int 244 | -- x' = Wrapper { treeLength = 6 245 | -- , treeWidth = 5 246 | -- , treeDepth = 3 247 | -- , wrappedTree = y' } 248 | 249 | -- y' :: Quadrant Int 250 | -- y' = Node (Leaf 0) 251 | -- (Node (Leaf 2) 252 | -- (Leaf 3) 253 | -- (Leaf 4) 254 | -- (Leaf 5)) 255 | -- (Leaf 1) 256 | -- (Leaf 9) 257 | 258 | -- basic :: QuadTree Int 259 | -- basic = Wrapper {treeLength = 4, treeWidth = 5, treeDepth = 3, 260 | -- wrappedTree = Node (Leaf 0) 261 | -- (Leaf 1) 262 | -- (Leaf 2) 263 | -- (Leaf 3)} 264 | 265 | -- x5 = set (atLocation (2,3)) 1 (makeTree (5,7) 0) 266 | -- x6 = set (atLocation (2,3)) 1 (makeTree (6,7) 0) 267 | -- p n = printTree (head . show) n 268 | 269 | -- test = set (atLocation (0,0)) 'd' $ 270 | -- set (atLocation (5,5)) 'c' $ 271 | -- set (atLocation (3,2)) 'b' $ 272 | -- set (atLocation (2,4)) 'a' $ 273 | -- makeTree (6,6) '.' 274 | -------------------------------------------------------------------------------- /hackage-upload-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Options / Usage 4 | # put this script in the same directory as your *.cabal file 5 | # it will use the first line of "cabal info ." to determine the package name 6 | 7 | # custom options for "cabal install" 8 | CUSTOM_OPTIONS=(--haddock-options='-q aliased') 9 | # hackage server to upload to (and to search uploaded versions for) 10 | HACKAGESERVER=hackage.haskell.org 11 | # whether to use cabal install (1) or copy docs directly from cabal haddock (0) 12 | # some user had troubles installing their package (or dependencies) 13 | CABAL_INSTALL=0 14 | # put your credentials into ~/.netrc: (see man netrc) 15 | # machine $HACKAGESERVER 16 | # login $USERNAME 17 | # password $PASSWORD 18 | 19 | # nothing to configure below this line 20 | 21 | # How it works 22 | # 23 | # It tries to find your package on the given hackage server, and 24 | # uploads the generated -doc.tar.gz. 25 | # It first tries the released version, then the candidate. 26 | # 27 | # To generate the docs it uses "cabal install" to install into a temporary directory, 28 | # with a temporary ghc package db in it. 29 | 30 | set -e 31 | 32 | status_code() { 33 | local code=$(curl "http://${HACKAGESERVER}$1" --silent -o /dev/null --write-out %{http_code}) 34 | echo "http://${HACKAGESERVER}$1 $code" >&2 35 | echo $code 36 | } 37 | 38 | self=$(readlink -f "$0") 39 | base=$(dirname "${self}") 40 | cd "${base}" 41 | tmpdir=$(mktemp --tmpdir -d doc-package-XXXXXXX) 42 | trap 'rm -rf "${tmpdir}"' EXIT 43 | 44 | name=$(cabal info . 2>/dev/null | awk '{print $2;exit}') 45 | plain_name="${name%-*}" # strip version number (must not contain a '-', the name itself can) 46 | 47 | if [ "200" = "$(status_code /package/${name})" ]; then 48 | echo "Found released version ${name}" 49 | targeturl="/package/${name}/docs" 50 | elif [ "200" = "$(status_code /package/${name}/candidate)" ]; then 51 | echo "Found candidate version ${name}" 52 | targeturl="/package/${name}/candidate/docs" 53 | else 54 | echo "Found no uploaded version" 55 | targeturl="" 56 | fi 57 | 58 | 59 | prefix="${tmpdir}/prefix" 60 | docdir="${prefix}/share/doc/${name}" 61 | if [ "${CABAL_INSTALL}" = 1 ]; then 62 | # after cabal install: 63 | htmldir="${docdir}/html" 64 | else 65 | # without cabal install: 66 | htmldir="${tmpdir}/dist/doc/html/${plain_name}" 67 | fi 68 | 69 | packagedb="${tmpdir}/package.conf.d" 70 | mkdir -p "${packagedb}" 71 | pkgdocdir="${tmpdir}/${name}-docs" 72 | pkgdocarchive="${tmpdir}/${name}-doc.tar.gz" 73 | 74 | cabal configure \ 75 | --builddir="${tmpdir}/dist" \ 76 | --disable-optimization --ghc-option -O0 \ 77 | --docdir="${docdir}" \ 78 | --prefix="${prefix}" 79 | 80 | # need separate haddock step, as install doesn't forward --builddir to haddock with 81 | # cabal install --enable-documentation 82 | # otherwise configure+haddock could be merged into install 83 | # (prefix cabal haddock options with --haddock- for cabal install) 84 | cabal haddock \ 85 | --builddir="${tmpdir}/dist" \ 86 | --html-location='/package/$pkg-$version/docs' \ 87 | --haddock-options='--built-in-themes' \ 88 | --hoogle --html \ 89 | "${CUSTOM_OPTIONS[@]}" \ 90 | --contents-location='/package/$pkg-$version' \ 91 | --hyperlink-source 92 | 93 | if [ "${CABAL_INSTALL}" = 1 ]; then 94 | cabal install \ 95 | --builddir="${tmpdir}/dist" \ 96 | --docdir="${docdir}" \ 97 | --prefix="${prefix}" \ 98 | --ghc-pkg-option --no-user-package-conf \ 99 | --ghc-pkg-option --package-db="${packagedb}" 100 | fi 101 | 102 | cp -ar "${htmldir}" "${pkgdocdir}" 103 | (cd "$(dirname ${pkgdocdir})"; tar --format=ustar -caf "${pkgdocarchive}" "$(basename ${pkgdocdir})") 104 | echo "Copying $(basename ${pkgdocdir}) to dist/" 105 | cp -ar "${pkgdocarchive}" dist/ 106 | 107 | if [ "${targeturl}" != "" ]; then 108 | echo -n "Upload to http://${HACKAGESERVER}${targeturl} (y/N)? " 109 | read ack 110 | if [ "${ack}" = "y" -o "${ack}" = "Y" ]; then 111 | echo "Uploading..." 112 | curl \ 113 | -X PUT \ 114 | -H "Content-Type: application/x-tar" \ 115 | -H "Content-Encoding: gzip" \ 116 | --data-binary @"${pkgdocarchive}" \ 117 | --digest --netrc \ 118 | "http://${HACKAGESERVER}${targeturl}" 119 | else 120 | echo "Not uploading." 121 | fi 122 | fi 123 | 124 | echo Done. 125 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor --------------------------------------------------------------------------------