{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.QuadTree.Tree
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Data.Geometry.QuadTree.Tree where


import           Control.Lens (makePrisms)
import           Data.Bifoldable
import           Data.Bifunctor
import           Data.Bitraversable
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Functor.Apply
import           Data.Geometry.Point
import           Data.Geometry.QuadTree.Cell
import           Data.Geometry.QuadTree.Quadrants
import           Data.Geometry.QuadTree.Split
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Semigroup.Foldable.Class
import           Data.Semigroup.Traversable.Class
import qualified Data.Tree as RoseTree
import           Data.Tree.Util (TreeNode(..))

--------------------------------------------------------------------------------

-- | Our cells use Rational numbers as their numeric type
-- type CellR = Cell (RealNumber 10)

-- | The Actual Tree type representing a quadTree
data Tree v p = Leaf !p
              | Node !v (Quadrants (Tree v p)) -- quadrants are stored lazily on purpose
              deriving (Int -> Tree v p -> ShowS
[Tree v p] -> ShowS
Tree v p -> String
(Int -> Tree v p -> ShowS)
-> (Tree v p -> String) -> ([Tree v p] -> ShowS) -> Show (Tree v p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v p. (Show p, Show v) => Int -> Tree v p -> ShowS
forall v p. (Show p, Show v) => [Tree v p] -> ShowS
forall v p. (Show p, Show v) => Tree v p -> String
showList :: [Tree v p] -> ShowS
$cshowList :: forall v p. (Show p, Show v) => [Tree v p] -> ShowS
show :: Tree v p -> String
$cshow :: forall v p. (Show p, Show v) => Tree v p -> String
showsPrec :: Int -> Tree v p -> ShowS
$cshowsPrec :: forall v p. (Show p, Show v) => Int -> Tree v p -> ShowS
Show,Tree v p -> Tree v p -> Bool
(Tree v p -> Tree v p -> Bool)
-> (Tree v p -> Tree v p -> Bool) -> Eq (Tree v p)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v p. (Eq p, Eq v) => Tree v p -> Tree v p -> Bool
/= :: Tree v p -> Tree v p -> Bool
$c/= :: forall v p. (Eq p, Eq v) => Tree v p -> Tree v p -> Bool
== :: Tree v p -> Tree v p -> Bool
$c== :: forall v p. (Eq p, Eq v) => Tree v p -> Tree v p -> Bool
Eq)
makePrisms ''Tree

instance Bifunctor Tree where
  bimap :: (a -> b) -> (c -> d) -> Tree a c -> Tree b d
bimap = (a -> b) -> (c -> d) -> Tree a c -> Tree b d
forall (t :: * -> * -> *) a b c d.
Bitraversable t =>
(a -> b) -> (c -> d) -> t a c -> t b d
bimapDefault

instance Bifoldable Tree where
  bifoldMap :: (a -> m) -> (b -> m) -> Tree a b -> m
bifoldMap = (a -> m) -> (b -> m) -> Tree a b -> m
forall (t :: * -> * -> *) m a b.
(Bitraversable t, Monoid m) =>
(a -> m) -> (b -> m) -> t a b -> m
bifoldMapDefault

instance Bitraversable Tree where
  bitraverse :: (a -> f c) -> (b -> f d) -> Tree a b -> f (Tree c d)
bitraverse a -> f c
f b -> f d
g = \case
    Leaf b
p    -> d -> Tree c d
forall v p. p -> Tree v p
Leaf (d -> Tree c d) -> f d -> f (Tree c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
p
    Node a
v Quadrants (Tree a b)
qs -> c -> Quadrants (Tree c d) -> Tree c d
forall v p. v -> Quadrants (Tree v p) -> Tree v p
Node (c -> Quadrants (Tree c d) -> Tree c d)
-> f c -> f (Quadrants (Tree c d) -> Tree c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
v f (Quadrants (Tree c d) -> Tree c d)
-> f (Quadrants (Tree c d)) -> f (Tree c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Tree a b -> f (Tree c d))
-> Quadrants (Tree a b) -> f (Quadrants (Tree c d))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f c) -> (b -> f d) -> Tree a b -> f (Tree c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g) Quadrants (Tree a b)
qs

instance Bifoldable1 Tree
instance Bitraversable1 Tree where
  bitraverse1 :: (a -> f b) -> (c -> f d) -> Tree a c -> f (Tree b d)
bitraverse1 a -> f b
f c -> f d
g = \case
    Leaf c
p    -> d -> Tree b d
forall v p. p -> Tree v p
Leaf (d -> Tree b d) -> f d -> f (Tree b d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> f d
g c
p
    Node a
v Quadrants (Tree a c)
qs -> b -> Quadrants (Tree b d) -> Tree b d
forall v p. v -> Quadrants (Tree v p) -> Tree v p
Node (b -> Quadrants (Tree b d) -> Tree b d)
-> f b -> f (Quadrants (Tree b d) -> Tree b d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v f (Quadrants (Tree b d) -> Tree b d)
-> f (Quadrants (Tree b d)) -> f (Tree b d)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> (Tree a c -> f (Tree b d))
-> Quadrants (Tree a c) -> f (Quadrants (Tree b d))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 ((a -> f b) -> (c -> f d) -> Tree a c -> f (Tree b d)
forall (t :: * -> * -> *) (f :: * -> *) a b c d.
(Bitraversable1 t, Apply f) =>
(a -> f b) -> (c -> f d) -> t a c -> f (t b d)
bitraverse1 a -> f b
f c -> f d
g) Quadrants (Tree a c)
qs

-- | Fold on the Tree type.
foldTree     :: (p -> b) -> (v -> Quadrants b -> b) -> Tree v p -> b
foldTree :: (p -> b) -> (v -> Quadrants b -> b) -> Tree v p -> b
foldTree p -> b
f v -> Quadrants b -> b
g = Tree v p -> b
go
  where
    go :: Tree v p -> b
go = \case
      Leaf p
p    -> p -> b
f p
p
      Node v
v Quadrants (Tree v p)
qs -> v -> Quadrants b -> b
g v
v (Tree v p -> b
go (Tree v p -> b) -> Quadrants (Tree v p) -> Quadrants b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Quadrants (Tree v p)
qs)

-- | Produce a list of all leaves of a quad tree
leaves :: Tree v p -> NonEmpty p
leaves :: Tree v p -> NonEmpty p
leaves = [p] -> NonEmpty p
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([p] -> NonEmpty p) -> (Tree v p -> [p]) -> Tree v p -> NonEmpty p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> [p]) -> (p -> [p]) -> Tree v p -> [p]
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap ([p] -> v -> [p]
forall a b. a -> b -> a
const []) (p -> [p] -> [p]
forall a. a -> [a] -> [a]
:[])

-- | Converts into a RoseTree
toRoseTree :: Tree v p -> RoseTree.Tree (TreeNode v p)
toRoseTree :: Tree v p -> Tree (TreeNode v p)
toRoseTree = (p -> Tree (TreeNode v p))
-> (v -> Quadrants (Tree (TreeNode v p)) -> Tree (TreeNode v p))
-> Tree v p
-> Tree (TreeNode v p)
forall p b v. (p -> b) -> (v -> Quadrants b -> b) -> Tree v p -> b
foldTree (\p
p    -> TreeNode v p -> Forest (TreeNode v p) -> Tree (TreeNode v p)
forall a. a -> Forest a -> Tree a
RoseTree.Node (p -> TreeNode v p
forall v a. a -> TreeNode v a
LeafNode p
p)     [])
                      (\v
v Quadrants (Tree (TreeNode v p))
qs -> TreeNode v p -> Forest (TreeNode v p) -> Tree (TreeNode v p)
forall a. a -> Forest a -> Tree a
RoseTree.Node (v -> TreeNode v p
forall v a. v -> TreeNode v a
InternalNode v
v) (Quadrants (Tree (TreeNode v p)) -> Forest (TreeNode v p)
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Quadrants (Tree (TreeNode v p))
qs))

-- | Computes the height of the quadtree
height :: Tree v p -> Integer
height :: Tree v p -> Integer
height = (p -> Integer)
-> (v -> Quadrants Integer -> Integer) -> Tree v p -> Integer
forall p b v. (p -> b) -> (v -> Quadrants b -> b) -> Tree v p -> b
foldTree (Integer -> p -> Integer
forall a b. a -> b -> a
const Integer
1) (\v
_ -> (Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+) (Integer -> Integer)
-> (Quadrants Integer -> Integer) -> Quadrants Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quadrants Integer -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum)


--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- * Functions operating on the QuadTree (in temrs of the 'Tree' type)

-- | Builds a QuadTree
build             :: Fractional r
                  => Splitter r pts v p -> Cell r -> pts -> Tree v p
build :: Splitter r pts v p -> Cell r -> pts -> Tree v p
build Splitter r pts v p
shouldSplit = Cell r -> pts -> Tree v p
build'
  where
    build' :: Cell r -> pts -> Tree v p
build' Cell r
cc pts
pts = case Splitter r pts v p
shouldSplit Cell r
cc pts
pts of
                      No p
p     -> p -> Tree v p
forall v p. p -> Tree v p
Leaf p
p
                      Yes v
v Quadrants pts
qs -> v -> Quadrants (Tree v p) -> Tree v p
forall v p. v -> Quadrants (Tree v p) -> Tree v p
Node v
v (Quadrants (Tree v p) -> Tree v p)
-> Quadrants (Tree v p) -> Tree v p
forall a b. (a -> b) -> a -> b
$ Cell r -> pts -> Tree v p
build' (Cell r -> pts -> Tree v p)
-> Corners (Cell r) -> Corners (pts -> Tree v p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cell r -> Corners (Cell r)
forall r. (Num r, Fractional r) => Cell r -> Quadrants (Cell r)
splitCell Cell r
cc Corners (pts -> Tree v p) -> Quadrants pts -> Quadrants (Tree v p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Quadrants pts
qs

-- | Annotate the tree with its corresponing cells
withCells :: Fractional r => Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r)
withCells :: Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r)
withCells Cell r
c0 = \case
  Leaf p
p    -> (p :+ Cell r) -> Tree (v :+ Cell r) (p :+ Cell r)
forall v p. p -> Tree v p
Leaf (p
p p -> Cell r -> p :+ Cell r
forall core extra. core -> extra -> core :+ extra
:+ Cell r
c0)
  Node v
v Quadrants (Tree v p)
qs -> (v :+ Cell r)
-> Quadrants (Tree (v :+ Cell r) (p :+ Cell r))
-> Tree (v :+ Cell r) (p :+ Cell r)
forall v p. v -> Quadrants (Tree v p) -> Tree v p
Node (v
v v -> Cell r -> v :+ Cell r
forall core extra. core -> extra -> core :+ extra
:+ Cell r
c0) (Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r)
forall r v p.
Fractional r =>
Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r)
withCells (Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r))
-> Corners (Cell r)
-> Corners (Tree v p -> Tree (v :+ Cell r) (p :+ Cell r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cell r -> Corners (Cell r)
forall r. (Num r, Fractional r) => Cell r -> Quadrants (Cell r)
splitCell Cell r
c0 Corners (Tree v p -> Tree (v :+ Cell r) (p :+ Cell r))
-> Quadrants (Tree v p)
-> Quadrants (Tree (v :+ Cell r) (p :+ Cell r))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Quadrants (Tree v p)
qs)


--------------------------------------------------------------------------------


-- | Build a QuadtTree from a set of points.
--
-- pre: the points lie inside the initial given cell.
--
-- running time: \(O(nh)\), where \(n\) is the number of points and
-- \(h\) is the height of the resulting quadTree.
fromPoints :: (Fractional r, Ord r)
           => Cell r -> [Point 2 r :+ p]
           -> Tree () (Maybe (Point 2 r :+ p))
fromPoints :: Cell r -> [Point 2 r :+ p] -> Tree () (Maybe (Point 2 r :+ p))
fromPoints = Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
-> Cell r -> [Point 2 r :+ p] -> Tree () (Maybe (Point 2 r :+ p))
forall r pts v p.
Fractional r =>
Splitter r pts v p -> Cell r -> pts -> Tree v p
build Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
forall r p.
(Fractional r, Ord r) =>
Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
fromPointsF

-- | The function that can be used to build a quadTree 'fromPoints'
fromPointsF   :: (Fractional r, Ord r)
              => Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
fromPointsF :: Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
fromPointsF Cell r
c = \case
      []   -> Maybe (Point 2 r :+ p)
-> Split [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
forall i v p. p -> Split i v p
No Maybe (Point 2 r :+ p)
forall a. Maybe a
Nothing
      [Point 2 r :+ p
p]  -> Maybe (Point 2 r :+ p)
-> Split [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
forall i v p. p -> Split i v p
No ((Point 2 r :+ p) -> Maybe (Point 2 r :+ p)
forall a. a -> Maybe a
Just Point 2 r :+ p
p)
      [Point 2 r :+ p]
pts  -> ()
-> Quadrants [Point 2 r :+ p]
-> Split [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
forall i v p. v -> Quadrants i -> Split i v p
Yes () (Quadrants [Point 2 r :+ p]
 -> Split [Point 2 r :+ p] () (Maybe (Point 2 r :+ p)))
-> Quadrants [Point 2 r :+ p]
-> Split [Point 2 r :+ p] () (Maybe (Point 2 r :+ p))
forall a b. (a -> b) -> a -> b
$ Cell r -> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p]
forall r p.
(Fractional r, Ord r) =>
Cell r -> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p]
partitionPoints Cell r
c [Point 2 r :+ p]
pts
        -- (\cell -> filter (`inCell` cell) pts) <$> splitCell c