{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}

#ifndef MIN_VERSION_lens
#define MIN_VERSION_lens(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Trifecta.Util.IntervalMap
-- Copyright   :  (c) Edward Kmett 2011-2019
--                (c) Ross Paterson 2008
-- License     :  BSD-style
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs, type families, 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://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
--
-- An amortized running time is given for each operation, with /n/
-- referring to the size of the priority queue.  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.
--
-- Unlike "Data.IntervalMap.FingerTree", this version sorts things so
-- that the largest interval from a given point comes first. This way
-- if you have nested intervals, you get the outermost interval before
-- the contained intervals.
-----------------------------------------------------------------------------
module Text.Trifecta.Util.IntervalMap
  (
  -- * Intervals
    Interval(..)
  -- * Interval maps
  , IntervalMap(..), singleton, insert
  -- * Searching
  , search, intersections, dominators
  -- * Prepending an offset onto every interval in the map
  , offset
  -- * The result monoid
  , IntInterval(..)
  , fromList
  ) where

import qualified Data.Foldable.WithIndex as WithIndex
import Control.Lens as Lens hiding ((:<), (<|), (|>))
import           Data.FingerTree
    (FingerTree, Measured (..), ViewL (..), (<|), (><))
import qualified Data.FingerTree        as FT
import qualified Data.Functor.WithIndex as WithIndex
#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup
#endif
import           Data.Semigroup.Reducer
import           Data.Semigroup.Union
import qualified Data.Traversable.WithIndex as WithIndex

----------------------------------
-- 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 { forall v. Interval v -> v
low :: v, forall v. Interval v -> v
high :: v }
  deriving 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
$cshowsPrec :: forall v. Show v => Int -> Interval v -> ShowS
showsPrec :: Int -> Interval v -> ShowS
$cshow :: forall v. Show v => Interval v -> String
show :: Interval v -> String
$cshowList :: forall v. Show v => [Interval v] -> ShowS
showList :: [Interval v] -> ShowS
Show

instance Ord v => Semigroup (Interval v) where
  Interval v
a v
b <> :: Interval v -> Interval v -> Interval v
<> Interval v
c v
d = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval (v -> v -> v
forall a. Ord a => a -> a -> a
min v
a v
c) (v -> v -> v
forall a. Ord a => a -> a -> a
max v
b v
d)

-- assumes the monoid and ordering are compatible.
instance (Ord v, Monoid v) => Reducer v (Interval v) where
  unit :: v -> Interval v
unit v
v = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval v
v v
v
  cons :: v -> Interval v -> Interval v
cons v
v (Interval v
a v
b) = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval (v
v v -> v -> v
forall a. Monoid a => a -> a -> a
`mappend` v
a) (v
v v -> v -> v
forall a. Monoid a => a -> a -> a
`mappend` v
b)
  snoc :: Interval v -> v -> Interval v
snoc (Interval v
a v
b) v
v = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval (v
a v -> v -> v
forall a. Monoid a => a -> a -> a
`mappend` v
v) (v
b v -> v -> v
forall a. Monoid a => a -> a -> a
`mappend` v
v)

instance Eq v => Eq (Interval v) where
  Interval v
a v
b == :: Interval v -> Interval v -> Bool
== Interval v
c v
d = v
a v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
c Bool -> Bool -> Bool
&& v
d v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
b

instance Ord v => Ord (Interval v) where
  compare :: Interval v -> Interval v -> Ordering
compare (Interval v
a v
b) (Interval v
c v
d) = case v -> v -> Ordering
forall a. Ord a => a -> a -> Ordering
compare v
a v
c of
    Ordering
LT -> Ordering
LT
    Ordering
EQ -> v -> v -> Ordering
forall a. Ord a => a -> a -> Ordering
compare v
d v
b -- reversed to put larger intervals first
    Ordering
GT -> Ordering
GT

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

instance Foldable Interval where
  foldMap :: forall m a. Monoid m => (a -> m) -> Interval a -> m
foldMap a -> m
f (Interval a
a a
b) = a -> m
f a
a m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
b

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

data Node v a = Node (Interval v) a

instance Functor (Node v) where
  fmap :: forall a b. (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 WithIndex.FunctorWithIndex (Interval v) (Node v) where
  imap :: forall a b. (Interval v -> a -> b) -> Node v a -> Node v b
imap Interval v -> 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 (Interval v -> a -> b
f Interval v
i a
x)

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

instance WithIndex.FoldableWithIndex (Interval v) (Node v) where
  ifoldMap :: forall m a. Monoid m => (Interval v -> a -> m) -> Node v a -> m
ifoldMap Interval v -> a -> m
f (Node Interval v
k a
v) = Interval v -> a -> m
f Interval v
k a
v

instance Traversable (Node v) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(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

instance WithIndex.TraversableWithIndex (Interval v) (Node v) where
  itraverse :: forall (f :: * -> *) a b.
Applicative f =>
(Interval v -> a -> f b) -> Node v a -> f (Node v b)
itraverse Interval v -> 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
<$> Interval v -> a -> f b
f Interval v
i a
x

#if !MIN_VERSION_lens(5,0,0)
instance Lens.FunctorWithIndex     (Interval v) (Node v) where imap      = WithIndex.imap
instance Lens.FoldableWithIndex    (Interval v) (Node v) where ifoldMap  = WithIndex.ifoldMap
instance Lens.TraversableWithIndex (Interval v) (Node v) where itraverse = WithIndex.itraverse
#endif

-- rightmost interval (including largest lower bound) and largest upper bound.
data IntInterval v = NoInterval | IntInterval (Interval v) v

instance Ord v => Monoid (IntInterval v) where
  mempty :: IntInterval v
mempty = IntInterval v
forall v. IntInterval v
NoInterval
  mappend :: IntInterval v -> IntInterval v -> IntInterval v
mappend = IntInterval v -> IntInterval v -> IntInterval v
forall a. Semigroup a => a -> a -> a
(<>)

instance Ord v => Semigroup (IntInterval v) where
  IntInterval v
NoInterval <> :: IntInterval v -> IntInterval v -> IntInterval v
<> IntInterval v
i  = IntInterval v
i
  IntInterval v
i <> IntInterval v
NoInterval  = IntInterval v
i
  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)

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 { forall v a.
IntervalMap v a -> FingerTree (IntInterval v) (Node v a)
runIntervalMap :: FingerTree (IntInterval v) (Node v a) }
-- ordered lexicographically by interval

instance Functor (IntervalMap v) where
  fmap :: forall a b. (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 a b. (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 FunctorWithIndex (Interval v) (IntervalMap v) where
  imap :: forall a b.
(Interval v -> a -> b) -> IntervalMap v a -> IntervalMap v b
imap Interval v -> 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 ((Interval v -> a -> b) -> Node v a -> Node v b
forall a b. (Interval v -> a -> b) -> Node v a -> Node v b
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap Interval v -> a -> b
f) FingerTree (IntInterval v) (Node v a)
t)

instance Foldable (IntervalMap v) where
  foldMap :: forall m a. Monoid m => (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 m a.
Monoid m =>
(a -> m) -> FingerTree (IntInterval v) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Node v a -> m
forall m a. Monoid m => (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 FoldableWithIndex (Interval v) (IntervalMap v) where
  ifoldMap :: forall m a.
Monoid m =>
(Interval v -> a -> m) -> IntervalMap v a -> m
ifoldMap Interval v -> a -> m
f (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = (Node v a -> m) -> FingerTree (IntInterval v) (Node v a) -> m
forall m a.
Monoid m =>
(a -> m) -> FingerTree (IntInterval v) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Interval v -> a -> m) -> Node v a -> m
forall m a. Monoid m => (Interval v -> a -> m) -> Node v a -> m
forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap Interval v -> a -> m
f) FingerTree (IntInterval v) (Node v a)
t

instance Traversable (IntervalMap v) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Node v a -> f (Node v b)
traverse a -> f b
f) FingerTree (IntInterval v) (Node v a)
t

instance TraversableWithIndex (Interval v) (IntervalMap v) where
  itraverse :: forall (f :: * -> *) a b.
Applicative f =>
(Interval v -> a -> f b) -> IntervalMap v a -> f (IntervalMap v b)
itraverse Interval v -> 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 ((Interval v -> a -> f b) -> Node v a -> f (Node v b)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(Interval v -> a -> f b) -> Node v a -> f (Node v b)
itraverse Interval v -> a -> f b
f) FingerTree (IntInterval v) (Node v a)
t

instance Ord v => Measured (IntInterval v) (IntervalMap v a) where
  measure :: IntervalMap v a -> IntInterval v
measure (IntervalMap FingerTree (IntInterval v) (Node v a)
m) = FingerTree (IntInterval v) (Node v a) -> IntInterval v
forall v a. Measured v a => a -> v
measure FingerTree (IntInterval v) (Node v a)
m

largerError :: a
largerError :: forall a. a
largerError = String -> a
forall a. HasCallStack => String -> a
error String
"Text.Trifecta.IntervalMap.larger: the impossible happened"

-- | /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.
instance Ord v => HasUnion (IntervalMap v a) where
  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
_ = Bool
forall a. a
largerError
    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
_ = Bool
forall a. a
largerError

instance Ord v => HasUnion0 (IntervalMap v a) where
  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. Measured v a => FingerTree v a
FT.empty

instance Ord v => Monoid (IntervalMap v a) where
  mempty :: IntervalMap v a
mempty = IntervalMap v a
forall f. HasUnion0 f => f
empty
  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
(<>)

instance Ord v => Semigroup (IntervalMap v a) where
  <> :: IntervalMap v a -> IntervalMap v a -> IntervalMap v a
(<>) = IntervalMap v a -> IntervalMap v a -> IntervalMap v a
forall f. HasUnion f => f -> f -> f
union

-- | /O(n)/. Add a delta to each interval in the map
offset :: (Ord v, Monoid v) => v -> IntervalMap v a -> IntervalMap v a
offset :: forall v a.
(Ord v, Monoid v) =>
v -> IntervalMap v a -> IntervalMap v a
offset v
v (IntervalMap FingerTree (IntInterval v) (Node v a)
m) = 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) -> IntervalMap v a)
-> FingerTree (IntInterval v) (Node v a) -> IntervalMap v a
forall a b. (a -> b) -> a -> b
$ (Node v a -> Node v a)
-> FingerTree (IntInterval v) (Node v a)
-> FingerTree (IntInterval v) (Node v a)
forall v1 a1 v2 a2.
(Measured v1 a1, Measured v2 a2) =>
(a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
FT.fmap' (\(Node (Interval v
lo v
hi) a
a) -> Interval v -> a -> Node v a
forall v a. Interval v -> a -> Node v a
Node (v -> v -> Interval v
forall v. v -> v -> Interval v
Interval (v -> v -> v
forall a. Monoid a => a -> a -> a
mappend v
v v
lo) (v -> v -> v
forall a. Monoid a => a -> a -> a
mappend v
v v
hi)) a
a) FingerTree (IntInterval v) (Node v a)
m

-- | /O(1)/.  Interval map with a single entry.
singleton :: Ord v => Interval v -> a -> IntervalMap v a
singleton :: forall v a. Ord v => 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 v a. Measured v a => 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 => v -> v -> a -> IntervalMap v a -> IntervalMap v a
insert :: forall v a.
Ord v =>
v -> v -> a -> IntervalMap v a -> IntervalMap v a
insert 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 v
lo v
hi 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
  i :: Interval v
i = v -> v -> Interval v
forall v. v -> v -> Interval v
Interval v
lo v
hi
  (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
_ = Bool
forall a. a
largerError

-- | /O(k log (n/\//k))/.  All intervals that contain the given interval,
-- in lexicographical order.
dominators :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
dominators :: forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
dominators v
i v
j = v -> v -> IntervalMap v a -> [(Interval v, a)]
forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
intersections v
j 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 :: forall v a. Ord v => 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)]
intersections v
p v
p

-- | /O(k log (n/\//k))/.  All intervals that intersect with the given
-- interval, in lexicographical order.
intersections :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
intersections :: forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
intersections v
lo v
hi (IntervalMap FingerTree (IntInterval v) (Node v a)
t) = FingerTree (IntInterval v) (Node v a) -> [(Interval v, a)]
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 a) -> [(Interval v, a)]
matches FingerTree (IntInterval v) (Node v a)
xs  =  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 ((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.dropUntil (v -> IntInterval v -> Bool
forall v. Ord v => v -> IntInterval v -> Bool
atleast v
lo) FingerTree (IntInterval v) (Node v a)
xs) of
    ViewL (FingerTree (IntInterval v)) (Node v a)
EmptyL -> []
    Node Interval v
i a
x :< FingerTree (IntInterval v) (Node v a)
xs'  ->  (Interval v
i, a
x) (Interval v, a) -> [(Interval v, a)] -> [(Interval v, a)]
forall a. a -> [a] -> [a]
: FingerTree (IntInterval v) (Node v a) -> [(Interval v, a)]
matches FingerTree (IntInterval v) (Node v a)
xs'

atleast :: Ord v => v -> IntInterval v -> Bool
atleast :: forall v. Ord v => 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
_ = Bool
False

greater :: Ord v => v -> IntInterval v -> Bool
greater :: forall v. Ord v => 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
_ = Bool
False

fromList :: Ord v => [(v, v, a)] -> IntervalMap v a
fromList :: forall v a. Ord v => [(v, v, a)] -> IntervalMap v a
fromList = ((v, v, a) -> IntervalMap v a -> IntervalMap v a)
-> IntervalMap v a -> [(v, v, a)] -> IntervalMap v a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (v, v, a) -> IntervalMap v a -> IntervalMap v a
forall {v} {a}.
Ord v =>
(v, v, a) -> IntervalMap v a -> IntervalMap v a
ins IntervalMap v a
forall f. HasUnion0 f => f
empty where
  ins :: (v, v, a) -> IntervalMap v a -> IntervalMap v a
ins (v
lo, v
hi, a
n) = v -> v -> a -> IntervalMap v a -> IntervalMap v a
forall v a.
Ord v =>
v -> v -> a -> IntervalMap v a -> IntervalMap v a
insert v
lo v
hi a
n