packages feed

nspace (empty) → 0.1.0.0

raw patch · 11 files changed

+1168/−0 lines, 11 filesdep +QuickCheckdep +basedep +checkerssetup-changed

Dependencies added: QuickCheck, base, checkers, containers, hashable, linear, monoidal-containers, nspace

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `nspace`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,23 @@+# nspace++[![Hackage](https://img.shields.io/hackage/v/nspace.svg?logo=haskell&label=nspace)](https://hackage.haskell.org/package/nspace)+++## Dedication++> The eternal silence of these infinite spaces frightens me.+>+> -- Blaise Pascal+++## Overview++Haskelly `QuadTree`s and `OctTree`s at last!++`nspace` provides infinite-precision 2D and 3D spatial data structures with+support for efficient spatial queries.++Check the+[Haddock](https://hackage.haskell.org/package/nspace/docs/Data-OctTree.html) for+more information on how to get started!+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ nspace.cabal view
@@ -0,0 +1,109 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack++name:           nspace+version:        0.1.0.0+synopsis:       Efficient, infinite-precision 2D and 3D spatial containers.+description:    Please see the README on GitHub at <https://github.com/isovector/nspace#readme>+category:       Data Structures+homepage:       https://github.com/isovector/nspace#readme+bug-reports:    https://github.com/isovector/nspace/issues+author:         Sandy Maguire+maintainer:     sandy@sandymaguire.me+copyright:      2023 Sandy Maguire+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/isovector/nspace++library+  exposed-modules:+      Data.OctTree+      Data.OctTree.Internal+      Data.QuadTree+      Data.QuadTree.Internal+      Data.Semilattice+  other-modules:+      Paths_nspace+  autogen-modules:+      Paths_nspace+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      GeneralisedNewtypeDeriving+      ImplicitPrelude+      LambdaCase+      MonomorphismRestriction+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      StarIsType+      TypeApplications+      ViewPatterns+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , containers+    , hashable+    , linear+    , monoidal-containers+  default-language: Haskell2010++test-suite nspace-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_nspace+  autogen-modules:+      Paths_nspace+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      GeneralisedNewtypeDeriving+      ImplicitPrelude+      LambdaCase+      MonomorphismRestriction+      RankNTypes+      ScopedTypeVariables+      StandaloneDeriving+      StarIsType+      TypeApplications+      ViewPatterns+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , checkers+    , containers+    , hashable+    , linear+    , monoidal-containers+    , nspace+  default-language: Haskell2010
+ src/Data/OctTree.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StrictData      #-}++module Data.OctTree+  ( OctTree (..)++    -- * Constructing 'OctTree's+  , cube+  , fill+  , combineAla++    -- * Spatially Querying 'OctTree's+  , lookup+  , query++    -- * Eliminating 'OctTree's+  , fuse+  , elements+  , toCubes+  , boundingCube+  , defaultValue++    -- * Constructing 'Cube's+  , Cube (..)+  , mkCubeByPow++    -- * Eliminating 'Cube's+  , midpoint+  , subdivide+  , Raw.cubeCorners++    -- * Indexing Types+  , V3 (..)+  , Oct (..)+  ) where++import           Data.Coerce+import           Data.Foldable+import           Data.Maybe (fromMaybe)+import           Data.Monoid (Ap(..))+import           Data.OctTree.Internal (Free(..), Oct(..), Cube(..), pattern Oct8, unwrap, intersects, cubeContainsCube, getIntersect, cubeContainsPoint, normalize, cubeSize)+import qualified Data.OctTree.Internal as Raw+import           Data.Semilattice+import           Data.Set (Set)+import qualified Data.Set as S+import           GHC.Base (liftA2)+import           Linear.V3+import           Prelude hiding (lookup)+++------------------------------------------------------------------------------+-- | Compute the center of a 'Cube'.+midpoint :: (Fractional a) => Cube a -> V3 a+midpoint (Cube pos sz) = pos + sz / 2+++------------------------------------------------------------------------------+-- | Subdivide a 'Cube' into eight 'Cube's which fill up the same volume.+subdivide :: Fractional a => Cube a -> Oct (Cube a)+subdivide (Cube (V3 x y z) (V3 w h d)) =+  let halfw = w / 2+      halfh = h / 2+      halfd = d / 2+   in Oct8+        (Cube (V3 x y z) (V3 halfw halfh halfd))+        (Cube (V3 (x + halfw) y z) $ V3 (w - halfw) halfh halfd)+        (Cube (V3 x (y + halfh) z) $ V3 halfw (h - halfh) halfd)+        (Cube (V3 (x + halfw) (y + halfh) z) $ V3 (w - halfw) (h - halfh) halfd)+        (Cube (V3 x y (z + halfd)) $ V3 halfw halfh (d - halfd))+        (Cube (V3 (x + halfw) y (z + halfd)) $ V3 (w - halfw) halfh (d - halfd))+        (Cube (V3 x (y + halfh) (z + halfd)) $ V3 halfw (h - halfh) (d - halfd))+        (Cube (V3 (x + halfw) (y + halfh) (z + halfd)) $ V3 (w - halfw) (h - halfh) (d - halfd))+++------------------------------------------------------------------------------+-- | A type mapping values at (infinitely precise) locations in 3D+-- space. That is, you can consider an 'OctTree' to be a function @'V3'+-- 'Rational' -> a@, equipped with efficient means of querying the space.+--+-- 'OctTree's should usually be constructed using their 'Monoid'al or+-- 'Applicative' interfaces, as well as by way of the 'cube' and 'fill'+-- functions.+data OctTree a = OctTree+  { ot_default  :: a+  , ot_root_pow :: Integer+  , ot_tree     :: Free a+  }+  deriving stock (Show, Functor)+  deriving (Num, Semigroup, Monoid) via (Ap OctTree a)++instance Semilattice a => Semilattice (OctTree a)+++------------------------------------------------------------------------------+-- | Get the value used to fill the infinity of space in an 'OctTree'.+defaultValue :: OctTree a -> a+defaultValue = ot_default++instance Eq a => Eq (OctTree a) where+  q1@(OctTree a m tr) == q2@(OctTree a' n tr') =+    case compare m n of+      LT -> realloc q1 == q2+      EQ -> a == a' && tr == tr'+      GT -> q1 == realloc q2+++instance Applicative OctTree where+  pure a = OctTree a 0 $ pure a+  liftA2 fabc q1@(OctTree a m ota) q2@(OctTree b n otb) =+    case compare m n of+      LT -> liftA2 fabc (realloc q1) q2+      EQ -> OctTree (fabc a b) m $ liftA2 fabc ota otb+      GT -> liftA2 fabc q1 (realloc q2)+++------------------------------------------------------------------------------+-- | Get a 'Cube' guaranteed to bound all of the non-defaulted values in the+-- 'OctTree'.+boundingCube :: OctTree a -> Cube Rational+boundingCube = mkCubeByPow . ot_root_pow+++------------------------------------------------------------------------------+-- | Construct a 'Cube' centered around $(0, 0, 0)$, with side length $2n$.+mkCubeByPow :: Integer -> Cube Rational+mkCubeByPow n =+  let side = 2 ^ n+   in Cube (pure (-side)) $ pure $ side * 2+++------------------------------------------------------------------------------+-- | Build a larger 'Free' 'Oct' by doubling each side length, keeping the+-- contents in the center.+doubleGo :: a -> Oct (Free a) -> Free a+doubleGo def (Oct8 tl0 tr0 bl0 br0 tl1 tr1 bl1 br1) = Split $+  Oct8+    (Split (Oct8 a a a a a a+                 a tl0)) (Split (Oct8 a a a a a  a+                                     tr0 a))+    (Split (Oct8 a a a a a bl0+                 a a)) (Split (Oct8 a a a a br0 a+                                    a  a))+    (Split (Oct8 a a+                 a tl1 a a a a)) (Split (Oct8 a  a+                                     tr1 a a a a a))+    (Split (Oct8 a bl1+                 a a a a a a)) (Split (Oct8 br1 a+                                    a  a a a a a))+  where+    a = Fill def+++------------------------------------------------------------------------------+-- | Reallocate the bounds of the 'OctTree' so each side length is twice the+-- size.+realloc :: OctTree a -> OctTree a+realloc (OctTree a n q) = OctTree a (n + 1) $ doubleGo a $ unwrap q+++------------------------------------------------------------------------------+-- | Get the smallest integer which will contain the 'Cube' when given as an+-- argument to 'mkCubeByPow'.+--+-- @+-- 'cubeContainsCube' ('mkCubeByPow' ('cubeBoundingLog' c)) c == True+-- @+cubeBoundingLog :: Cube Rational -> Integer+cubeBoundingLog (Cube (V3 x y z) (V3 w h d)) =+  maximum $ (0 :) $ fmap (ceiling @Double . logBase 2 . fromRational)+    [ abs x+    , abs $ x + w+    , abs y+    , abs $ y + h+    , abs z+    , abs $ z + d+    ]+++fillSel :: (Fractional r, Ord r) => a -> a -> Maybe (Cube r) -> Cube r -> Free a+fillSel def _ Nothing _ = pure def+fillSel def v (Just r) qu = fillImpl def v r qu+++fillImpl :: (Fractional r, Ord r) => a -> a -> Cube r -> Cube r -> Free a+fillImpl def v area r+  | cubeContainsCube area r = pure v+  | intersects area r = do+      let subr = subdivide r+          subarea = getIntersect area <$> subr+      Split $ fillSel def v <$> subarea <*> subr+  | otherwise = pure def+++------------------------------------------------------------------------------+-- | @'cube' def val c@ constructs a new 'OctTree', which has value @val@+-- everywhere in the cube @c@, and @def@ everywhere else.+cube :: a -> a -> Cube Rational -> OctTree a+cube def v (normalize -> r)+  | cubeSize r == 0  = OctTree def (cubeBoundingLog r) $ pure def+  | otherwise = OctTree def (cubeBoundingLog r) $ fillImpl def v r $ mkCubeByPow (cubeBoundingLog r)+++------------------------------------------------------------------------------+-- | Fill a 'Cube' with the given value in an 'OctTree'+fill :: forall a. Cube Rational -> a -> OctTree a -> OctTree a+fill (normalize -> r) a q = liftA2 fromMaybe q (cube Nothing (Just a) r)+++lookupImpl :: V3 Rational -> Cube Rational -> Free a -> Maybe a+lookupImpl p r ot+  | cubeContainsPoint r p = case ot of+      Fill a -> Just a+      Split qu -> asum $ lookupImpl p <$> subdivide r <*> qu+  | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Get the value at the given position in the 'OctTree'.+lookup :: V3 Rational -> OctTree a -> a+lookup v2 (OctTree a n q) = fromMaybe a $ lookupImpl v2 (mkCubeByPow n) q+++------------------------------------------------------------------------------+-- | Query a region of space in an 'OctTree'. This method is a special case of+-- 'foldMap', specialized to finite regions.+--+-- For example, if you'd like to check if everything in the 'Cube' has+-- a specific value, use 'Data.Monoid.All' as your choice of 'Semilattice'. If+-- you'd like to check whether anything in the space has a value, instead use+-- 'Data.Monoid.Any'.+query :: Semilattice s => (a -> s) -> Cube Rational -> OctTree a -> s+query f (normalize -> area) (OctTree a n q)+  | cubeContainsCube r area = queryImpl f area r q+  | intersects r area = queryImpl f area r q /\ f a+  | otherwise = f a+  where+    r = mkCubeByPow n+++queryImpl :: Semilattice s => (a -> s) -> Cube Rational -> Cube Rational -> Free a -> s+queryImpl f area r (Fill a)+  | intersects area r = f a+  | otherwise = mempty+queryImpl f area r (Split qu)+  | intersects area r = do+      let subr = subdivide r+          subarea = getIntersect area <$> subr+      fold $ querySel f <$> subarea <*> subr <*> qu+  | otherwise = mempty+++querySel :: Semilattice s => (a -> s) -> Maybe (Cube Rational) -> Cube Rational -> Free a -> s+querySel _ Nothing _ _ = mempty+querySel f (Just area) r q = queryImpl f area r q+++------------------------------------------------------------------------------+-- | Partition the 'OctTree' into contiguous, singular-valued 'Cube's.+-- Satsifies the law+--+-- @+-- 'foldMap' (uncurry $ 'cube' ('defaultValue' ot)) ('toCubes' ot) == ot+-- @+toCubes :: OctTree a -> [(Cube Rational, a)]+toCubes (OctTree _ n q) = toCubesImpl (mkCubeByPow n) q++toCubesImpl :: Cube Rational -> Free a -> [(Cube Rational, a)]+toCubesImpl r (Fill a) = pure (r, a)+toCubesImpl r (Split qu) = do+  let subr = subdivide r+  fold $ toCubesImpl <$> subr <*> qu+++------------------------------------------------------------------------------+-- | Get the unique elements contained in the 'OctTree'.+elements :: Ord a => OctTree a -> Set a+elements ot = S.insert (ot_default ot) $ query S.singleton (boundingCube ot) ot+++------------------------------------------------------------------------------+-- | Fuse together all adjacent regions of space which contain the same value.+-- This will speed up subsequent queries, but requires traversing the entire+-- tree.+fuse :: Eq a => OctTree a -> OctTree a+fuse (OctTree a n ot) = OctTree a n $ Raw.fuse ot+++------------------------------------------------------------------------------+-- | Combine two 'OctTree's using a different semigroup than usual. For+-- example, in order to replace any values in @ot1@ with those covered by+-- @ot2@, we can use:+--+-- @+-- 'combineAla' 'Data.Semigroup.Last' ot1 ot2+-- @+combineAla :: forall n a. (Coercible a n, Semigroup n)  => (a -> n) -> OctTree a -> OctTree a -> OctTree a+combineAla _ x y = coerce $ (coerce x :: OctTree n) <> coerce y+
+ src/Data/OctTree/Internal.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE PatternSynonyms #-}++module Data.OctTree.Internal where++import Control.Applicative (liftA2)+import Data.Maybe (isJust)+import Data.Monoid (Ap(..))+import GHC.Generics (Generic)+import Linear.V3+import Linear.V4+++------------------------------------------------------------------------------+-- | An axis-aligned bounding box in 3-space.+data Cube a = Cube+  { r_pos  :: !(V3 a)+  , r_size :: !(V3 a)+  }+  deriving stock (Show, Read, Eq, Generic, Ord, Functor)+++------------------------------------------------------------------------------+r_x, r_y, r_z, r_w, r_h, r_d :: Cube a -> a+r_x (Cube (V3 x _ _) (V3 _ _ _)) = x+r_y (Cube (V3 _ y _) (V3 _ _ _)) = y+r_z (Cube (V3 _ _ z) (V3 _ _ _)) = z+r_w (Cube (V3 _ _ _) (V3 w _ _)) = w+r_h (Cube (V3 _ _ _) (V3 _ h _)) = h+r_d (Cube (V3 _ _ _) (V3 _ _ d)) = d+++------------------------------------------------------------------------------+-- | @'containsCube' c1 c2@ is true when @c2@ is inside or equal to @c1@.+cubeContainsCube :: (Num a, Ord a) => Cube a -> Cube a -> Bool+cubeContainsCube r1@(Cube (V3 bx by bz) (V3 bw bh bd)) r2@(Cube (V3 sx sy sz) (V3 sw sh sd)) =+  r1 == r2 ||+  and+    [ bx <= sx+    , by <= sy+    , bz <= sz+    , sx + sw <= bx + bw+    , sy + sh <= by + bh+    , sz + sd <= bz + bd+    ]+++------------------------------------------------------------------------------+-- | Does the cube contain a given point?+cubeContainsPoint :: (Ord a, Num a) => Cube a -> V3 a -> Bool+cubeContainsPoint (Cube _ (V3 w h d)) _+  | w <= 0 || h <= 0 || d <= 0+  = False+cubeContainsPoint (Cube (V3 x y z) (V3 w h d)) (V3 tx ty tz) =+  and+    [ x <= tx+    , y <= ty+    , z <= tz+    , tx < x + w+    , ty < y + h+    , tz < z + d+    ]++------------------------------------------------------------------------------+-- | Get the co-ordinates of the corners of a 'Cube'.+cubeCorners :: Num a => Cube a -> Oct (V3 a)+cubeCorners (Cube (V3 x y z) (V3 w h d)) =+  let p = V3 x y z+      dx = V3 w 0 0+      dy = V3 0 h 0+      dz = V3 0 0 d+   in fmap (p +) $ Oct8 0   dx         dy       (dx + dy)+                       dz (dx + dz) (dy + dz) (dx + dy + dz)+++------------------------------------------------------------------------------+-- | 'Control.Monad.Free.Free', but with better instances.+data Free a+  = Fill a+  | Split (Oct (Free a))+  deriving (Functor, Foldable, Traversable, Generic)++deriving via Ap Free a instance (Semigroup a) => Semigroup (Free a)+deriving via Ap Free a instance (Monoid    a) => Monoid    (Free a)++deriving stock instance (Show a) => Show (Free a)++instance (Eq a) => Eq (Free a) where+  Fill a   == Fill b    = a             == b+  Split qu == Split qu' = qu            == qu'+  Fill a   == Split qu  = pure (pure a) == qu+  Split qu == Fill a    = pure (pure a) == qu++instance Applicative Free where+  pure = Fill+  liftA2 fabc (Fill a) (Fill b) = Fill $ fabc a b+  liftA2 fabc (Fill a) (Split qu) = Split $ fmap (fmap (fabc a)) qu+  liftA2 fabc (Split qu) (Fill b) = Split $ fmap (fmap (flip  fabc b)) qu+  liftA2 fabc (Split qu) (Split qu') = Split $ liftA2 (liftA2 fabc) qu qu'++instance Monad Free where+  Fill a >>= f = f a+  Split qu >>= f = Split $ fmap (>>= f) qu+++------------------------------------------------------------------------------+-- | An 8-tuple of values.+data Oct a = Oct !(V4 a) !(V4 a)+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)+  deriving (Semigroup, Monoid) via Ap Oct a++pattern Oct8 :: a -> a -> a -> a -> a -> a -> a -> a -> Oct a+pattern Oct8 a b c d e f g h = Oct (V4 a b c d) (V4 e f g h)+{-# COMPLETE Oct8 #-}++instance Applicative Oct where+  pure a = Oct (pure a) (pure a)+  liftA2 fabc (Oct a1 a2) (Oct b1 b2)+    = Oct (liftA2 fabc a1 b1) (liftA2 fabc a2 b2)+++------------------------------------------------------------------------------+-- | Normalize a 'Cube' so it has a positive 'r_size'.+normalize :: (Num a, Ord a) => Cube a -> Cube a+normalize q@(Cube (V3 x y z) (V3 w h d))+  | w < 0 = let w' = abs w in normalize $ Cube (V3 (x - w') y z) $ V3 w' h d+  | h < 0 = let h' = abs h in normalize $ Cube (V3 x (y - h') z) $ V3 w h' d+  | d < 0 = let d' = abs d in normalize $ Cube (V3 x y (z - d')) $ V3 w h d'+  | otherwise = q+++------------------------------------------------------------------------------+-- | Do two 'Cube's intersect?+intersects :: (Ord a, Num a) => Cube a -> Cube a -> Bool+intersects r1 r2 = isJust $ getIntersect r1 r2+++------------------------------------------------------------------------------+-- | Get the volume of a 'Cube'.+cubeSize :: Num a => Cube a -> a+cubeSize (Cube _ (V3 w h d)) = abs w * abs h * abs d+++------------------------------------------------------------------------------+-- | Compute the intersection of two 'Cube's.+getIntersect :: (Ord a, Num a) => Cube a -> Cube a -> Maybe (Cube a)+getIntersect (normalize -> r1) (normalize -> r2)+ | cubeSize r1 == 0 = Just r1+ | cubeSize r2 == 0 = Just r2+ | otherwise =+  let x0 = max (r_x r1) (r_x r2)+      y0 = max (r_y r1) (r_y r2)+      z0 = max (r_z r1) (r_z r2)+      x1 = min (r_x r1 + r_w r1) (r_x r2 + r_w r2)+      y1 = min (r_y r1 + r_h r1) (r_y r2 + r_h r2)+      z1 = min (r_z r1 + r_d r1) (r_z r2 + r_d r2)+      w = x1 - x0+      h = y1 - y0+      d = z1 - z0+   in case 0 < w && 0 < h && 0 < d of+        True -> Just $ Cube (V3 x0 y0 z0) (V3 w h d)+        False -> Nothing+++unwrap :: Free a -> Oct (Free a)+unwrap (Fill a) = pure $ pure a+unwrap (Split qu) = qu+++------------------------------------------------------------------------------+-- | Join together 'Split' constructors which all contain the same value.+fuse :: Eq a => Free a -> Free a+fuse (Fill a) = Fill a+fuse (Split q) = doFuse $ fmap fuse q+++doFuse :: Eq a => Oct (Free a) -> Free a+doFuse (Oct8 (Fill a) (Fill b) (Fill c) (Fill d) (Fill e) (Fill f) (Fill g) (Fill h))+  | a == b+  , b == c+  , c == d+  , d == e+  , e == f+  , f == g+  , g == h+  = Fill a+doFuse q = Split q+
+ src/Data/QuadTree.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StrictData      #-}++module Data.QuadTree+  ( QuadTree (..)++    -- * Constructing 'QuadTree's+  , rect+  , fill+  , combineAla++    -- * Spatially Querying 'QuadTree's+  , lookup+  , query++    -- * Eliminating 'QuadTree's+  , fuse+  , elements+  , toRects+  , boundingRect+  , defaultValue++    -- * Constructing 'Rect's+  , Rect (..)+  , mkRectByPow++    -- * Eliminating 'Rect's+  , midpoint+  , subdivide+  , Raw.rectCorners++    -- * Indexing Types+  , V2 (..)+  , V4 (..)+  ) where++import           Data.Coerce+import           Data.Foldable+import           Data.Maybe (fromMaybe)+import           Data.Monoid (Ap(..))+import           Data.QuadTree.Internal (Free(..), Rect(..), unwrap, intersects, rectContainsRect, getIntersect, rectContainsPoint, normalize, rectSize)+import qualified Data.QuadTree.Internal as Raw+import           Data.Semilattice+import           Data.Set (Set)+import qualified Data.Set as S+import           GHC.Base (liftA2)+import           Linear.V2+import           Linear.V4+import           Prelude hiding (lookup)+++------------------------------------------------------------------------------+-- | Compute the center of a 'Rect'.+midpoint :: (Fractional a) => Rect a -> V2 a+midpoint (Rect pos sz) = pos + sz / 2+++------------------------------------------------------------------------------+-- | Subdivide a 'Rect' into four 'Rect's which fill up the same volume.+subdivide :: Fractional a => Rect a -> V4 (Rect a)+subdivide (Rect (V2 x y) (V2 w h)) =+  let halfw = w / 2+      halfh = h / 2+   in V4+        (Rect (V2 x y) (V2 halfw halfh))+        (Rect (V2 (x + halfw) y) $ V2 (w - halfw) halfh)+        (Rect (V2 x (y + halfh)) $ V2 halfw (h - halfh))+        (Rect (V2 (x + halfw) (y + halfh)) $ V2 (w - halfw) (h - halfh))+++------------------------------------------------------------------------------+-- | A type mapping values at (infinitely precise) locations in 2D+-- space. That is, you can consider an 'QuadTree' to be a function @'V2'+-- 'Rational' -> a@, equipped with efficient means of querying the space.+--+-- 'QuadTree's should usually be constructed using their 'Monoid'al or+-- 'Applicative' interfaces, as well as by way of the 'rect' and 'fill'+-- functions.+data QuadTree a = QuadTree+  { ot_default  :: a+  , ot_root_pow :: Integer+  , ot_tree     :: Free a+  }+  deriving stock (Show, Functor)+  deriving (Num, Semigroup, Monoid) via (Ap QuadTree a)++instance Semilattice a => Semilattice (QuadTree a)+++------------------------------------------------------------------------------+-- | Get the value used to fill the infinity of space in an 'QuadTree'.+defaultValue :: QuadTree a -> a+defaultValue = ot_default++instance Eq a => Eq (QuadTree a) where+  q1@(QuadTree a m tr) == q2@(QuadTree a' n tr') =+    case compare m n of+      LT -> realloc q1 == q2+      EQ -> a == a' && tr == tr'+      GT -> q1 == realloc q2+++instance Applicative QuadTree where+  pure a = QuadTree a 0 $ pure a+  liftA2 fabc q1@(QuadTree a m ota) q2@(QuadTree b n otb) =+    case compare m n of+      LT -> liftA2 fabc (realloc q1) q2+      EQ -> QuadTree (fabc a b) m $ liftA2 fabc ota otb+      GT -> liftA2 fabc q1 (realloc q2)+++------------------------------------------------------------------------------+-- | Get a 'Rect' guaranteed to bound all of the non-defaulted values in the+-- 'QuadTree'.+boundingRect :: QuadTree a -> Rect Rational+boundingRect = mkRectByPow . ot_root_pow+++------------------------------------------------------------------------------+-- | Construct a 'Rect' centered around $(0, 0, 0)$, with side length $2n$.+mkRectByPow :: Integer -> Rect Rational+mkRectByPow n =+  let side = 2 ^ n+   in Rect (pure (-side)) $ pure $ side * 2+++------------------------------------------------------------------------------+-- | Build a larger 'Free' 'Quad' by doubling each side length, keeping the+-- contents in the center.+doubleGo :: a -> V4 (Free a) -> Free a+doubleGo def (V4 tl tr bl br) = Split $+  V4+    (Split (V4 a a+               a tl)) (Split (V4 a  a+                                tr a))+    (Split (V4 a bl+               a a)) (Split (V4 br a+                                a  a))+  where+    a = Fill def+++------------------------------------------------------------------------------+-- | Reallocate the bounds of the 'QuadTree' so each side length is twice the+-- size.+realloc :: QuadTree a -> QuadTree a+realloc (QuadTree a n q) = QuadTree a (n + 1) $ doubleGo a $ unwrap q+++------------------------------------------------------------------------------+-- | Get the smallest integer which will contain the 'Rect' when given as an+-- argument to 'mkRectByPow'.+--+-- @+-- 'rectContainsRect' ('mkRectByPow' ('rectBoundingLog' c)) c == True+-- @+rectBoundingLog :: Rect Rational -> Integer+rectBoundingLog (Rect (V2 x y) (V2 w h)) =+  maximum $ (0 :) $ fmap (ceiling @Double . logBase 2 . fromRational)+    [ abs x+    , abs $ x + w+    , abs y+    , abs $ y + h+    ]+++fillSel :: (Fractional r, Ord r) => a -> a -> Maybe (Rect r) -> Rect r -> Free a+fillSel def _ Nothing _ = pure def+fillSel def v (Just r) qu = fillImpl def v r qu+++fillImpl :: (Fractional r, Ord r) => a -> a -> Rect r -> Rect r -> Free a+fillImpl def v area r+  | rectContainsRect area r = pure v+  | intersects area r = do+      let subr = subdivide r+          subarea = getIntersect area <$> subr+      Split $ fillSel def v <$> subarea <*> subr+  | otherwise = pure def+++------------------------------------------------------------------------------+-- | @'rect' def val c@ constructs a new 'QuadTree', which has value @val@+-- everywhere in the rect @c@, and @def@ everywhere else.+rect :: a -> a -> Rect Rational -> QuadTree a+rect def v (normalize -> r)+  | rectSize r == 0  = QuadTree def (rectBoundingLog r) $ pure def+  | otherwise = QuadTree def (rectBoundingLog r) $ fillImpl def v r $ mkRectByPow (rectBoundingLog r)+++------------------------------------------------------------------------------+-- | Fill a 'Rect' with the given value in an 'QuadTree'+fill :: forall a. Rect Rational -> a -> QuadTree a -> QuadTree a+fill (normalize -> r) a q = liftA2 fromMaybe q (rect Nothing (Just a) r)+++lookupImpl :: V2 Rational -> Rect Rational -> Free a -> Maybe a+lookupImpl p r ot+  | rectContainsPoint r p = case ot of+      Fill a -> Just a+      Split qu -> asum $ lookupImpl p <$> subdivide r <*> qu+  | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Get the value at the given position in the 'QuadTree'.+lookup :: V2 Rational -> QuadTree a -> a+lookup v2 (QuadTree a n q) = fromMaybe a $ lookupImpl v2 (mkRectByPow n) q+++------------------------------------------------------------------------------+-- | Query a region of space in an 'QuadTree'. This method is a special case of+-- 'foldMap', specialized to finite regions.+--+-- For example, if you'd like to check if everything in the 'Rect' has+-- a specific value, use 'Data.Monoid.All' as your choice of 'Semilattice'. If+-- you'd like to check whether anything in the space has a value, instead use+-- 'Data.Monoid.Any'.+query :: Semilattice s => (a -> s) -> Rect Rational -> QuadTree a -> s+query f (normalize -> area) (QuadTree a n q)+  | rectContainsRect r area = queryImpl f area r q+  | intersects r area = queryImpl f area r q /\ f a+  | otherwise = f a+  where+    r = mkRectByPow n+++queryImpl :: Semilattice s => (a -> s) -> Rect Rational -> Rect Rational -> Free a -> s+queryImpl f area r (Fill a)+  | intersects area r = f a+  | otherwise = mempty+queryImpl f area r (Split qu)+  | intersects area r = do+      let subr = subdivide r+          subarea = getIntersect area <$> subr+      fold $ querySel f <$> subarea <*> subr <*> qu+  | otherwise = mempty+++querySel :: Semilattice s => (a -> s) -> Maybe (Rect Rational) -> Rect Rational -> Free a -> s+querySel _ Nothing _ _ = mempty+querySel f (Just area) r q = queryImpl f area r q+++------------------------------------------------------------------------------+-- | Partition the 'QuadTree' into contiguous, singular-valued 'Rect's.+-- Satsifies the law+--+-- @+-- 'foldMap' (uncurry $ 'rect' ('defaultValue' ot)) ('toRects' ot) == ot+-- @+toRects :: QuadTree a -> [(Rect Rational, a)]+toRects (QuadTree _ n q) = toRectsImpl (mkRectByPow n) q++toRectsImpl :: Rect Rational -> Free a -> [(Rect Rational, a)]+toRectsImpl r (Fill a) = pure (r, a)+toRectsImpl r (Split qu) = do+  let subr = subdivide r+  fold $ toRectsImpl <$> subr <*> qu+++------------------------------------------------------------------------------+-- | Get the unique elements contained in the 'QuadTree'.+elements :: Ord a => QuadTree a -> Set a+elements ot = S.insert (ot_default ot) $ query S.singleton (boundingRect ot) ot+++------------------------------------------------------------------------------+-- | Fuse together all adjacent regions of space which contain the same value.+-- This will speed up subsequent queries, but requires traversing the entire+-- tree.+fuse :: Eq a => QuadTree a -> QuadTree a+fuse (QuadTree a n ot) = QuadTree a n $ Raw.fuse ot+++------------------------------------------------------------------------------+-- | Combine two 'QuadTree's using a different semigroup than usual. For+-- example, in order to replace any values in @qt1@ with those covered by+-- @qt2@, we can use:+--+-- @+-- 'combineAla' 'Data.Semigroup.Last' qt1 qt2+-- @+combineAla :: forall n a. (Coercible a n, Semigroup n)  => (a -> n) -> QuadTree a -> QuadTree a -> QuadTree a+combineAla _ x y = coerce $ (coerce x :: QuadTree n) <> coerce y++
+ src/Data/QuadTree/Internal.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE RoleAnnotations      #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.QuadTree.Internal where++import Control.Applicative (liftA2)+import Data.Maybe (isJust)+import Data.Monoid (Ap(..))+import GHC.Generics (Generic)+import Linear.V2+import Linear.V4+++------------------------------------------------------------------------------+-- | An axis-aligned bounding box in 3-space.+data Rect a = Rect+  { r_pos  :: !(V2 a)+  , r_size :: !(V2 a)+  }+  deriving stock (Show, Read, Eq, Generic, Ord, Functor)+++------------------------------------------------------------------------------+r_x, r_y, r_w, r_h :: Rect a -> a+r_x (Rect (V2 x _) (V2 _ _)) = x+r_y (Rect (V2 _ y) (V2 _ _)) = y+r_w (Rect (V2 _ _) (V2 w _)) = w+r_h (Rect (V2 _ _) (V2 _ h)) = h+++------------------------------------------------------------------------------+-- | @'containsRect' c1 c2@ is true when @c2@ is inside or equal to @c1@.+rectContainsRect :: (Num a, Ord a) => Rect a -> Rect a -> Bool+rectContainsRect r1@(Rect (V2 bx by) (V2 bw bh)) r2@(Rect (V2 sx sy) (V2 sw sh)) =+  r1 == r2 ||+  and+    [ bx <= sx+    , by <= sy+    , sx + sw <= bx + bw+    , sy + sh <= by + bh+    ]+++------------------------------------------------------------------------------+-- | Does the rect contain a given point?+rectContainsPoint :: (Ord a, Num a) => Rect a -> V2 a -> Bool+rectContainsPoint (Rect _ (V2 w h)) _+  | w <= 0 || h <= 0+  = False+rectContainsPoint (Rect (V2 x y) (V2 w h)) (V2 tx ty) =+  and+    [ x <= tx+    , y <= ty+    , tx < x + w+    , ty < y + h+    ]++------------------------------------------------------------------------------+-- | Get the co-ordinates of the corners of a 'Rect'.+rectCorners :: Num a => Rect a -> V4 (V2 a)+rectCorners (Rect (V2 x y) (V2 w h)) =+  let p = V2 x y+      dx = V2 w 0+      dy = V2 0 h+   in fmap (p +) $ V4 0   dx         dy       (dx + dy)+++------------------------------------------------------------------------------+-- | 'Control.Monad.Free.Free', but with better instances.+data Free a+  = Fill a+  | Split (V4 (Free a))+  deriving (Functor, Foldable, Traversable, Generic)++deriving via Ap Free a instance (Semigroup a) => Semigroup (Free a)+deriving via Ap Free a instance (Monoid    a) => Monoid    (Free a)++deriving stock instance (Show a) => Show (Free a)++instance (Eq a) => Eq (Free a) where+  Fill a   == Fill b    = a             == b+  Split qu == Split qu' = qu            == qu'+  Fill a   == Split qu  = pure (pure a) == qu+  Split qu == Fill a    = pure (pure a) == qu++instance Applicative Free where+  pure = Fill+  liftA2 fabc (Fill a) (Fill b) = Fill $ fabc a b+  liftA2 fabc (Fill a) (Split qu) = Split $ fmap (fmap (fabc a)) qu+  liftA2 fabc (Split qu) (Fill b) = Split $ fmap (fmap (flip  fabc b)) qu+  liftA2 fabc (Split qu) (Split qu') = Split $ liftA2 (liftA2 fabc) qu qu'++instance Monad Free where+  Fill a >>= f = f a+  Split qu >>= f = Split $ fmap (>>= f) qu+++------------------------------------------------------------------------------+-- | Normalize a 'Rect' so it has a positive 'r_size'.+normalize :: (Num a, Ord a) => Rect a -> Rect a+normalize q@(Rect (V2 x y) (V2 w h))+  | w < 0 = let w' = abs w in normalize $ Rect (V2 (x - w') y) $ V2 w' h+  | h < 0 = let h' = abs h in normalize $ Rect (V2 x (y - h')) $ V2 w h'+  | otherwise = q+++------------------------------------------------------------------------------+-- | Do two 'Rect's intersect?+intersects :: (Ord a, Num a) => Rect a -> Rect a -> Bool+intersects r1 r2 = isJust $ getIntersect r1 r2+++------------------------------------------------------------------------------+-- | Get the area of a 'Rect'.+rectSize :: Num a => Rect a -> a+rectSize (Rect _ (V2 w h)) = w * h+++------------------------------------------------------------------------------+-- | Compute the intersection of two 'Rect's.+getIntersect :: (Ord a, Num a) => Rect a -> Rect a -> Maybe (Rect a)+getIntersect (normalize -> r1) (normalize -> r2)+ | rectSize r1 == 0 = Just r1+ | rectSize r2 == 0 = Just r2+ | otherwise =+  let x0 = max (r_x r1) (r_x r2)+      y0 = max (r_y r1) (r_y r2)+      x1 = min (r_x r1 + r_w r1) (r_x r2 + r_w r2)+      y1 = min (r_y r1 + r_h r1) (r_y r2 + r_h r2)+      w = x1 - x0+      h = y1 - y0+   in case 0 < w && 0 < h of+        True -> Just $ Rect (V2 x0 y0) (V2 w h)+        False -> Nothing+++unwrap :: Free a -> V4 (Free a)+unwrap (Fill a) = pure $ pure a+unwrap (Split qu) = qu+++------------------------------------------------------------------------------+-- | Join together 'Split' constructors which all contain the same value.+fuse :: Eq a => Free a -> Free a+fuse (Fill a) = Fill a+fuse (Split q) = doFuse $ fmap fuse q+++doFuse :: Eq a => V4 (Free a) -> Free a+doFuse (V4 (Fill a) (Fill b) (Fill c) (Fill d))+  | a == b+  , b == c+  , c == d+  = Fill a+doFuse q = Split q+
+ src/Data/Semilattice.hs view
@@ -0,0 +1,62 @@+module Data.Semilattice where++import           Data.Functor.Compose+import           Data.Functor.Const+import           Data.Functor.Product+import qualified Data.HashMap.Monoidal as HashMap+import           Data.Hashable (Hashable)+import qualified Data.IntMap.Monoidal as LazyIntMap+import qualified Data.IntMap.Monoidal.Strict as StrictIntMap+import qualified Data.Map.Monoidal as LazyMap+import qualified Data.Map.Monoidal.Strict as StrictMap+import           Data.Monoid hiding (Product)+import           Data.Semigroup hiding (Product)+import           Data.Set (Set)+import           GHC.Generics++------------------------------------------------------------------------------+-- | A 'Semilattice' is a 'Monoid' with the additional property that its+-- @'(/\)' = '(<>)'@ operation is commutative and idempotent.  That is:+--+-- @+-- a '/\' b = b '/\' a+-- @+--+-- and+--+-- @+-- a '/\' a = a+-- @+--+-- These two properties ensure the internal representations of+-- 'Data.QuadTree.QuadTree' and 'Data.OctTree.OctTree' can't leak out when+-- performing spatial queries.+class Monoid a => Semilattice a where+  (/\) :: a -> a -> a+  (/\) = (<>)++instance Semilattice ()+instance Semilattice Any+instance Semilattice All+instance (Ord a, Bounded a) => Semilattice (Max a)+instance (Ord a, Bounded a) => Semilattice (Min a)+instance Ord a => Semilattice (Set a)+instance (Ord k, Semilattice a) => Semilattice (LazyMap.MonoidalMap k a)+instance (Ord k, Semilattice a) => Semilattice (StrictMap.MonoidalMap k a)+instance Semilattice a => Semilattice (LazyIntMap.MonoidalIntMap a)+instance Semilattice a => Semilattice (StrictIntMap.MonoidalIntMap a)+instance (Hashable k, Eq k, Semilattice a) => Semilattice (HashMap.MonoidalHashMap k a)+instance Semilattice b => Semilattice (a -> b)+instance Semilattice a => Semilattice (Maybe a)+instance Semilattice a => Semilattice (Const a b)+instance Semilattice a => Semilattice (K1 i a b)+instance Semilattice (f a) => Semilattice (M1 i c f a)+instance (Semilattice (f a), Semilattice (g a)) => Semilattice (Product f g a)+instance (Semilattice (f (g a))) => Semilattice (Compose f g a)+instance (Semilattice (f (g a))) => Semilattice ((:.:) f g a)+instance (Semilattice (f a), Semilattice (g a)) => Semilattice ((:*:) f g a)+instance (Semilattice a, Semilattice b) => Semilattice (a, b)+instance (Semilattice a, Semilattice b, Semilattice c) => Semilattice (a, b, c)+instance (Semilattice a, Semilattice b, Semilattice c, Semilattice d) => Semilattice (a, b, c, d)+instance (Semilattice a, Semilattice b, Semilattice c, Semilattice d, Semilattice e) => Semilattice (a, b, c, d, e)+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"