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

import           Control.Lens hiding (element)
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Geometry.Point
import qualified Data.Geometry.RangeTree.Generic as GRT
import           Data.Geometry.RangeTree.Measure
import           Data.Geometry.Vector
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Measured.Class
import           Data.Proxy
import           Data.Range
import           GHC.TypeLits
import           Prelude hiding (last,init,head)

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

type RangeTree d = RT d d

newtype RT i d v p r =
  RangeTree { RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r
_unRangeTree :: GRT.RangeTree (Assoc i d v p r) (Leaf i d v p r) r }

deriving instance (Show r, Show (Assoc i d v p r), Show (Leaf i d v p r)) => Show (RT i d v p r)
deriving instance (Eq r,   Eq   (Assoc i d v p r), Eq   (Leaf i d v p r)) => Eq   (RT i d v p r)

newtype Leaf i d v p r = Leaf { Leaf i d v p r -> [Point d r :+ p]
_getPts :: [Point d r :+ p]} deriving (b -> Leaf i d v p r -> Leaf i d v p r
NonEmpty (Leaf i d v p r) -> Leaf i d v p r
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
(Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r)
-> (NonEmpty (Leaf i d v p r) -> Leaf i d v p r)
-> (forall b. Integral b => b -> Leaf i d v p r -> Leaf i d v p r)
-> Semigroup (Leaf i d v p r)
forall b. Integral b => b -> Leaf i d v p r -> Leaf i d v p r
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (i :: k) (d :: Nat) k (v :: k) p r.
NonEmpty (Leaf i d v p r) -> Leaf i d v p r
forall k (i :: k) (d :: Nat) k (v :: k) p r.
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
forall k (i :: k) (d :: Nat) k (v :: k) p r b.
Integral b =>
b -> Leaf i d v p r -> Leaf i d v p r
stimes :: b -> Leaf i d v p r -> Leaf i d v p r
$cstimes :: forall k (i :: k) (d :: Nat) k (v :: k) p r b.
Integral b =>
b -> Leaf i d v p r -> Leaf i d v p r
sconcat :: NonEmpty (Leaf i d v p r) -> Leaf i d v p r
$csconcat :: forall k (i :: k) (d :: Nat) k (v :: k) p r.
NonEmpty (Leaf i d v p r) -> Leaf i d v p r
<> :: Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
$c<> :: forall k (i :: k) (d :: Nat) k (v :: k) p r.
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
Semigroup,Semigroup (Leaf i d v p r)
Leaf i d v p r
Semigroup (Leaf i d v p r)
-> Leaf i d v p r
-> (Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r)
-> ([Leaf i d v p r] -> Leaf i d v p r)
-> Monoid (Leaf i d v p r)
[Leaf i d v p r] -> Leaf i d v p r
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (i :: k) (d :: Nat) k (v :: k) p r.
Semigroup (Leaf i d v p r)
forall k (i :: k) (d :: Nat) k (v :: k) p r. Leaf i d v p r
forall k (i :: k) (d :: Nat) k (v :: k) p r.
[Leaf i d v p r] -> Leaf i d v p r
forall k (i :: k) (d :: Nat) k (v :: k) p r.
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
mconcat :: [Leaf i d v p r] -> Leaf i d v p r
$cmconcat :: forall k (i :: k) (d :: Nat) k (v :: k) p r.
[Leaf i d v p r] -> Leaf i d v p r
mappend :: Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
$cmappend :: forall k (i :: k) (d :: Nat) k (v :: k) p r.
Leaf i d v p r -> Leaf i d v p r -> Leaf i d v p r
mempty :: Leaf i d v p r
$cmempty :: forall k (i :: k) (d :: Nat) k (v :: k) p r. Leaf i d v p r
$cp1Monoid :: forall k (i :: k) (d :: Nat) k (v :: k) p r.
Semigroup (Leaf i d v p r)
Monoid)

deriving instance (Show r, Show p, Arity d) => Show (Leaf i d v p r)
deriving instance (Eq r, Eq p,     Arity d) => Eq   (Leaf i d v p r)


type family AssocT i d v p r where
  AssocT 1 d v p r = v (Point d r :+ p)
  AssocT 2 d v p r = Maybe (RT 1 d v p r)

newtype Assoc i d v p r = Assoc { Assoc i d v p r -> AssocT i d v p r
unAssoc :: AssocT i d v p r }

deriving instance Show (AssocT i d v p r) => Show (Assoc i d v p r)
deriving instance Eq   (AssocT i d v p r) => Eq   (Assoc i d v p r)


type RTMeasure v d p r = (LabeledMeasure v, Semigroup (v (Point d r :+ p)))

instance RTMeasure v d p r => Semigroup (Assoc 1 d v p r) where
  (Assoc AssocT 1 d v p r
l) <> :: Assoc 1 d v p r -> Assoc 1 d v p r -> Assoc 1 d v p r
<> (Assoc AssocT 1 d v p r
r) = AssocT 1 d v p r -> Assoc 1 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
AssocT i d v p r -> Assoc i d v p r
Assoc (AssocT 1 d v p r -> Assoc 1 d v p r)
-> AssocT 1 d v p r -> Assoc 1 d v p r
forall a b. (a -> b) -> a -> b
$ v (Point d r :+ p)
AssocT 1 d v p r
l v (Point d r :+ p) -> v (Point d r :+ p) -> v (Point d r :+ p)
forall a. Semigroup a => a -> a -> a
<> v (Point d r :+ p)
AssocT 1 d v p r
r

instance (RTMeasure v d p r, Ord r, 1 <= d, Arity d) => Semigroup (Assoc 2 d v p r) where
  (Assoc AssocT 2 d v p r
l) <> :: Assoc 2 d v p r -> Assoc 2 d v p r -> Assoc 2 d v p r
<> (Assoc AssocT 2 d v p r
r) = Maybe (RT 1 d v p r) -> Assoc 2 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
AssocT i d v p r -> Assoc i d v p r
Assoc (Maybe (RT 1 d v p r) -> Assoc 2 d v p r)
-> ([Point d r :+ p] -> Maybe (RT 1 d v p r))
-> [Point d r :+ p]
-> Assoc 2 d v p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> Maybe (RT 1 d v p r)
createRangeTree'' ([Point d r :+ p] -> Assoc 2 d v p r)
-> [Point d r :+ p] -> Assoc 2 d v p r
forall a b. (a -> b) -> a -> b
$ Maybe (RT 1 d v p r) -> [Point d r :+ p]
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
Maybe (RT i d v p r) -> [Point d r :+ p]
toList Maybe (RT 1 d v p r)
AssocT 2 d v p r
l [Point d r :+ p] -> [Point d r :+ p] -> [Point d r :+ p]
forall a. Semigroup a => a -> a -> a
<> Maybe (RT 1 d v p r) -> [Point d r :+ p]
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
Maybe (RT i d v p r) -> [Point d r :+ p]
toList Maybe (RT 1 d v p r)
AssocT 2 d v p r
r
    where
      toList :: Maybe (RT i d v p r) -> [Point d r :+ p]
toList = [Point d r :+ p]
-> (RT i d v p r -> [Point d r :+ p])
-> Maybe (RT i d v p r)
-> [Point d r :+ p]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Point d r :+ p] -> [Point d r :+ p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList ([Point d r :+ p] -> [Point d r :+ p])
-> (RT i d v p r -> [Point d r :+ p])
-> RT i d v p r
-> [Point d r :+ p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RT i d v p r -> [Point d r :+ p]
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RT i d v p r -> [Point d r :+ p]
toAscList)
      createRangeTree'' :: [Point d r :+ p] -> Maybe (RT 1 d v p r)
createRangeTree'' = (NonEmpty (Point d r :+ p) -> RT 1 d v p r)
-> Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT 1 d v p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Point d r :+ p) -> RT 1 d v p r
forall r (v :: * -> *) (d :: Nat) p.
(Ord r, RTMeasure v d p r, 1 <= d, Arity d) =>
NonEmpty (Point d r :+ p) -> RT 1 d v p r
createRangeTree1 (Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT 1 d v p r))
-> ([Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p)))
-> [Point d r :+ p]
-> Maybe (RT 1 d v p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty



instance (RTMeasure v d p r, Ord r, 1 <= d, Arity d) => Monoid (Assoc 2 d v p r) where
  mempty :: Assoc 2 d v p r
mempty = AssocT 2 d v p r -> Assoc 2 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
AssocT i d v p r -> Assoc i d v p r
Assoc AssocT 2 d v p r
forall a. Maybe a
Nothing

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

instance ( RTMeasure v d p r
         ) => Measured (Assoc 1 d v p r) (Leaf 1 d v p r) where
  measure :: Leaf 1 d v p r -> Assoc 1 d v p r
measure (Leaf [Point d r :+ p]
pts) = v (Point d r :+ p) -> Assoc 1 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
AssocT i d v p r -> Assoc i d v p r
Assoc (v (Point d r :+ p) -> Assoc 1 d v p r)
-> ([Point d r :+ p] -> v (Point d r :+ p))
-> [Point d r :+ p]
-> Assoc 1 d v p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> v (Point d r :+ p)
forall (v :: * -> *) a. LabeledMeasure v => [a] -> v a
labeledMeasure ([Point d r :+ p] -> Assoc 1 d v p r)
-> [Point d r :+ p] -> Assoc 1 d v p r
forall a b. (a -> b) -> a -> b
$ [Point d r :+ p]
pts

instance ( RTMeasure v d p r, Ord r, 1 <= d, Arity d
         ) => Measured (Assoc 2 d v p r) (Leaf 2 d v p r) where
  measure :: Leaf 2 d v p r -> Assoc 2 d v p r
measure (Leaf [Point d r :+ p]
pts) = Maybe (RT 1 d v p r) -> Assoc 2 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
AssocT i d v p r -> Assoc i d v p r
Assoc (Maybe (RT 1 d v p r) -> Assoc 2 d v p r)
-> ([Point d r :+ p] -> Maybe (RT 1 d v p r))
-> [Point d r :+ p]
-> Assoc 2 d v p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> Maybe (RT 1 d v p r)
createRangeTree'' ([Point d r :+ p] -> Assoc 2 d v p r)
-> [Point d r :+ p] -> Assoc 2 d v p r
forall a b. (a -> b) -> a -> b
$ [Point d r :+ p]
pts
    where
      createRangeTree'' :: [Point d r :+ p] -> Maybe (RT 1 d v p r)
createRangeTree'' = (NonEmpty (Point d r :+ p) -> RT 1 d v p r)
-> Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT 1 d v p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Point d r :+ p) -> RT 1 d v p r
forall r (v :: * -> *) (d :: Nat) p.
(Ord r, RTMeasure v d p r, 1 <= d, Arity d) =>
NonEmpty (Point d r :+ p) -> RT 1 d v p r
createRangeTree1 (Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT 1 d v p r))
-> ([Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p)))
-> [Point d r :+ p]
-> Maybe (RT 1 d v p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty

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

createRangeTree' :: (Ord r, RTMeasure v d p r
                   -- , Arity d, Arity (d+1), d ~ (d' + 1), Arity d'
                   -- , Measured (Assoc d v p r) (Leaf d v p r)
                   )
                 => [Point d r :+ p] -> Maybe (RT i d v p r)
createRangeTree' :: [Point d r :+ p] -> Maybe (RT i d v p r)
createRangeTree' = (NonEmpty (Point d r :+ p) -> RT i d v p r)
-> Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT i d v p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Point d r :+ p) -> RT i d v p r
forall r (v :: * -> *) (d :: Nat) p (i :: Nat).
(Ord r, RTMeasure v d p r) =>
NonEmpty (Point d r :+ p) -> RT i d v p r
createRangeTree (Maybe (NonEmpty (Point d r :+ p)) -> Maybe (RT i d v p r))
-> ([Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p)))
-> [Point d r :+ p]
-> Maybe (RT i d v p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r :+ p] -> Maybe (NonEmpty (Point d r :+ p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty


createRangeTree :: (Ord r, RTMeasure v d p r
                   -- , Arity d, Arity (d+1), d ~ (d' + 1), Arity d'
                   -- , Measured (Assoc d v p r) (Leaf d v p r)
                   )
                => NonEmpty (Point d r :+ p) -> RT i d v p r
createRangeTree :: NonEmpty (Point d r :+ p) -> RT i d v p r
createRangeTree = NonEmpty (Point d r :+ p) -> RT i d v p r
forall a. HasCallStack => a
undefined
-- RangeTree . GRT.createTree
--                 . fmap (\p -> last (p^.core.vector) :+ Leaf [p])


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

-- | Gets all points in the range tree
toAscList :: RT i d v p r -> [Point d r :+ p]
toAscList :: RT i d v p r -> [Point d r :+ p]
toAscList = ((r :+ Leaf i d v p r) -> [Point d r :+ p])
-> [r :+ Leaf i d v p r] -> [Point d r :+ p]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((r :+ Leaf i d v p r)
-> Getting [Point d r :+ p] (r :+ Leaf i d v p r) [Point d r :+ p]
-> [Point d r :+ p]
forall s a. s -> Getting a s a -> a
^.(Leaf i d v p r -> Const [Point d r :+ p] (Leaf i d v p r))
-> (r :+ Leaf i d v p r)
-> Const [Point d r :+ p] (r :+ Leaf i d v p r)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra((Leaf i d v p r -> Const [Point d r :+ p] (Leaf i d v p r))
 -> (r :+ Leaf i d v p r)
 -> Const [Point d r :+ p] (r :+ Leaf i d v p r))
-> (([Point d r :+ p] -> Const [Point d r :+ p] [Point d r :+ p])
    -> Leaf i d v p r -> Const [Point d r :+ p] (Leaf i d v p r))
-> Getting [Point d r :+ p] (r :+ Leaf i d v p r) [Point d r :+ p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Leaf i d v p r -> [Point d r :+ p])
-> ([Point d r :+ p] -> Const [Point d r :+ p] [Point d r :+ p])
-> Leaf i d v p r
-> Const [Point d r :+ p] (Leaf i d v p r)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Leaf i d v p r -> [Point d r :+ p]
forall k (i :: k) (d :: Nat) k (v :: k) p r.
Leaf i d v p r -> [Point d r :+ p]
_getPts) ([r :+ Leaf i d v p r] -> [Point d r :+ p])
-> (RT i d v p r -> [r :+ Leaf i d v p r])
-> RT i d v p r
-> [Point d r :+ p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (r :+ Leaf i d v p r) -> [r :+ Leaf i d v p r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (NonEmpty (r :+ Leaf i d v p r) -> [r :+ Leaf i d v p r])
-> (RT i d v p r -> NonEmpty (r :+ Leaf i d v p r))
-> RT i d v p r
-> [r :+ Leaf i d v p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeTree (Assoc i d v p r) (Leaf i d v p r) r
-> NonEmpty (r :+ Leaf i d v p r)
forall v p r. RangeTree v p r -> NonEmpty (r :+ p)
GRT.toAscList (RangeTree (Assoc i d v p r) (Leaf i d v p r) r
 -> NonEmpty (r :+ Leaf i d v p r))
-> (RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r)
-> RT i d v p r
-> NonEmpty (r :+ Leaf i d v p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r
_unRangeTree


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

createRangeTree1 :: (Ord r, RTMeasure v d p r, 1 <= d, Arity d)
                 => NonEmpty (Point d r :+ p) -> RT 1 d v p r
createRangeTree1 :: NonEmpty (Point d r :+ p) -> RT 1 d v p r
createRangeTree1 = RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r -> RT 1 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RangeTree (Assoc i d v p r) (Leaf i d v p r) r -> RT i d v p r
RangeTree (RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r -> RT 1 d v p r)
-> (NonEmpty (Point d r :+ p)
    -> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r)
-> NonEmpty (Point d r :+ p)
-> RT 1 d v p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (r :+ Leaf 1 d v p r)
-> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r
forall r v p.
(Ord r, Measured v p, Semigroup p) =>
NonEmpty (r :+ p) -> RangeTree v p r
GRT.createTree
                (NonEmpty (r :+ Leaf 1 d v p r)
 -> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r)
-> (NonEmpty (Point d r :+ p) -> NonEmpty (r :+ Leaf 1 d v p r))
-> NonEmpty (Point d r :+ p)
-> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point d r :+ p) -> r :+ Leaf 1 d v p r)
-> NonEmpty (Point d r :+ p) -> NonEmpty (r :+ Leaf 1 d v p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Point d r :+ p
p -> Vector d r -> r
forall (d :: Nat) r. (Arity d, 1 <= d) => Vector d r -> r
head (Point d r :+ p
p(Point d r :+ p)
-> Getting (Vector d r) (Point d r :+ p) (Vector d r) -> Vector d r
forall s a. s -> Getting a s a -> a
^.(Point d r -> Const (Vector d r) (Point d r))
-> (Point d r :+ p) -> Const (Vector d r) (Point d r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point d r -> Const (Vector d r) (Point d r))
 -> (Point d r :+ p) -> Const (Vector d r) (Point d r :+ p))
-> ((Vector d r -> Const (Vector d r) (Vector d r))
    -> Point d r -> Const (Vector d r) (Point d r))
-> Getting (Vector d r) (Point d r :+ p) (Vector d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vector d r -> Const (Vector d r) (Vector d r))
-> Point d r -> Const (Vector d r) (Point d r)
forall (d :: Nat) r r'.
Lens (Point d r) (Point d r') (Vector d r) (Vector d r')
vector) r -> Leaf 1 d v p r -> r :+ Leaf 1 d v p r
forall core extra. core -> extra -> core :+ extra
:+ [Point d r :+ p] -> Leaf 1 d v p r
forall k k (i :: k) (d :: Nat) (v :: k) p r.
[Point d r :+ p] -> Leaf i d v p r
Leaf [Point d r :+ p
p])

createRangeTree2 :: forall v d r p. (Ord r, RTMeasure v d p r, Arity d, 2 <= d
                                    , 1 <= d -- this one is kind of silly
                 ) => NonEmpty (Point d r :+ p) -> RT 2 d v p r
createRangeTree2 :: NonEmpty (Point d r :+ p) -> RT 2 d v p r
createRangeTree2 = RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r -> RT 2 d v p r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RangeTree (Assoc i d v p r) (Leaf i d v p r) r -> RT i d v p r
RangeTree (RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r -> RT 2 d v p r)
-> (NonEmpty (Point d r :+ p)
    -> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r)
-> NonEmpty (Point d r :+ p)
-> RT 2 d v p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (r :+ Leaf 2 d v p r)
-> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r
forall r v p.
(Ord r, Measured v p, Semigroup p) =>
NonEmpty (r :+ p) -> RangeTree v p r
GRT.createTree
                 (NonEmpty (r :+ Leaf 2 d v p r)
 -> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r)
-> (NonEmpty (Point d r :+ p) -> NonEmpty (r :+ Leaf 2 d v p r))
-> NonEmpty (Point d r :+ p)
-> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point d r :+ p) -> r :+ Leaf 2 d v p r)
-> NonEmpty (Point d r :+ p) -> NonEmpty (r :+ Leaf 2 d v p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Point d r :+ p
p -> Point d r :+ p
p(Point d r :+ p) -> Getting r (Point d r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point d r -> Const r (Point d r))
-> (Point d r :+ p) -> Const r (Point d r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point d r -> Const r (Point d r))
 -> (Point d r :+ p) -> Const r (Point d r :+ p))
-> ((r -> Const r r) -> Point d r -> Const r (Point d r))
-> Getting r (Point d r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Proxy 2 -> Lens' (Point d r) r
forall (i :: Nat) (d :: Nat) (p :: Nat -> * -> *)
       (proxy :: Nat -> *) r.
(1 <= i, i <= d, KnownNat i, Arity d, AsAPoint p) =>
proxy i -> Lens' (p d r) r
coord (Proxy 2
forall k (t :: k). Proxy t
Proxy :: Proxy 2) r -> Leaf 2 d v p r -> r :+ Leaf 2 d v p r
forall core extra. core -> extra -> core :+ extra
:+ [Point d r :+ p] -> Leaf 2 d v p r
forall k k (i :: k) (d :: Nat) (v :: k) p r.
[Point d r :+ p] -> Leaf i d v p r
Leaf [Point d r :+ p
p])

--------------------------------------------------------------------------------
-- * Querying


search   :: ( Ord r, Monoid (v (Point d r :+ p)), Query i d)
         => Vector d (Range r) -> RT i d v p r -> v (Point d r :+ p)
search :: Vector d (Range r) -> RT i d v p r -> v (Point d r :+ p)
search Vector d (Range r)
r = [v (Point d r :+ p)] -> v (Point d r :+ p)
forall a. Monoid a => [a] -> a
mconcat ([v (Point d r :+ p)] -> v (Point d r :+ p))
-> (RT i d v p r -> [v (Point d r :+ p)])
-> RT i d v p r
-> v (Point d r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector d (Range r) -> RT i d v p r -> [v (Point d r :+ p)]
forall (i :: Nat) (d :: Nat) r (v :: * -> *) p.
(Query i d, Ord r) =>
Vector d (Range r) -> RT i d v p r -> [v (Point d r :+ p)]
search' Vector d (Range r)
r


class (i <= d, Arity d) => Query i d where
  search' :: Ord r => Vector d (Range r) -> RT i d v p r -> [v (Point d r :+ p)]

instance (1 <= d, Arity d) => Query 1 d where
  search' :: Vector d (Range r) -> RT 1 d v p r -> [v (Point d r :+ p)]
search' Vector d (Range r)
qr = (Assoc 1 d v p r -> v (Point d r :+ p))
-> [Assoc 1 d v p r] -> [v (Point d r :+ p)]
forall a b. (a -> b) -> [a] -> [b]
map Assoc 1 d v p r -> v (Point d r :+ p)
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
Assoc i d v p r -> AssocT i d v p r
unAssoc ([Assoc 1 d v p r] -> [v (Point d r :+ p)])
-> (RT 1 d v p r -> [Assoc 1 d v p r])
-> RT 1 d v p r
-> [v (Point d r :+ p)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range r
-> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r
-> [Assoc 1 d v p r]
forall r v p. Ord r => Range r -> RangeTree v p r -> [v]
GRT.search' Range r
r (RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r
 -> [Assoc 1 d v p r])
-> (RT 1 d v p r -> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r)
-> RT 1 d v p r
-> [Assoc 1 d v p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RT 1 d v p r -> RangeTree (Assoc 1 d v p r) (Leaf 1 d v p r) r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r
_unRangeTree
    where
      r :: Range r
r = Vector d (Range r)
qrVector d (Range r)
-> Getting (Range r) (Vector d (Range r)) (Range r) -> Range r
forall s a. s -> Getting a s a -> a
^.Proxy 0 -> Lens' (Vector d (Range r)) (Range r)
forall (proxy :: Nat -> *) (i :: Nat) (d :: Nat) r.
(Arity d, KnownNat i, (i + 1) <= d) =>
proxy i -> Lens' (Vector d r) r
element (Proxy 0
forall k (t :: k). Proxy t
Proxy :: Proxy 0)

instance ( 1 <= d, i <= d, Query (i-1) d, Arity d
         , i ~ 2
         ) => Query 2 d where
  search' :: Vector d (Range r) -> RT 2 d v p r -> [v (Point d r :+ p)]
search' Vector d (Range r)
qr = (Assoc 2 d v p r -> [v (Point d r :+ p)])
-> [Assoc 2 d v p r] -> [v (Point d r :+ p)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([v (Point d r :+ p)]
-> (RT 1 d v p r -> [v (Point d r :+ p)])
-> Maybe (RT 1 d v p r)
-> [v (Point d r :+ p)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Vector d (Range r) -> RT 1 d v p r -> [v (Point d r :+ p)]
forall (i :: Nat) (d :: Nat) r (v :: * -> *) p.
(Query i d, Ord r) =>
Vector d (Range r) -> RT i d v p r -> [v (Point d r :+ p)]
search' Vector d (Range r)
qr) (Maybe (RT 1 d v p r) -> [v (Point d r :+ p)])
-> (Assoc 2 d v p r -> Maybe (RT 1 d v p r))
-> Assoc 2 d v p r
-> [v (Point d r :+ p)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Assoc 2 d v p r -> Maybe (RT 1 d v p r)
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
Assoc i d v p r -> AssocT i d v p r
unAssoc) ([Assoc 2 d v p r] -> [v (Point d r :+ p)])
-> (RT 2 d v p r -> [Assoc 2 d v p r])
-> RT 2 d v p r
-> [v (Point d r :+ p)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range r
-> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r
-> [Assoc 2 d v p r]
forall r v p. Ord r => Range r -> RangeTree v p r -> [v]
GRT.search' Range r
r (RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r
 -> [Assoc 2 d v p r])
-> (RT 2 d v p r -> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r)
-> RT 2 d v p r
-> [Assoc 2 d v p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RT 2 d v p r -> RangeTree (Assoc 2 d v p r) (Leaf 2 d v p r) r
forall (i :: Nat) (d :: Nat) (v :: * -> *) p r.
RT i d v p r -> RangeTree (Assoc i d v p r) (Leaf i d v p r) r
_unRangeTree
    where
      r :: Range r
r = Vector d (Range r)
qrVector d (Range r)
-> Getting (Range r) (Vector d (Range r)) (Range r) -> Range r
forall s a. s -> Getting a s a -> a
^.Proxy 1 -> Lens' (Vector d (Range r)) (Range r)
forall (proxy :: Nat -> *) (i :: Nat) (d :: Nat) r.
(Arity d, KnownNat i, (i + 1) <= d) =>
proxy i -> Lens' (Vector d r) r
element (Proxy (i - 1)
forall k (t :: k). Proxy t
Proxy :: Proxy (i-1))