--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.PrioritySearchTree
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Implements a linear size data structure for three-sided range
-- queries in \(\mathbb{R}^2\). See
--
-- McCreight, Edward (May 1985). "Priority search trees".
-- SIAM Journal on Scientific Computing. 14 (2): 257-276.
--
-- for more details.
--
--------------------------------------------------------------------------------
module Data.Geometry.PrioritySearchTree( PrioritySearchTree(..)
                                       , createTree
                                       , queryRange
                                       ) where

import           Algorithms.DivideAndConquer (mergeSortedListsBy)
import           Control.Lens
import           Data.BinaryTree
import           Data.Ext
import           Data.Geometry.Point
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Measured.Class ()
import           Data.Measured.Size
import           Data.Ord (comparing, Down(..))
import           Data.Range
import qualified Data.Set as Set
import           Data.Util
--------------------------------------------------------------------------------

-- | Internal nodes store the max x-value from the left subtree and
-- the point that has globally the max-y coordinate.
data NodeData p r = NodeData { NodeData p r -> r
_splitPoint :: !r
                             , NodeData p r -> Maybe (Point 2 r :+ p)
_maxVal     :: !(Maybe (Point 2 r :+ p))
                             } deriving (Int -> NodeData p r -> ShowS
[NodeData p r] -> ShowS
NodeData p r -> String
(Int -> NodeData p r -> ShowS)
-> (NodeData p r -> String)
-> ([NodeData p r] -> ShowS)
-> Show (NodeData p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r. (Show r, Show p) => Int -> NodeData p r -> ShowS
forall p r. (Show r, Show p) => [NodeData p r] -> ShowS
forall p r. (Show r, Show p) => NodeData p r -> String
showList :: [NodeData p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [NodeData p r] -> ShowS
show :: NodeData p r -> String
$cshow :: forall p r. (Show r, Show p) => NodeData p r -> String
showsPrec :: Int -> NodeData p r -> ShowS
$cshowsPrec :: forall p r. (Show r, Show p) => Int -> NodeData p r -> ShowS
Show,NodeData p r -> NodeData p r -> Bool
(NodeData p r -> NodeData p r -> Bool)
-> (NodeData p r -> NodeData p r -> Bool) -> Eq (NodeData p r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p r. (Eq r, Eq p) => NodeData p r -> NodeData p r -> Bool
/= :: NodeData p r -> NodeData p r -> Bool
$c/= :: forall p r. (Eq r, Eq p) => NodeData p r -> NodeData p r -> Bool
== :: NodeData p r -> NodeData p r -> Bool
$c== :: forall p r. (Eq r, Eq p) => NodeData p r -> NodeData p r -> Bool
Eq)

instance Bifunctor NodeData where
  bimap :: (a -> b) -> (c -> d) -> NodeData a c -> NodeData b d
bimap a -> b
f c -> d
g (NodeData c
x Maybe (Point 2 c :+ a)
m) = d -> Maybe (Point 2 d :+ b) -> NodeData b d
forall p r. r -> Maybe (Point 2 r :+ p) -> NodeData p r
NodeData (c -> d
g c
x) ((Point 2 c -> Point 2 d)
-> (a -> b) -> (Point 2 c :+ a) -> Point 2 d :+ b
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((c -> d) -> Point 2 c -> Point 2 d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) a -> b
f ((Point 2 c :+ a) -> Point 2 d :+ b)
-> Maybe (Point 2 c :+ a) -> Maybe (Point 2 d :+ b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Point 2 c :+ a)
m)

maxVal :: Lens' (NodeData p r) (Maybe (Point 2 r :+ p))
maxVal :: (Maybe (Point 2 r :+ p) -> f (Maybe (Point 2 r :+ p)))
-> NodeData p r -> f (NodeData p r)
maxVal = (NodeData p r -> Maybe (Point 2 r :+ p))
-> (NodeData p r -> Maybe (Point 2 r :+ p) -> NodeData p r)
-> Lens
     (NodeData p r)
     (NodeData p r)
     (Maybe (Point 2 r :+ p))
     (Maybe (Point 2 r :+ p))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens NodeData p r -> Maybe (Point 2 r :+ p)
forall p r. NodeData p r -> Maybe (Point 2 r :+ p)
_maxVal (\(NodeData r
x Maybe (Point 2 r :+ p)
_) Maybe (Point 2 r :+ p)
m -> r -> Maybe (Point 2 r :+ p) -> NodeData p r
forall p r. r -> Maybe (Point 2 r :+ p) -> NodeData p r
NodeData r
x Maybe (Point 2 r :+ p)
m)


type LeafData p r = SP r [Point 2 r :+ p]

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

-- | A priority search tree storing points in \(\mathbb{R}^2) that
-- have an additional payload of type p.
newtype PrioritySearchTree p r =
    PrioritySearchTree { PrioritySearchTree p r -> BinLeafTree (NodeData p r) (LeafData p r)
_unPrioritySearchTree :: BinLeafTree (NodeData p r) (LeafData p r) }
  deriving (Int -> PrioritySearchTree p r -> ShowS
[PrioritySearchTree p r] -> ShowS
PrioritySearchTree p r -> String
(Int -> PrioritySearchTree p r -> ShowS)
-> (PrioritySearchTree p r -> String)
-> ([PrioritySearchTree p r] -> ShowS)
-> Show (PrioritySearchTree p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r.
(Show r, Show p) =>
Int -> PrioritySearchTree p r -> ShowS
forall p r. (Show r, Show p) => [PrioritySearchTree p r] -> ShowS
forall p r. (Show r, Show p) => PrioritySearchTree p r -> String
showList :: [PrioritySearchTree p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [PrioritySearchTree p r] -> ShowS
show :: PrioritySearchTree p r -> String
$cshow :: forall p r. (Show r, Show p) => PrioritySearchTree p r -> String
showsPrec :: Int -> PrioritySearchTree p r -> ShowS
$cshowsPrec :: forall p r.
(Show r, Show p) =>
Int -> PrioritySearchTree p r -> ShowS
Show,PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
(PrioritySearchTree p r -> PrioritySearchTree p r -> Bool)
-> (PrioritySearchTree p r -> PrioritySearchTree p r -> Bool)
-> Eq (PrioritySearchTree p r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p r.
(Eq r, Eq p) =>
PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
/= :: PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
$c/= :: forall p r.
(Eq r, Eq p) =>
PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
== :: PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
$c== :: forall p r.
(Eq r, Eq p) =>
PrioritySearchTree p r -> PrioritySearchTree p r -> Bool
Eq)

instance Bifunctor PrioritySearchTree where
  -- ^ note that this is not necessarily safe, as mapping over r can
  -- invalidate the invariants. Users are responsible for making sure
  -- this does not happen.
  bimap :: (a -> b)
-> (c -> d) -> PrioritySearchTree a c -> PrioritySearchTree b d
bimap a -> b
f c -> d
g (PrioritySearchTree BinLeafTree (NodeData a c) (LeafData a c)
t) = BinLeafTree (NodeData b d) (LeafData b d) -> PrioritySearchTree b d
forall p r.
BinLeafTree (NodeData p r) (LeafData p r) -> PrioritySearchTree p r
PrioritySearchTree (BinLeafTree (NodeData b d) (LeafData b d)
 -> PrioritySearchTree b d)
-> (BinLeafTree (NodeData a c) (LeafData a c)
    -> BinLeafTree (NodeData b d) (LeafData b d))
-> BinLeafTree (NodeData a c) (LeafData a c)
-> PrioritySearchTree b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeData a c -> NodeData b d)
-> (LeafData a c -> LeafData b d)
-> BinLeafTree (NodeData a c) (LeafData a c)
-> BinLeafTree (NodeData b d) (LeafData b d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((a -> b) -> (c -> d) -> NodeData a c -> NodeData b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) LeafData a c -> LeafData b d
h (BinLeafTree (NodeData a c) (LeafData a c)
 -> PrioritySearchTree b d)
-> BinLeafTree (NodeData a c) (LeafData a c)
-> PrioritySearchTree b d
forall a b. (a -> b) -> a -> b
$ BinLeafTree (NodeData a c) (LeafData a c)
t
    where
      h :: LeafData a c -> LeafData b d
h = (c -> d)
-> ([Point 2 c :+ a] -> [Point 2 d :+ b])
-> LeafData a c
-> LeafData b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap c -> d
g (((Point 2 c :+ a) -> Point 2 d :+ b)
-> [Point 2 c :+ a] -> [Point 2 d :+ b]
forall a b. (a -> b) -> [a] -> [b]
map (((Point 2 c :+ a) -> Point 2 d :+ b)
 -> [Point 2 c :+ a] -> [Point 2 d :+ b])
-> ((Point 2 c :+ a) -> Point 2 d :+ b)
-> [Point 2 c :+ a]
-> [Point 2 d :+ b]
forall a b. (a -> b) -> a -> b
$ (Point 2 c -> Point 2 d)
-> (a -> b) -> (Point 2 c :+ a) -> Point 2 d :+ b
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((c -> d) -> Point 2 c -> Point 2 d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) a -> b
f)

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

-- | Creates a Priority Search Tree for 3-sided range queries of the
-- form \([x_l,x_r] \times [y,\infty)\).
--
-- the base tree will be static.
--
-- pre: all points have unique x-coordinates
--
-- running time: \(O(n\log n)\)
createTree     :: Ord r => NonEmpty (Point 2 r :+ p) -> PrioritySearchTree p r
createTree :: NonEmpty (Point 2 r :+ p) -> PrioritySearchTree p r
createTree NonEmpty (Point 2 r :+ p)
pts = BinLeafTree (NodeData p r) (LeafData p r) -> PrioritySearchTree p r
forall p r.
BinLeafTree (NodeData p r) (LeafData p r) -> PrioritySearchTree p r
PrioritySearchTree (BinLeafTree (NodeData p r) (LeafData p r)
 -> PrioritySearchTree p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> PrioritySearchTree p r
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p)
 -> BinLeafTree (NodeData p r) (LeafData p r)
 -> BinLeafTree (NodeData p r) (LeafData p r))
-> BinLeafTree (NodeData p r) (LeafData p r)
-> NonEmpty (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall r p.
Ord r =>
(Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
insert BinLeafTree (NodeData p r) (LeafData p r)
t NonEmpty (Point 2 r :+ p)
pts
  where
    t :: BinLeafTree (NodeData p r) (LeafData p r)
t = Getting
  (BinLeafTree (NodeData p r) (LeafData p r))
  (SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
  (BinLeafTree (NodeData p r) (LeafData p r))
-> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
-> BinLeafTree (NodeData p r) (LeafData p r)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (BinLeafTree (NodeData p r) (LeafData p r))
  (SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
  (BinLeafTree (NodeData p r) (LeafData p r))
forall s t a b. Field1 s t a b => Lens s t a b
_1
      (SP (BinLeafTree (NodeData p r) (LeafData p r)) r
 -> BinLeafTree (NodeData p r) (LeafData p r))
-> (NonEmpty (Point 2 r :+ p)
    -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
-> NonEmpty (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SP (BinLeafTree (NodeData p r) (LeafData p r)) r
 -> Size
 -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
 -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
-> (Elem r -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
-> BinLeafTree Size (Elem r)
-> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
forall b v a.
(b -> v -> b -> b) -> (a -> b) -> BinLeafTree v a -> b
foldUp (\(SP BinLeafTree (NodeData p r) (LeafData p r)
l r
k) Size
_ (SP BinLeafTree (NodeData p r) (LeafData p r)
r r
m) -> BinLeafTree (NodeData p r) (LeafData p r)
-> r -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
forall a b. a -> b -> SP a b
SP (BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall v a.
BinLeafTree v a -> v -> BinLeafTree v a -> BinLeafTree v a
Node BinLeafTree (NodeData p r) (LeafData p r)
l (r -> Maybe (Point 2 r :+ p) -> NodeData p r
forall p r. r -> Maybe (Point 2 r :+ p) -> NodeData p r
NodeData r
k Maybe (Point 2 r :+ p)
forall a. Maybe a
Nothing) BinLeafTree (NodeData p r) (LeafData p r)
r) r
m)
               (\(Elem r
x) -> BinLeafTree (NodeData p r) (LeafData p r)
-> r -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
forall a b. a -> b -> SP a b
SP (LeafData p r -> BinLeafTree (NodeData p r) (LeafData p r)
forall v a. a -> BinLeafTree v a
Leaf (r -> [Point 2 r :+ p] -> LeafData p r
forall a b. a -> b -> SP a b
SP r
x [])) r
x)
      (BinLeafTree Size (Elem r)
 -> SP (BinLeafTree (NodeData p r) (LeafData p r)) r)
-> (NonEmpty (Point 2 r :+ p) -> BinLeafTree Size (Elem r))
-> NonEmpty (Point 2 r :+ p)
-> SP (BinLeafTree (NodeData p r) (LeafData p r)) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty r -> BinLeafTree Size (Elem r)
forall a. NonEmpty a -> BinLeafTree Size (Elem a)
asBalancedBinLeafTree (NonEmpty r -> BinLeafTree Size (Elem r))
-> (NonEmpty (Point 2 r :+ p) -> NonEmpty r)
-> NonEmpty (Point 2 r :+ p)
-> BinLeafTree Size (Elem r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> NonEmpty r
forall a. [a] -> NonEmpty a
NonEmpty.fromList
      ([r] -> NonEmpty r)
-> (NonEmpty (Point 2 r :+ p) -> [r])
-> NonEmpty (Point 2 r :+ p)
-> NonEmpty r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set r -> [r]
forall a. Set a -> [a]
Set.toAscList (Set r -> [r])
-> (NonEmpty (Point 2 r :+ p) -> Set r)
-> NonEmpty (Point 2 r :+ p)
-> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList -- remove duplicates + sort
      ([r] -> Set r)
-> (NonEmpty (Point 2 r :+ p) -> [r])
-> NonEmpty (Point 2 r :+ p)
-> Set r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p) -> r) -> [Point 2 r :+ p] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map ((Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) ([Point 2 r :+ p] -> [r])
-> (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p])
-> NonEmpty (Point 2 r :+ p)
-> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (Point 2 r :+ p)
 -> BinLeafTree (NodeData p r) (LeafData p r))
-> NonEmpty (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Point 2 r :+ p)
pts

-- | Inserts a point into the priority search tree
--
-- running time: \(O(\log n)\)
insert                          :: Ord r
                                => Point 2 r :+ p
                                -> BinLeafTree (NodeData p r) (LeafData p r)
                                -> BinLeafTree (NodeData p r) (LeafData p r)
insert :: (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
insert Point 2 r :+ p
p = \case
    Leaf (SP r
x [Point 2 r :+ p]
ps)                                -> LeafData p r -> BinLeafTree (NodeData p r) (LeafData p r)
forall v a. a -> BinLeafTree v a
Leaf (LeafData p r -> BinLeafTree (NodeData p r) (LeafData p r))
-> LeafData p r -> BinLeafTree (NodeData p r) (LeafData p r)
forall a b. (a -> b) -> a -> b
$ r -> [Point 2 r :+ p] -> LeafData p r
forall a b. a -> b -> SP a b
SP r
x (Point 2 r :+ p
p(Point 2 r :+ p) -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. a -> [a] -> [a]
:[Point 2 r :+ p]
ps)
      -- TODO: In case we have multiple points with the same x-coord, these points
      -- are not really in decreasing y-order.
    Node BinLeafTree (NodeData p r) (LeafData p r)
l NodeData p r
d BinLeafTree (NodeData p r) (LeafData p r)
r | Maybe r
py Maybe r -> Maybe r -> Bool
forall a. Ord a => a -> a -> Bool
> NodeData p r
dNodeData p r -> Getting (First r) (NodeData p r) r -> Maybe r
forall s a. s -> Getting (First a) s a -> Maybe a
^?(Maybe (Point 2 r :+ p)
 -> Const (First r) (Maybe (Point 2 r :+ p)))
-> NodeData p r -> Const (First r) (NodeData p r)
forall p r. Lens' (NodeData p r) (Maybe (Point 2 r :+ p))
maxVal((Maybe (Point 2 r :+ p)
  -> Const (First r) (Maybe (Point 2 r :+ p)))
 -> NodeData p r -> Const (First r) (NodeData p r))
-> ((r -> Const (First r) r)
    -> Maybe (Point 2 r :+ p)
    -> Const (First r) (Maybe (Point 2 r :+ p)))
-> Getting (First r) (NodeData p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const (First r) (Point 2 r :+ p))
-> Maybe (Point 2 r :+ p)
-> Const (First r) (Maybe (Point 2 r :+ p))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just(((Point 2 r :+ p) -> Const (First r) (Point 2 r :+ p))
 -> Maybe (Point 2 r :+ p)
 -> Const (First r) (Maybe (Point 2 r :+ p)))
-> ((r -> Const (First r) r)
    -> (Point 2 r :+ p) -> Const (First r) (Point 2 r :+ p))
-> (r -> Const (First r) r)
-> Maybe (Point 2 r :+ p)
-> Const (First r) (Maybe (Point 2 r :+ p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (First r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (First r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const (First r) (Point 2 r))
 -> (Point 2 r :+ p) -> Const (First r) (Point 2 r :+ p))
-> ((r -> Const (First r) r)
    -> Point 2 r -> Const (First r) (Point 2 r))
-> (r -> Const (First r) r)
-> (Point 2 r :+ p)
-> Const (First r) (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const (First r) r)
-> Point 2 r -> Const (First r) (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord ->
                   BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> Maybe (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall r p.
Ord r =>
BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> Maybe (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
node' BinLeafTree (NodeData p r) (LeafData p r)
l (NodeData p r
dNodeData p r -> (NodeData p r -> NodeData p r) -> NodeData p r
forall a b. a -> (a -> b) -> b
&(Maybe (Point 2 r :+ p) -> Identity (Maybe (Point 2 r :+ p)))
-> NodeData p r -> Identity (NodeData p r)
forall p r. Lens' (NodeData p r) (Maybe (Point 2 r :+ p))
maxVal ((Maybe (Point 2 r :+ p) -> Identity (Maybe (Point 2 r :+ p)))
 -> NodeData p r -> Identity (NodeData p r))
-> (Point 2 r :+ p) -> NodeData p r -> NodeData p r
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Point 2 r :+ p
p) BinLeafTree (NodeData p r) (LeafData p r)
r (NodeData p r
dNodeData p r
-> Getting
     (Maybe (Point 2 r :+ p)) (NodeData p r) (Maybe (Point 2 r :+ p))
-> Maybe (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (Point 2 r :+ p)) (NodeData p r) (Maybe (Point 2 r :+ p))
forall p r. Lens' (NodeData p r) (Maybe (Point 2 r :+ p))
maxVal)
                   -- push the existing point down
               | Bool
otherwise                 ->
                   BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> Maybe (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall r p.
Ord r =>
BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> Maybe (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
node' BinLeafTree (NodeData p r) (LeafData p r)
l NodeData p r
d                             BinLeafTree (NodeData p r) (LeafData p r)
r ((Point 2 r :+ p) -> Maybe (Point 2 r :+ p)
forall a. a -> Maybe a
Just Point 2 r :+ p
p)
  where
    py :: Maybe r
py = r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> r -> Maybe r
forall a b. (a -> b) -> a -> b
$ Point 2 r :+ p
p(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord

    node' :: BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> Maybe (Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
node' BinLeafTree (NodeData p r) (LeafData p r)
l d :: NodeData p r
d@(NodeData r
k Maybe (Point 2 r :+ p)
_) BinLeafTree (NodeData p r) (LeafData p r)
r = \case
      Maybe (Point 2 r :+ p)
Nothing                      -> BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall v a.
BinLeafTree v a -> v -> BinLeafTree v a -> BinLeafTree v a
Node BinLeafTree (NodeData p r) (LeafData p r)
l NodeData p r
d BinLeafTree (NodeData p r) (LeafData p r)
r -- no new insertion necessary anymore
      Just Point 2 r :+ p
q | Point 2 r :+ p
q(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
k -> BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall v a.
BinLeafTree v a -> v -> BinLeafTree v a -> BinLeafTree v a
Node ((Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall r p.
Ord r =>
(Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
insert Point 2 r :+ p
q BinLeafTree (NodeData p r) (LeafData p r)
l) NodeData p r
d BinLeafTree (NodeData p r) (LeafData p r)
r
             | Bool
otherwise           -> BinLeafTree (NodeData p r) (LeafData p r)
-> NodeData p r
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall v a.
BinLeafTree v a -> v -> BinLeafTree v a -> BinLeafTree v a
Node BinLeafTree (NodeData p r) (LeafData p r)
l NodeData p r
d ((Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
forall r p.
Ord r =>
(Point 2 r :+ p)
-> BinLeafTree (NodeData p r) (LeafData p r)
-> BinLeafTree (NodeData p r) (LeafData p r)
insert Point 2 r :+ p
q BinLeafTree (NodeData p r) (LeafData p r)
r)



-- | Given a three sided range \([x_l,x_r],y\) report all points in
-- the range \([x_l,x_r] \times [y,\infty)\). The points are reported
-- in decreasing order of \(y\)-coordinate.
--
-- running time: \(O(\log n + k)\), where \(k\) is the number of reported points.
queryRange   :: Ord r
             => (Range r,r) -> PrioritySearchTree p r -> [Point 2 r :+ p]
queryRange :: (Range r, r) -> PrioritySearchTree p r -> [Point 2 r :+ p]
queryRange (Range r, r)
q = (Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
forall r p.
Ord r =>
(Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
queryRange' (Range r, r)
q (BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p])
-> (PrioritySearchTree p r
    -> BinLeafTree (NodeData p r) (LeafData p r))
-> PrioritySearchTree p r
-> [Point 2 r :+ p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrioritySearchTree p r -> BinLeafTree (NodeData p r) (LeafData p r)
forall p r.
PrioritySearchTree p r -> BinLeafTree (NodeData p r) (LeafData p r)
_unPrioritySearchTree

-- | Implementation fo the query function.
queryRange'           :: Ord r
                      => (Range r,r) -> BinLeafTree (NodeData p r) (LeafData p r)
                      -> [Point 2 r :+ p]
queryRange' :: (Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
queryRange' q :: (Range r, r)
q@(Range r
qr, r
y) = \case
    Leaf (SP r
x [Point 2 r :+ p]
pts) | r
x r -> Range r -> Bool
forall a. Ord a => a -> Range a -> Bool
`inRange` Range r
qr                     ->
                        ((Point 2 r :+ p) -> Bool) -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Point 2 r :+ p
p -> Point 2 r :+ p
p(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
>= r
y) [Point 2 r :+ p]
pts
                    | Bool
otherwise                          -> []
    Node BinLeafTree (NodeData p r) (LeafData p r)
_ (NodeData r
_ Maybe (Point 2 r :+ p)
Nothing)  BinLeafTree (NodeData p r) (LeafData p r)
_                       -> []
      -- nothing stored here, or lower
    Node BinLeafTree (NodeData p r) (LeafData p r)
l (NodeData r
x (Just Point 2 r :+ p
p)) BinLeafTree (NodeData p r) (LeafData p r)
r | Point 2 r :+ p
p(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
>= r
y -> (Point 2 r :+ p) -> [Point 2 r :+ p]
mrep Point 2 r :+ p
p [Point 2 r :+ p] -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. Semigroup a => a -> a -> a
<> [Point 2 r :+ p] -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall extra.
[Point 2 r :+ extra]
-> [Point 2 r :+ extra] -> [Point 2 r :+ extra]
merge (r -> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
goL r
x BinLeafTree (NodeData p r) (LeafData p r)
l) (r -> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
goR r
x BinLeafTree (NodeData p r) (LeafData p r)
r)
                                   | Bool
otherwise           -> []
                                     -- all stuff below here has lower
                                     -- y-coord, so outside the range.
  where
    mrep :: (Point 2 r :+ p) -> [Point 2 r :+ p]
mrep Point 2 r :+ p
p | (Point 2 r :+ p
p(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> Range r -> Bool
forall a. Ord a => a -> Range a -> Bool
`inRange` Range r
qr = [Point 2 r :+ p
p]
           | Bool
otherwise                     = []

    goL :: r -> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
goL r
x BinLeafTree (NodeData p r) (LeafData p r)
t' | Range r
qrRange r
-> Getting (EndPoint r) (Range r) (EndPoint r) -> EndPoint r
forall s a. s -> Getting a s a -> a
^.Getting (EndPoint r) (Range r) (EndPoint r)
forall a. Lens' (Range a) (EndPoint a)
lower EndPoint r -> EndPoint r -> Bool
forall a. Ord a => a -> a -> Bool
<= r -> EndPoint r
forall a. a -> EndPoint a
Closed r
x = (Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
forall r p.
Ord r =>
(Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
queryRange' (Range r, r)
q BinLeafTree (NodeData p r) (LeafData p r)
t'
             | Bool
otherwise             = []

    goR :: r -> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
goR r
x BinLeafTree (NodeData p r) (LeafData p r)
t' | r -> EndPoint r
forall a. a -> EndPoint a
Open r
x EndPoint r -> EndPoint r -> Bool
forall a. Ord a => a -> a -> Bool
< Range r
qrRange r
-> Getting (EndPoint r) (Range r) (EndPoint r) -> EndPoint r
forall s a. s -> Getting a s a -> a
^.Getting (EndPoint r) (Range r) (EndPoint r)
forall a. Lens' (Range a) (EndPoint a)
upper    = (Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
forall r p.
Ord r =>
(Range r, r)
-> BinLeafTree (NodeData p r) (LeafData p r) -> [Point 2 r :+ p]
queryRange' (Range r, r)
q BinLeafTree (NodeData p r) (LeafData p r)
t'
             | Bool
otherwise             = []

    merge :: [Point 2 r :+ extra]
-> [Point 2 r :+ extra] -> [Point 2 r :+ extra]
merge = ((Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering)
-> [Point 2 r :+ extra]
-> [Point 2 r :+ extra]
-> [Point 2 r :+ extra]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeSortedListsBy (((Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering)
 -> [Point 2 r :+ extra]
 -> [Point 2 r :+ extra]
 -> [Point 2 r :+ extra])
-> ((Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering)
-> [Point 2 r :+ extra]
-> [Point 2 r :+ extra]
-> [Point 2 r :+ extra]
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ extra) -> Down r)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (r -> Down r
forall a. a -> Down a
Down (r -> Down r)
-> ((Point 2 r :+ extra) -> r) -> (Point 2 r :+ extra) -> Down r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ extra) -> Getting r (Point 2 r :+ extra) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ extra) -> Const r (Point 2 r :+ extra)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ extra) -> Const r (Point 2 r :+ extra))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ extra) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord))