{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.IntervalMap.Strict
-- Copyright   :  (c) Arbor Networks 2017
-- License     :  BSD-style
-- Maintainer  :  mayhem@arbor.net
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs and functional dependencies)
--
-- Interval maps implemented using the 'FingerTree' type, following
-- section 4.8 of
--
--  * Ralf Hinze and Ross Paterson,
--    \"Finger trees: a simple general-purpose data structure\",
--    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
--    <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
--
-- An amortized running time is given for each operation, with /n/
-- referring to the size of the map.  These bounds hold even
-- in a persistent (shared) setting.
--
-- /Note/: Many of these operations have the same names as similar
-- operations on lists in the "Prelude".  The ambiguity may be resolved
-- using either qualification or the @hiding@ clause.
--
-----------------------------------------------------------------------------

module HaskellWorks.Data.IntervalMap.Strict (
    -- * Intervals
    Interval(..), point,
    -- * Interval maps
    IntervalMap(..), empty, singleton, insert, union,
    -- * Searching
    search, intersections, dominators
    ) where

import Control.Applicative                 ((<$>))
import Control.DeepSeq                     (NFData)
import Data.Foldable                       (Foldable (foldMap))
import Data.Traversable                    (Traversable (traverse))
import GHC.Generics                        (Generic)
import HaskellWorks.Data.FingerTree.Strict (FingerTree, Measured (..), ViewL (..), (<|), (><))

import qualified Data.Semigroup                      as S
import qualified HaskellWorks.Data.FingerTree.Strict as FT

----------------------------------
-- 4.8 Application: interval trees
----------------------------------

-- | A closed interval.  The lower bound should be less than or equal
-- to the higher bound.
data Interval v = Interval { Interval v -> v
low :: !v, Interval v -> v
high :: !v }
  deriving (Interval v -> Interval v -> Bool
(Interval v -> Interval v -> Bool)
-> (Interval v -> Interval v -> Bool) -> Eq (Interval v)
forall v. Eq v => Interval v -> Interval v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interval v -> Interval v -> Bool
$c/= :: forall v. Eq v => Interval v -> Interval v -> Bool
== :: Interval v -> Interval v -> Bool
$c== :: forall v. Eq v => Interval v -> Interval v -> Bool
Eq, Eq (Interval v)
Eq (Interval v)
-> (Interval v -> Interval v -> Ordering)
-> (Interval v -> Interval v -> Bool)
-> (Interval v -> Interval v -> Bool)
-> (Interval v -> Interval v -> Bool)
-> (Interval v -> Interval v -> Bool)
-> (Interval v -> Interval v -> Interval v)
-> (Interval v -> Interval v -> Interval v)
-> Ord (Interval v)
Interval v -> Interval v -> Bool
Interval v -> Interval v -> Ordering
Interval v -> Interval v -> Interval v
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall v. Ord v => Eq (Interval v)
forall v. Ord v => Interval v -> Interval v -> Bool
forall v. Ord v => Interval v -> Interval v -> Ordering
forall v. Ord v => Interval v -> Interval v -> Interval v
min :: Interval v -> Interval v -> Interval v
$cmin :: forall v. Ord v => Interval v -> Interval v -> Interval v
max :: Interval v -> Interval v -> Interval v
$cmax :: forall v. Ord v => Interval v -> Interval v -> Interval v
>= :: Interval v -> Interval v -> Bool
$c>= :: forall v. Ord v => Interval v -> Interval v -> Bool
> :: Interval v -> Interval v -> Bool
$c> :: forall v. Ord v => Interval v -> Interval v -> Bool
<= :: Interval v -> Interval v -> Bool
$c<= :: forall v. Ord v => Interval v -> Interval v -> Bool
< :: Interval v -> Interval v -> Bool
$c< :: forall v. Ord v => Interval v -> Interval v -> Bool
compare :: Interval v -> Interval v -> Ordering
$ccompare :: forall v. Ord v => Interval v -> Interval v -> Ordering
$cp1Ord :: forall v. Ord v => Eq (Interval v)
Ord, Int -> Interval v -> ShowS
[Interval v] -> ShowS
Interval v -> String
(Int -> Interval v -> ShowS)
-> (Interval v -> String)
-> ([Interval v] -> ShowS)
-> Show (Interval v)
forall v. Show v => Int -> Interval v -> ShowS
forall v. Show v => [Interval v] -> ShowS
forall v. Show v => Interval v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Interval v] -> ShowS
$cshowList :: forall v. Show v => [Interval v] -> ShowS
show :: Interval v -> String
$cshow :: forall v. Show v => Interval v -> String
showsPrec :: Int -> Interval v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> Interval v -> ShowS
Show, (forall x. Interval v -> Rep (Interval v) x)
-> (forall x. Rep (Interval v) x -> Interval v)
-> Generic (Interval v)
forall x. Rep (Interval v) x -> Interval v
forall x. Interval v -> Rep (Interval v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v x. Rep (Interval v) x -> Interval v
forall v x. Interval v -> Rep (Interval v) x
$cto :: forall v x. Rep (Interval v) x -> Interval v
$cfrom :: forall v x. Interval v -> Rep (Interval v) x
Generic, Interval v -> ()
(Interval v -> ()) -> NFData (Interval v)
forall v. NFData v => Interval v -> ()
forall a. (a -> ()) -> NFData a
rnf :: Interval v -> ()
$crnf :: forall v. NFData v => Interval v -> ()
NFData)

-- | An interval in which the lower and upper bounds are equal.
point :: v -> Interval v
point :: v -> Interval v
point v
v = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval v
v v
v

data Node v a = Node !(Interval v) !a
  deriving (Node v a -> Node v a -> Bool
(Node v a -> Node v a -> Bool)
-> (Node v a -> Node v a -> Bool) -> Eq (Node v a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v a. (Eq v, Eq a) => Node v a -> Node v a -> Bool
/= :: Node v a -> Node v a -> Bool
$c/= :: forall v a. (Eq v, Eq a) => Node v a -> Node v a -> Bool
== :: Node v a -> Node v a -> Bool
$c== :: forall v a. (Eq v, Eq a) => Node v a -> Node v a -> Bool
Eq, Int -> Node v a -> ShowS
[Node v a] -> ShowS
Node v a -> String
(Int -> Node v a -> ShowS)
-> (Node v a -> String) -> ([Node v a] -> ShowS) -> Show (Node v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v a. (Show v, Show a) => Int -> Node v a -> ShowS
forall v a. (Show v, Show a) => [Node v a] -> ShowS
forall v a. (Show v, Show a) => Node v a -> String
showList :: [Node v a] -> ShowS
$cshowList :: forall v a. (Show v, Show a) => [Node v a] -> ShowS
show :: Node v a -> String
$cshow :: forall v a. (Show v, Show a) => Node v a -> String
showsPrec :: Int -> Node v a -> ShowS
$cshowsPrec :: forall v a. (Show v, Show a) => Int -> Node v a -> ShowS
Show, (forall x. Node v a -> Rep (Node v a) x)
-> (forall x. Rep (Node v a) x -> Node v a) -> Generic (Node v a)
forall x. Rep (Node v a) x -> Node v a
forall x. Node v a -> Rep (Node v a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v a x. Rep (Node v a) x -> Node v a
forall v a x. Node v a -> Rep (Node v a) x
$cto :: forall v a x. Rep (Node v a) x -> Node v a
$cfrom :: forall v a x. Node v a -> Rep (Node v a) x
Generic, Node v a -> ()
(Node v a -> ()) -> NFData (Node v a)
forall a. (a -> ()) -> NFData a
forall v a. (NFData v, NFData a) => Node v a -> ()
rnf :: Node v a -> ()
$crnf :: forall v a. (NFData v, NFData a) => Node v a -> ()
NFData)

instance Functor (Node v) where
    fmap :: (a -> b) -> Node v a -> Node v b
fmap a -> b
f (Node Interval v
i a
x) = Interval v -> b -> Node v b
forall v a. Interval v -> a -> Node v a
Node Interval v
i (a -> b
f a
x)

instance Foldable (Node v) where
    foldMap :: (a -> m) -> Node v a -> m
foldMap a -> m
f (Node Interval v
_ a
x) = a -> m
f a
x

instance Traversable (Node v) where
    traverse :: (a -> f b) -> Node v a -> f (Node v b)
traverse a -> f b
f (Node Interval v
i a
x) = Interval v -> b -> Node v b
forall v a. Interval v -> a -> Node v a
Node Interval v
i (b -> Node v b) -> f b -> f (Node v b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x

-- rightmost interval (including largest lower bound) and largest upper bound.
data IntInterval v = NoInterval | IntInterval !(Interval v) !v
  deriving (IntInterval v -> IntInterval v -> Bool
(IntInterval v -> IntInterval v -> Bool)
-> (IntInterval v -> IntInterval v -> Bool) -> Eq (IntInterval v)
forall v. Eq v => IntInterval v -> IntInterval v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntInterval v -> IntInterval v -> Bool
$c/= :: forall v. Eq v => IntInterval v -> IntInterval v -> Bool
== :: IntInterval v -> IntInterval v -> Bool
$c== :: forall v. Eq v => IntInterval v -> IntInterval v -> Bool
Eq, Int -> IntInterval v -> ShowS
[IntInterval v] -> ShowS
IntInterval v -> String
(Int -> IntInterval v -> ShowS)
-> (IntInterval v -> String)
-> ([IntInterval v] -> ShowS)
-> Show (IntInterval v)
forall v. Show v => Int -> IntInterval v -> ShowS
forall v. Show v => [IntInterval v] -> ShowS
forall v. Show v => IntInterval v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntInterval v] -> ShowS
$cshowList :: forall v. Show v => [IntInterval v] -> ShowS
show :: IntInterval v -> String
$cshow :: forall v. Show v => IntInterval v -> String
showsPrec :: Int -> IntInterval v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> IntInterval v -> ShowS
Show, (forall x. IntInterval v -> Rep (IntInterval v) x)
-> (forall x. Rep (IntInterval v) x -> IntInterval v)
-> Generic (IntInterval v)
forall x. Rep (IntInterval v) x -> IntInterval v
forall x. IntInterval v -> Rep (IntInterval v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v x. Rep (IntInterval v) x -> IntInterval v
forall v x. IntInterval v -> Rep (IntInterval v) x
$cto :: forall v x. Rep (IntInterval v) x -> IntInterval v
$cfrom :: forall v x. IntInterval v -> Rep (IntInterval v) x
Generic, IntInterval v -> ()
(IntInterval v -> ()) -> NFData (IntInterval v)
forall v. NFData v => IntInterval v -> ()
forall a. (a -> ()) -> NFData a
rnf :: IntInterval v -> ()
$crnf :: forall v. NFData v => IntInterval v -> ()
NFData)

appendInterval :: Ord v => IntInterval v -> IntInterval v -> IntInterval v
appendInterval :: IntInterval v -> IntInterval v -> IntInterval v
appendInterval  IntInterval v
NoInterval          IntInterval v
i                     = IntInterval v
i
appendInterval  IntInterval v
i                   IntInterval v
NoInterval            = IntInterval v
i
appendInterval (IntInterval Interval v
_ v
hi1) (IntInterval Interval v
int2 v
hi2) = Interval v -> v -> IntInterval v
forall v. Interval v -> v -> IntInterval v
IntInterval Interval v
int2 (v -> v -> v
forall a. Ord a => a -> a -> a
max v
hi1 v
hi2)
{-# INLINE appendInterval #-}

instance Ord v => S.Semigroup (IntInterval v) where
  <> :: IntInterval v -> IntInterval v -> IntInterval v
(<>) = IntInterval v -> IntInterval v -> IntInterval v
forall v. Ord v => IntInterval v -> IntInterval v -> IntInterval v
appendInterval
  {-# INLINE (<>) #-}

instance Ord v => Monoid (IntInterval v) where
  mempty :: IntInterval v
mempty = IntInterval v
forall v. IntInterval v
NoInterval
  {-# INLINE mempty #-}

instance (Ord v) => Measured (IntInterval v) (Node v a) where
    measure :: Node v a -> IntInterval v
measure (Node Interval v
i a
_) = Interval v -> v -> IntInterval v
forall v. Interval v -> v -> IntInterval v
IntInterval Interval v
i (Interval v -> v
forall v. Interval v -> v
high Interval v
i)

-- | Map of closed intervals, possibly with duplicates.
-- The 'Foldable' and 'Traversable' instances process the intervals in
-- lexicographical order.
newtype IntervalMap v a =
    IntervalMap (FingerTree (IntInterval v) (Node v a))
  deriving (IntervalMap v a -> IntervalMap v a -> Bool
(IntervalMap v a -> IntervalMap v a -> Bool)
-> (IntervalMap v a -> IntervalMap v a -> Bool)
-> Eq (IntervalMap v a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v a.
(Eq v, Eq a) =>
IntervalMap v a -> IntervalMap v a -> Bool
/= :: IntervalMap v a -> IntervalMap v a -> Bool
$c/= :: forall v a.
(Eq v, Eq a) =>
IntervalMap v a -> IntervalMap v a -> Bool
== :: IntervalMap v a -> IntervalMap v a -> Bool
$c== :: forall v a.
(Eq v, Eq a) =>
IntervalMap v a -> IntervalMap v a -> Bool
Eq, Int -> IntervalMap v a -> ShowS
[IntervalMap v a] -> ShowS
IntervalMap v a -> String
(Int -> IntervalMap v a -> ShowS)
-> (IntervalMap v a -> String)
-> ([IntervalMap v a] -> ShowS)
-> Show (IntervalMap v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v a. (Show v, Show a) => Int -> IntervalMap v a -> ShowS
forall v a. (Show v, Show a) => [IntervalMap v a] -> ShowS
forall v a. (Show v, Show a) => IntervalMap v a -> String
showList :: [IntervalMap v a] -> ShowS
$cshowList :: forall v a. (Show v, Show a) => [IntervalMap v a] -> ShowS
show :: IntervalMap v a -> String
$cshow :: forall v a. (Show v, Show a) => IntervalMap v a -> String
showsPrec :: Int -> IntervalMap v a -> ShowS
$cshowsPrec :: forall v a. (Show v, Show a) => Int -> IntervalMap v a -> ShowS
Show, (forall x. IntervalMap v a -> Rep (IntervalMap v a) x)
-> (forall x. Rep (IntervalMap v a) x -> IntervalMap v a)
-> Generic (IntervalMap v a)
forall x. Rep (IntervalMap v a) x -> IntervalMap v a
forall x. IntervalMap v a -> Rep (IntervalMap v a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v a x. Rep (IntervalMap v a) x -> IntervalMap v a
forall v a x. IntervalMap v a -> Rep (IntervalMap v a) x
$cto :: forall v a x. Rep (IntervalMap v a) x -> IntervalMap v a
$cfrom :: forall v a x. IntervalMap v a -> Rep (IntervalMap v a) x
Generic, IntervalMap v a -> ()
(IntervalMap v a -> ()) -> NFData (IntervalMap v a)
forall a. (a -> ()) -> NFData a
forall v a. (NFData v, NFData a) => IntervalMap v a -> ()
rnf :: IntervalMap v a -> ()
$crnf :: forall v a. (NFData v, NFData a) => IntervalMap v a -> ()
NFData)

-- ordered lexicographically by interval

instance Functor (IntervalMap v) where
    fmap :: (a -> b) -> IntervalMap v a -> IntervalMap v b
fmap a -> b
f (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = FingerTree (IntInterval v) (Node v b) -> IntervalMap v b
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap ((Node v a -> Node v b)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v b)
forall a b v. (a -> b) -> FingerTree v a -> FingerTree v b
FT.unsafeFmap ((a -> b) -> Node v a -> Node v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) FingerTree (IntInterval v) (Node v a)
t)

instance Foldable (IntervalMap v) where
    foldMap :: (a -> m) -> IntervalMap v a -> m
foldMap a -> m
f (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = (Node v a -> m) -> FingerTree (IntInterval v) (Node v a) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Node v a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) FingerTree (IntInterval v) (Node v a)
t

instance Traversable (IntervalMap v) where
    traverse :: (a -> f b) -> IntervalMap v a -> f (IntervalMap v b)
traverse a -> f b
f (IntervalMap FingerTree (IntInterval v) (Node v a)
t) =
        FingerTree (IntInterval v) (Node v b) -> IntervalMap v b
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap (FingerTree (IntInterval v) (Node v b) -> IntervalMap v b)
-> f (FingerTree (IntInterval v) (Node v b)) -> f (IntervalMap v b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node v a -> f (Node v b))
-> FingerTree (IntInterval v) (Node v a)
-> f (FingerTree (IntInterval v) (Node v b))
forall (f :: * -> *) a b v.
Applicative f =>
(a -> f b) -> FingerTree v a -> f (FingerTree v b)
FT.unsafeTraverse ((a -> f b) -> Node v a -> f (Node v b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) FingerTree (IntInterval v) (Node v a)
t

instance (Ord v) => S.Semigroup (IntervalMap v a) where
  <> :: IntervalMap v a -> IntervalMap v a -> IntervalMap v a
(<>) = IntervalMap v a -> IntervalMap v a -> IntervalMap v a
forall v a.
Ord v =>
IntervalMap v a -> IntervalMap v a -> IntervalMap v a
union
  {-# INLINE (<>) #-}

-- | 'empty' and 'union'.
instance (Ord v) => Monoid (IntervalMap v a) where
    mempty :: IntervalMap v a
mempty = IntervalMap v a
forall v a. IntervalMap v a
empty
    {-# INLINE mempty #-}
    mappend :: IntervalMap v a -> IntervalMap v a -> IntervalMap v a
mappend = IntervalMap v a -> IntervalMap v a -> IntervalMap v a
forall a. Semigroup a => a -> a -> a
(<>)
    {-# INLINE mappend #-}

-- | /O(1)/.  The empty interval map.
empty :: IntervalMap v a
empty :: IntervalMap v a
empty = FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap FingerTree (IntInterval v) (Node v a)
forall v a. FingerTree v a
FT.empty

-- | /O(1)/.  Interval map with a single entry.
singleton :: Interval v -> a -> IntervalMap v a
singleton :: Interval v -> a -> IntervalMap v a
singleton Interval v
i a
x = FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap (Node v a -> FingerTree (IntInterval v) (Node v a)
forall a v. a -> FingerTree v a
FT.singleton (Interval v -> a -> Node v a
forall v a. Interval v -> a -> Node v a
Node Interval v
i a
x))

-- | /O(log n)/.  Insert an interval into a map.
-- The map may contain duplicate intervals; the new entry will be inserted
-- before any existing entries for the same interval.
insert :: (Ord v) => Interval v -> a -> IntervalMap v a -> IntervalMap v a
insert :: Interval v -> a -> IntervalMap v a -> IntervalMap v a
insert (Interval v
lo v
hi) a
_ IntervalMap v a
m | v
lo v -> v -> Bool
forall a. Ord a => a -> a -> Bool
> v
hi = IntervalMap v a
m
insert Interval v
i a
x (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap (FingerTree (IntInterval v) (Node v a)
l FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a.
Measured v a =>
FingerTree v a -> FingerTree v a -> FingerTree v a
>< Interval v -> a -> Node v a
forall v a. Interval v -> a -> Node v a
Node Interval v
i a
x Node v a
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
<| FingerTree (IntInterval v) (Node v a)
r)
  where
    (FingerTree (IntInterval v) (Node v a)
l, FingerTree (IntInterval v) (Node v a)
r) = (IntInterval v -> Bool)
-> FingerTree (IntInterval v) (Node v a)
-> (FingerTree (IntInterval v) (Node v a),
    FingerTree (IntInterval v) (Node v a))
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
FT.split IntInterval v -> Bool
larger FingerTree (IntInterval v) (Node v a)
t
    larger :: IntInterval v -> Bool
larger (IntInterval Interval v
k v
_) = Interval v
k Interval v -> Interval v -> Bool
forall a. Ord a => a -> a -> Bool
>= Interval v
i
    larger IntInterval v
NoInterval        = String -> Bool
forall a. HasCallStack => String -> a
error String
"larger NoInterval"

-- | /O(m log (n/\//m))/.  Merge two interval maps.
-- The map may contain duplicate intervals; entries with equal intervals
-- are kept in the original order.
union  ::  (Ord v) => IntervalMap v a -> IntervalMap v a -> IntervalMap v a
union :: IntervalMap v a -> IntervalMap v a -> IntervalMap v a
union (IntervalMap FingerTree (IntInterval v) (Node v a)
xs) (IntervalMap FingerTree (IntInterval v) (Node v a)
ys) = FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
forall v a.
FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
IntervalMap (FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a.
Ord v =>
FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
merge1 FingerTree (IntInterval v) (Node v a)
xs FingerTree (IntInterval v) (Node v a)
ys)
  where
    merge1 :: FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
merge1 FingerTree (IntInterval v) (Node v a)
as FingerTree (IntInterval v) (Node v a)
bs = case FingerTree (IntInterval v) (Node v a)
-> ViewL (FingerTree (IntInterval v)) (Node v a)
forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
FT.viewl FingerTree (IntInterval v) (Node v a)
as of
        ViewL (FingerTree (IntInterval v)) (Node v a)
EmptyL                  -> FingerTree (IntInterval v) (Node v a)
bs
        a :: Node v a
a@(Node Interval v
i a
_) :< FingerTree (IntInterval v) (Node v a)
as'     -> FingerTree (IntInterval v) (Node v a)
l FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a.
Measured v a =>
FingerTree v a -> FingerTree v a -> FingerTree v a
>< Node v a
a Node v a
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
<| FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
merge2 FingerTree (IntInterval v) (Node v a)
as' FingerTree (IntInterval v) (Node v a)
r
          where
            (FingerTree (IntInterval v) (Node v a)
l, FingerTree (IntInterval v) (Node v a)
r) = (IntInterval v -> Bool)
-> FingerTree (IntInterval v) (Node v a)
-> (FingerTree (IntInterval v) (Node v a),
    FingerTree (IntInterval v) (Node v a))
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
FT.split IntInterval v -> Bool
larger FingerTree (IntInterval v) (Node v a)
bs
            larger :: IntInterval v -> Bool
larger (IntInterval Interval v
k v
_) = Interval v
k Interval v -> Interval v -> Bool
forall a. Ord a => a -> a -> Bool
>= Interval v
i
            larger IntInterval v
NoInterval        = String -> Bool
forall a. HasCallStack => String -> a
error String
"larger NoInterval"
    merge2 :: FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
merge2 FingerTree (IntInterval v) (Node v a)
as FingerTree (IntInterval v) (Node v a)
bs = case FingerTree (IntInterval v) (Node v a)
-> ViewL (FingerTree (IntInterval v)) (Node v a)
forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
FT.viewl FingerTree (IntInterval v) (Node v a)
bs of
        ViewL (FingerTree (IntInterval v)) (Node v a)
EmptyL                  -> FingerTree (IntInterval v) (Node v a)
as
        b :: Node v a
b@(Node Interval v
i a
_) :< FingerTree (IntInterval v) (Node v a)
bs'     -> FingerTree (IntInterval v) (Node v a)
l FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a.
Measured v a =>
FingerTree v a -> FingerTree v a -> FingerTree v a
>< Node v a
b Node v a
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
<| FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
merge1 FingerTree (IntInterval v) (Node v a)
r FingerTree (IntInterval v) (Node v a)
bs'
          where
            (FingerTree (IntInterval v) (Node v a)
l, FingerTree (IntInterval v) (Node v a)
r) = (IntInterval v -> Bool)
-> FingerTree (IntInterval v) (Node v a)
-> (FingerTree (IntInterval v) (Node v a),
    FingerTree (IntInterval v) (Node v a))
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
FT.split IntInterval v -> Bool
larger FingerTree (IntInterval v) (Node v a)
as
            larger :: IntInterval v -> Bool
larger (IntInterval Interval v
k v
_) = Interval v
k Interval v -> Interval v -> Bool
forall a. Ord a => a -> a -> Bool
> Interval v
i
            larger IntInterval v
NoInterval        = String -> Bool
forall a. HasCallStack => String -> a
error String
"larger NoInterval"

-- | /O(k log (n/\//k))/.  All intervals that intersect with the given
-- interval, in lexicographical order.
intersections :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]
intersections :: Interval v -> IntervalMap v a -> [(Interval v, a)]
intersections Interval v
i = v -> v -> IntervalMap v a -> [(Interval v, a)]
forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
inRange (Interval v -> v
forall v. Interval v -> v
low Interval v
i) (Interval v -> v
forall v. Interval v -> v
high Interval v
i)

-- | /O(k log (n/\//k))/.  All intervals that contain the given interval,
-- in lexicographical order.
dominators :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]
dominators :: Interval v -> IntervalMap v a -> [(Interval v, a)]
dominators Interval v
i = v -> v -> IntervalMap v a -> [(Interval v, a)]
forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
inRange (Interval v -> v
forall v. Interval v -> v
high Interval v
i) (Interval v -> v
forall v. Interval v -> v
low Interval v
i)

-- | /O(k log (n/\//k))/.  All intervals that contain the given point,
-- in lexicographical order.
search :: (Ord v) => v -> IntervalMap v a -> [(Interval v, a)]
search :: v -> IntervalMap v a -> [(Interval v, a)]
search v
p = v -> v -> IntervalMap v a -> [(Interval v, a)]
forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
inRange v
p v
p

-- | /O(k log (n/\//k))/.  All intervals that intersect with the given
-- interval, in lexicographical order.
inRange :: (Ord v) => v -> v -> IntervalMap v a -> [(Interval v, a)]
inRange :: v -> v -> IntervalMap v a -> [(Interval v, a)]
inRange v
lo v
hi (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = FingerTree (IntInterval v) (Node v a) -> [(Interval v, a)]
forall b.
FingerTree (IntInterval v) (Node v b) -> [(Interval v, b)]
matches ((IntInterval v -> Bool)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> FingerTree v a
FT.takeUntil (v -> IntInterval v -> Bool
forall v. Ord v => v -> IntInterval v -> Bool
greater v
hi) FingerTree (IntInterval v) (Node v a)
t)
  where
    matches :: FingerTree (IntInterval v) (Node v b) -> [(Interval v, b)]
matches FingerTree (IntInterval v) (Node v b)
xs  =  case FingerTree (IntInterval v) (Node v b)
-> ViewL (FingerTree (IntInterval v)) (Node v b)
forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
FT.viewl ((IntInterval v -> Bool)
-> FingerTree (IntInterval v) (Node v b)
-> FingerTree (IntInterval v) (Node v b)
forall v a.
Measured v a =>
(v -> Bool) -> FingerTree v a -> FingerTree v a
FT.dropUntil (v -> IntInterval v -> Bool
forall v. Ord v => v -> IntInterval v -> Bool
atleast v
lo) FingerTree (IntInterval v) (Node v b)
xs) of
        ViewL (FingerTree (IntInterval v)) (Node v b)
EmptyL          ->  []
        Node Interval v
i b
x :< FingerTree (IntInterval v) (Node v b)
xs' ->  (Interval v
i, b
x) (Interval v, b) -> [(Interval v, b)] -> [(Interval v, b)]
forall a. a -> [a] -> [a]
: FingerTree (IntInterval v) (Node v b) -> [(Interval v, b)]
matches FingerTree (IntInterval v) (Node v b)
xs'

atleast :: (Ord v) => v -> IntInterval v -> Bool
atleast :: v -> IntInterval v -> Bool
atleast v
k (IntInterval Interval v
_ v
hi) = v
k v -> v -> Bool
forall a. Ord a => a -> a -> Bool
<= v
hi
atleast v
_ IntInterval v
NoInterval         = String -> Bool
forall a. HasCallStack => String -> a
error String
"atleast NoInterval"

greater :: (Ord v) => v -> IntInterval v -> Bool
greater :: v -> IntInterval v -> Bool
greater v
k (IntInterval Interval v
i v
_) = Interval v -> v
forall v. Interval v -> v
low Interval v
i v -> v -> Bool
forall a. Ord a => a -> a -> Bool
> v
k
greater v
_ IntInterval v
NoInterval        = String -> Bool
forall a. HasCallStack => String -> a
error String
"greater NoInterval"

{-
-- Examples

mkMap :: (Ord v) => [(v, v, a)] -> IntervalMap v a
mkMap = foldr ins empty
  where
    ins (lo, hi, n) = insert (Interval lo hi) n

composers :: IntervalMap Int String
composers = mkMap [
    (1685, 1750, "Bach"),
    (1685, 1759, "Handel"),
    (1732, 1809, "Haydn"),
    (1756, 1791, "Mozart"),
    (1770, 1827, "Beethoven"),
    (1782, 1840, "Paganini"),
    (1797, 1828, "Schubert"),
    (1803, 1869, "Berlioz"),
    (1810, 1849, "Chopin"),
    (1833, 1897, "Brahms"),
    (1838, 1875, "Bizet")]

mathematicians :: IntervalMap Int String
mathematicians = mkMap [
    (1642, 1727, "Newton"),
    (1646, 1716, "Leibniz"),
    (1707, 1783, "Euler"),
    (1736, 1813, "Lagrange"),
    (1777, 1855, "Gauss"),
    (1811, 1831, "Galois")]
-}