{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module      : Interval Algebra Utilities
Description : Functions for operating on containers of Intervals.
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
Stability   : experimental
-}

{-# LANGUAGE FlexibleContexts #-}
module IntervalAlgebra.IntervalUtilities (
      combineIntervals
    , gaps
    , durations
    , clip
    , relations
    , gapsWithin
    , emptyIf
    , emptyIfNone
    , emptyIfAny
    , emptyIfAll
) where

import GHC.Base
    ( (++), map, foldr, otherwise, ($), (.), (<*>), seq, not
    , Semigroup((<>)), Functor(fmap), Maybe(..)
    , Int, Bool)
import GHC.Num ()
import Data.Tuple ( uncurry )
import Data.Foldable ( Foldable(null, foldl'), all, any )
import Data.Monoid ( (<>), Monoid(mempty) )
import IntervalAlgebra
    ( Interval, Intervallic(..), IntervalAlgebraic(..)
    , IntervalCombinable(..), IntervalSizeable(..)
    , IntervalFilterable(..)
    , IntervalRelation(..))
import Data.Maybe (mapMaybe)
import Data.List ( (++), head, init, last, tail, zip )
import Witherable ( Filterable )

intInt :: Int -> Int -> Interval Int
intInt :: Int -> Int -> Interval Int
intInt = Int -> Int -> Interval Int
forall a. Intervallic a => a -> a -> Interval a
unsafeInterval

-- | Box to avoid overlapping instances
-- TODO: avoid the head/tail footguns
newtype Box a = Box { Box a -> [a]
unBox :: [a] }
instance (IntervalCombinable a) => Semigroup (Box (Interval a)) where
    Box [Interval a]
x <> :: Box (Interval a) -> Box (Interval a) -> Box (Interval a)
<> Box [Interval a]
y
       | [Interval a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interval a]
x         = [Interval a] -> Box (Interval a)
forall a. [a] -> Box a
Box [Interval a]
y
       | [Interval a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interval a]
y         = [Interval a] -> Box (Interval a)
forall a. [a] -> Box a
Box [Interval a]
x
       | Bool
otherwise      = [Interval a] -> Box (Interval a)
forall a. [a] -> Box a
Box ([Interval a] -> Box (Interval a))
-> [Interval a] -> Box (Interval a)
forall a b. (a -> b) -> a -> b
$ [Interval a] -> [Interval a]
forall a. [a] -> [a]
init [Interval a]
x [Interval a] -> [Interval a] -> [Interval a]
forall a. [a] -> [a] -> [a]
++ (Interval a
lx Interval a -> Interval a -> [Interval a]
forall a (f :: * -> *).
(IntervalCombinable a, Semigroup (f (Interval a)),
 Applicative f) =>
Interval a -> Interval a -> f (Interval a)
<+> Interval a
fy) [Interval a] -> [Interval a] -> [Interval a]
forall a. [a] -> [a] -> [a]
++ [Interval a] -> [Interval a]
forall a. [a] -> [a]
tail [Interval a]
y
       where lx :: Interval a
lx = [Interval a] -> Interval a
forall a. [a] -> a
last [Interval a]
x
             fy :: Interval a
fy = [Interval a] -> Interval a
forall a. [a] -> a
head [Interval a]
y

-- | Returns a list of intervals where any intervals that meet or share support
--   are combined into one interval. *To work properly, the input list should 
--   be sorted*. 
--
-- >>> combineIntervals [intInt 0 10, intInt 2 7, intInt 10 12, intInt 13 15]
-- [(0, 12),(13, 15)]
combineIntervals :: (IntervalCombinable a) => [Interval a] -> [Interval a]
combineIntervals :: [Interval a] -> [Interval a]
combineIntervals [Interval a]
l = Box (Interval a) -> [Interval a]
forall a. Box a -> [a]
unBox (Box (Interval a) -> [Interval a])
-> Box (Interval a) -> [Interval a]
forall a b. (a -> b) -> a -> b
$ (Box (Interval a) -> Box (Interval a) -> Box (Interval a))
-> Box (Interval a) -> [Box (Interval a)] -> Box (Interval a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Box (Interval a) -> Box (Interval a) -> Box (Interval a)
forall a. Semigroup a => a -> a -> a
(<>) ([Interval a] -> Box (Interval a)
forall a. [a] -> Box a
Box []) ((Interval a -> Box (Interval a))
-> [Interval a] -> [Box (Interval a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Interval a
z -> [Interval a] -> Box (Interval a)
forall a. [a] -> Box a
Box [Interval a
z]) [Interval a]
l)

-- | Returns a (possibly empty) list of intervals consisting of the gaps between
--   intervals in the input list. *To work properly, the input list should be sorted*.
gaps :: (IntervalCombinable a) => [Interval a] -> [Interval a]
gaps :: [Interval a] -> [Interval a]
gaps [Interval a]
l = ((Interval a, Interval a) -> Maybe (Interval a))
-> [(Interval a, Interval a)] -> [Interval a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Interval a -> Interval a -> Maybe (Interval a))
-> (Interval a, Interval a) -> Maybe (Interval a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Interval a -> Interval a -> Maybe (Interval a)
forall a.
IntervalCombinable a =>
Interval a -> Interval a -> Maybe (Interval a)
(><)) (([Interval a] -> [Interval a] -> [(Interval a, Interval a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Interval a] -> [Interval a] -> [(Interval a, Interval a)])
-> ([Interval a] -> [Interval a])
-> [Interval a]
-> [(Interval a, Interval a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Interval a] -> [Interval a]
forall a. [a] -> [a]
tail) [Interval a]
l)

-- | Returns the 'duration' of each 'Interval' in the 'Functor' @f@.
--
-- >>> durations [intInt 1 10, intInt 2 12, intInt 5 6]
-- [9,10,1]
durations :: (Functor f, IntervalSizeable a b) => f (Interval a) -> f b
durations :: f (Interval a) -> f b
durations = (Interval a -> b) -> f (Interval a) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Interval a -> b
forall a b. IntervalSizeable a b => Interval a -> b
duration


-- | In the case that x y are not disjoint, clips y to the extent of x.
-- 
-- >>> clip (intInt 0 5) (intInt 3 6)
-- Just (3, 5)
--
-- >>> clip (intInt 0 3) (intInt 4 6)
-- Nothing
clip :: (IntervalAlgebraic a, IntervalSizeable a b)=>
       Interval a
    -> Interval a
    -> Maybe (Interval a)
clip :: Interval a -> Interval a -> Maybe (Interval a)
clip Interval a
x Interval a
y
   | ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
overlaps Interval a
x Interval a
y     = Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just (Interval a -> Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall a b. (a -> b) -> a -> b
$ b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
enderval   (a -> a -> b
forall a b. IntervalSizeable a b => a -> a -> b
diff (Interval a -> a
forall a. Intervallic a => Interval a -> a
end Interval a
x) (Interval a -> a
forall a. Intervallic a => Interval a -> a
begin Interval a
y)) (Interval a -> a
forall a. Intervallic a => Interval a -> a
end Interval a
x)
   | ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
overlappedBy Interval a
x Interval a
y = Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just (Interval a -> Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall a b. (a -> b) -> a -> b
$ b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval (a -> a -> b
forall a b. IntervalSizeable a b => a -> a -> b
diff (Interval a -> a
forall a. Intervallic a => Interval a -> a
end Interval a
y) (Interval a -> a
forall a. Intervallic a => Interval a -> a
begin Interval a
x)) (Interval a -> a
forall a. Intervallic a => Interval a -> a
begin Interval a
x)
   | ComparativePredicateOf (Interval a)
jx Interval a
x Interval a
y           = Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just Interval a
x
   | ComparativePredicateOf (Interval a)
jy Interval a
x Interval a
y           = Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just Interval a
y
   | ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
disjoint Interval a
x Interval a
y     = Maybe (Interval a)
forall a. Maybe a
Nothing
   where jy :: ComparativePredicateOf (Interval a)
jy = ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
equals ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
<|> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
startedBy ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
<|> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
contains ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
<|> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
finishedBy
         jx :: ComparativePredicateOf (Interval a)
jx = ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
starts ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
<|> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
during ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
-> ComparativePredicateOf (Interval a)
<|> ComparativePredicateOf (Interval a)
forall a.
IntervalAlgebraic a =>
ComparativePredicateOf (Interval a)
finishes

-- | Finds the 'IntervalRelation' between each consecutive pair of intervals.
-- 
-- >>> relations [intInt 0 1, intInt 1 2] 
-- [Meets]
relations :: (IntervalAlgebraic a)=> [Interval a] -> [IntervalRelation a]
-- TODO: generalize to collections besides list
relations :: [Interval a] -> [IntervalRelation a]
relations [Interval a]
x = ((Interval a, Interval a) -> IntervalRelation a)
-> [(Interval a, Interval a)] -> [IntervalRelation a]
forall a b. (a -> b) -> [a] -> [b]
map ((Interval a -> Interval a -> IntervalRelation a)
-> (Interval a, Interval a) -> IntervalRelation a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Interval a -> Interval a -> IntervalRelation a
forall a.
IntervalAlgebraic a =>
Interval a -> Interval a -> IntervalRelation a
relate) (([Interval a] -> [Interval a] -> [(Interval a, Interval a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Interval a] -> [Interval a] -> [(Interval a, Interval a)])
-> ([Interval a] -> [Interval a])
-> [Interval a]
-> [(Interval a, Interval a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Interval a] -> [Interval a]
forall a. [a] -> [a]
tail) [Interval a]
x)

-- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are *not* disjoint
-- from @i@. Intervals that 'overlaps' or are 'overlappedBy' @i@ are 'clip'ped to @i@.
--
-- >>> gapsWithin (intInt 1 10) [intInt 0 5, intInt 7 9, intInt 12 15]
-- [(5, 7),(9, 10)]
gapsWithin :: (IntervalSizeable a b, IntervalCombinable a, IntervalFilterable [] a)=>
      Interval a  -- ^ i
  -> [Interval a] -- ^ x
  -> [Interval a]
-- TODO: generalize to collections besides list
gapsWithin :: Interval a -> [Interval a] -> [Interval a]
gapsWithin Interval a
i [Interval a]
x = [Interval a] -> [Interval a]
forall a. IntervalCombinable a => [Interval a] -> [Interval a]
gaps ([Interval a] -> [Interval a]) -> [Interval a] -> [Interval a]
forall a b. (a -> b) -> a -> b
$ b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
enderval b
0 (Interval a -> a
forall a. Intervallic a => Interval a -> a
begin Interval a
i) Interval a -> [Interval a] -> [Interval a]
forall a. a -> [a] -> [a]
:
                        (Interval a -> Maybe (Interval a)) -> [Interval a] -> [Interval a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Interval a -> Interval a -> Maybe (Interval a)
forall a b.
(IntervalAlgebraic a, IntervalSizeable a b) =>
Interval a -> Interval a -> Maybe (Interval a)
clip Interval a
i) (Interval a -> [Interval a] -> [Interval a]
forall (f :: * -> *) a.
IntervalFilterable f a =>
Interval a -> f (Interval a) -> f (Interval a)
filterNotDisjoint Interval a
i [Interval a]
x) [Interval a] -> [Interval a] -> [Interval a]
forall a. [a] -> [a] -> [a]
++
                        [b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval b
0 (Interval a -> a
forall a. Intervallic a => Interval a -> a
end Interval a
i)]

-- | Given a predicate combinator, a predicate, and list of intervals, returns 
--   the input unchanged if the predicate combinator is 'True'. Otherwise, returns
--   an empty list. See 'emptyIfAny' and 'emptyIfNone' for examples.
emptyIf :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=>
     ((Interval a -> Bool) -> f (Interval a) -> Bool) -- ^ e.g. 'any' or 'all'
  -> (Interval a -> Bool) -- ^ predicate to apply to each element of input list
  -> f (Interval a)
  -> f (Interval a)
emptyIf :: ((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIf (Interval a -> Bool) -> f (Interval a) -> Bool
g Interval a -> Bool
f f (Interval a)
x = if (Interval a -> Bool) -> f (Interval a) -> Bool
g Interval a -> Bool
f f (Interval a)
x then f (Interval a)
forall a. Monoid a => a
mempty else f (Interval a)
x

-- | Returns the empty monoid structure if *none* of the element of input satisfy
--   the predicate condition.
-- 
-- For example, the following returns the empty list because none of the intervals
-- in the input list 'starts' (3, 5).
--
-- >>> emptyIfNone (starts (intInt 3 5)) [intInt 3 4, intInt 5 6]
-- []
--
-- In the following, (3, 5) 'starts' (3, 6), so the input is returned.
--
-- >>> emptyIfNone (starts (intInt 3 5)) [intInt 3 6, intInt 5 6]
-- [(3, 6),(5, 6)]
emptyIfNone :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=>
    (Interval a -> Bool) -- ^ predicate to apply to each element of input list
  -> f (Interval a)
  -> f (Interval a)
emptyIfNone :: (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIfNone = ((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
forall (f :: * -> *) a.
(Monoid (f (Interval a)), Foldable f, IntervalFilterable f a) =>
((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIf (\Interval a -> Bool
f f (Interval a)
x -> (Bool -> Bool
not(Bool -> Bool)
-> (f (Interval a) -> Bool) -> f (Interval a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Interval a -> Bool) -> f (Interval a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Interval a -> Bool
f) f (Interval a)
x)

-- | Returns the empty monoid structure if *any* of the element of input satisfy
--   the predicate condition
emptyIfAny :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=>
    (Interval a -> Bool) -- ^ predicate to apply to each element of input list
  -> f (Interval a)
  -> f (Interval a)
emptyIfAny :: (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIfAny = ((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
forall (f :: * -> *) a.
(Monoid (f (Interval a)), Foldable f, IntervalFilterable f a) =>
((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIf (Interval a -> Bool) -> f (Interval a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any

-- | Returns the empty monoid structure if *all* of the element of input satisfy
--   the predicate condition
emptyIfAll :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=>
    (Interval a -> Bool) -- ^ predicate to apply to each element of input list
  -> f (Interval a)
  -> f (Interval a)
emptyIfAll :: (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIfAll = ((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
forall (f :: * -> *) a.
(Monoid (f (Interval a)), Foldable f, IntervalFilterable f a) =>
((Interval a -> Bool) -> f (Interval a) -> Bool)
-> (Interval a -> Bool) -> f (Interval a) -> f (Interval a)
emptyIf (Interval a -> Bool) -> f (Interval a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all