{-|
Module      : Interval Algebra
Description : Implementation of Allen's interval algebra
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
Stability   : experimental

The @IntervalAlgebra@ module provides data types and related classes for the 
interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434)
and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). 

A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html).

= Design

The module is built around four typeclasses designed to separate concerns of 
constructing, relating, and combining types that contain @'Interval'@s: 

1. @'Intervallic'@ provides an interface to the data structures which contain an
   @'Interval'@.
2. @'IntervalAlgebraic'@ provides an interface to the @'IntervalRelation's@, 
   the workhorse of Allen's temporal logic.
3. @'IntervalCombinable'@ provides an interface to methods of combining two
   @'Interval's@.
4. @'IntervalSizeable'@ provides methods for measuring and modifying the size of
    an interval.

An advantage of nested typeclass design is that developers can define an 
@'Interval'@ of type @a@ with just the amount of structure that they need.

== Total Ordering of @Interval@s 

The modules makes the (opinionated) choice of a total ordering for @'Intervallic'@ 
@'Interval'@s. Namely, the ordering is based on first ordering the 'begin's 
then the 'end's.

= Development

This module is under development and the API may change in the future.
-}

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

-- {-# LANGUAGE MonoLocalBinds #-}
module IntervalAlgebra(

    -- * Classes
      Intervallic(..)
    , IntervalAlgebraic(..)
    , IntervalCombinable(..)
    , IntervalSizeable(..)

    -- * Types
    , Interval
    , parseInterval
    , unsafeInterval
    , IntervalRelation(..)
    , ComparativePredicateOf

    -- * Functions for creating new intervals from existing    
    , expand
    , expandl
    , expandr
    , beginerval
    , enderval
    , extenterval
) where

import Prelude (Eq, Ord, Show, Read, Enum(..), Bounded(..), Ordering (LT)
               , Maybe(..), Either(..), String, Integer, Int, Bool(..), Num
               , Foldable (maximum, minimum, foldMap, foldr)
               , map, otherwise, flip, show, fst, snd, min, max, any, negate, not
               , replicate, id
               , (++), (==), (&&), (<), (>), (<=), ($), (+), (-), (.), (!!))
import Data.Time as DT ( Day, addDays, diffDays, addGregorianYearsClip, calendarYear )
import Data.Semigroup ( Semigroup((<>)) )
import Data.Set(Set, fromList, difference, intersection, union, map, toList)
import Data.Ord( Ord(..), Ordering(..))
import GHC.Base (Applicative(pure))

{- | An @'Interval' a@ is a pair of @a@s \( (x, y) \text{ where } x < y\). The
@'Intervallic'@ class provides a safe @'parseInterval'@ function that returns a 
@'Left'@ error if \(y < x\) and 'unsafeInterval' as constructor for creating an
interval that may not be valid. 
-}
newtype Interval a = Interval (a, a) deriving (Eq)

-- | Safely parse a pair of @a@s to create an @'Interval' a@.
parseInterval :: (Show a, Ord a) => a -> a -> Either String (Interval a)
parseInterval x y
    -- TODO: create more general framework for error handling
    |  y < x    = Left  $ show y ++ "<" ++ show x
    | otherwise = Right $ Interval (x, y)

{- | Create a new @'Interval' a@. This function is __not__ safe as it does 
    not enforce that \(x < y\). Use with caution. It is meant to be helper 
    function in early prototyping of this package. This function may be 
    deprecated in future releases.
-}
unsafeInterval :: a -> a -> Interval a
unsafeInterval x y = Interval (x, y)

intervalBegin :: Interval a -> a
intervalBegin (Interval x) = fst x

intervalEnd :: Interval a -> a
intervalEnd (Interval x) = snd x

{- | 
The @'Intervallic'@ typeclass defines how to get and set the 'Interval' content
of a data structure. It also includes functions for getting the @'begin'@ and 
@'end'@ this data.
-}
class (Ord a, Show a) => Intervallic i a where

    -- | Get the interval from an @i a@
    getInterval :: i a -> Interval a

    -- | Set the interval in an @i a@
    setInterval :: i a -> Interval a -> i a

    -- | Access the ends of an @i a@ .
    begin, end :: i a -> a
    begin = intervalBegin . getInterval
    end   = intervalEnd . getInterval

{- | 

The 'IntervalRelation' type enumerates the thirteen possible ways that two 
@'Interval' a@ objects can relate according to the interval algebra.

=== Meets, Metby

> x `meets` y
> y `metBy` x

@ 
x: |-----|
y:       |-----| 
@

=== Before, After

> x `before` y
> y `after` x

@ 
x: |-----|  
y:          |-----|
@


=== Overlaps, OverlappedBy

> x `overlaps` y
> y `overlappedBy` x

@ 
x: |-----|
y:     |-----|
@

=== Starts, StartedBy

> x `starts` y
> y `startedBy` x

@ 
x: |---| 
y: |-----|
@

=== Finishes, FinishedBy

> x `finishes` y
> y `finishedBy` x

@ 
x:   |---| 
y: |-----|
@

=== During, Contains

> x `during` y
> y `contains` x

@ 
x:   |-| 
y: |-----|
@

=== Equal

> x `equal` y
> y `equal` x

@ 
x: |-----| 
y: |-----|
@

-}
data IntervalRelation a =
      Meets
    | MetBy
    | Before
    | After
    | Overlaps
    | OverlappedBy
    | Starts
    | StartedBy
    | Finishes
    | FinishedBy
    | During
    | Contains
    | Equals
    deriving (Eq, Show, Read)

instance Bounded (IntervalRelation a) where
    minBound = Before
    maxBound = After

instance Enum (IntervalRelation a) where
    fromEnum r = case r of
                    Before       -> 0
                    Meets        -> 1
                    Overlaps     -> 2
                    FinishedBy   -> 3
                    Contains     -> 4
                    Starts       -> 5
                    Equals       -> 6
                    StartedBy    -> 7
                    During       -> 8
                    Finishes     -> 9
                    OverlappedBy -> 10
                    MetBy        -> 11
                    After        -> 12

    toEnum i = case i of
               0  -> Before
               1  -> Meets
               2  -> Overlaps
               3  -> FinishedBy
               4  -> Contains
               5  -> Starts
               6  -> Equals
               7  -> StartedBy
               8  -> During
               9 -> Finishes
               10 -> OverlappedBy
               11 -> MetBy
               12 -> After

instance Ord (IntervalRelation a) where
    compare x y = compare (fromEnum x) (fromEnum y)

-- | The 'Set' of all 'IntervalRelation's.
intervalRelations :: Set (IntervalRelation a)
intervalRelations = fromList (Prelude.map toEnum [0..12] ::[IntervalRelation a])

-- | Find the converse of a single 'IntervalRelation'
converseRelation :: IntervalRelation a -> IntervalRelation a
converseRelation x = toEnum (12 - fromEnum x)

-- | The lookup table for the compositions of interval relations.
composeRelationLookup :: [[[IntervalRelation a]]]
composeRelationLookup =
      [ [p    , p    , p    , p    , p    , p    , p , p    , pmosd, pmosd, pmosd, pmosd, full ]
      , [p    , p    , p    , p    , p    , m    , m , m    , osd  , osd  , osd  , fef  , dsomp]
      , [p    , p    , pmo  , pmo  , pmofd, o    , o , ofd  , osd  , osd  , cncr , dso  , dsomp]
      , [p    , m    , o    , f'   , d'   , o    , f', d'   , osd  , fef  , dso  , dso  , dsomp]
      , [pmofd, ofd  , ofd  , d'   , d'   , ofd  , d', d'   , cncr , dso  , dso  , dso  , dsomp]
      , [p    , p    , pmo  , pmo  , pmofd, s    , s , ses  , d    , d    , dfo  , m'   , p'   ]
      , [p    , m    , o    , f'   , d'   , s    , e , s'   , d    , f    , o'   , m'   , p'   ]
      , [pmofd, ofd  , ofd  , d'   , d'   , ses  , s', s'   , dfo  , o'   , o'   , m'   , p'   ]
      , [p    , p    , pmosd, pmosd, full , d    , d , dfomp, d    , d    , dfomp, p'   , p'   ]
      , [p    , m    , osd  , fef  , dsomp, d    , f , omp  , d    , f    , omp  , p'   , p'   ]
      , [pmofd, ofd  , cncr , dso  , dsomp, dfo  , o', omp  , dfo  , o'   , omp  , p'   , p'   ]
      , [pmofd, ses  , dfo  , m'   , p'   , dfo  , m', p'   , dfo  , m'   , p'   , p'   , p'   ]
      , [full , dfomp, dfomp, p'   , p'   , dfomp, p', p'   , dfomp, p'   , p'   , p'   , p'   ]
      ]
      where p  = [Before]
            m  = [Meets]
            o  = [Overlaps]
            f' = [FinishedBy]
            d' = [Contains]
            s  = [Starts]
            e  = [Equals]
            s' = [StartedBy]
            d  = [During]
            f  = [Finishes]
            o' = [OverlappedBy]
            m' = [MetBy]
            p' = [After]
            ses    = s ++ e ++ s'
            fef    = f' ++ e ++ f
            pmo    = p ++ m ++ o
            pmofd  = pmo ++ f' ++ d'
            osd    = o ++ s ++ d
            ofd    = o ++ f' ++ d'
            omp    = o' ++ m' ++ p'
            dfo    = d ++ f ++ o'
            dfomp  = dfo ++ m' ++ p'
            dso    = d' ++ s' ++ o'
            dsomp  = dso ++ m' ++ p'
            pmosd  = p ++ m ++ osd
            cncr = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o'
            full = p ++ m ++ cncr ++ m' ++ p'
{-
Misc
-}

-- | Defines a predicate of two objects of type @a@.
type ComparativePredicateOf a = (a -> a -> Bool)


{- |
The @'IntervalAlgebraic'@ typeclass specifies the functions and relational 
operators for interval-based temporal logic. The typeclass defines the 
relational operators for types that contain an @'Interval a'@, plus other useful
 utilities such as @'disjoint'@, @'within'@, and @'unionPredicates'@.
-}
class (Eq (i a), Intervallic i a) => IntervalAlgebraic i a where

    -- | Compare two @i a@ to determine their 'IntervalRelation'.
    relate :: i a -> i a -> IntervalRelation (i a)
    relate x y
        | x `before` y       = Before
        | x `after`  y       = After
        | x `meets`  y       = Meets
        | x `metBy`  y       = MetBy
        | x `overlaps` y     = Overlaps
        | x `overlappedBy` y = OverlappedBy
        | x `starts` y       = Starts
        | x `startedBy` y    = StartedBy
        | x `finishes` y     = Finishes
        | x `finishedBy` y   = FinishedBy
        | x `during` y       = During
        | x `contains` y     = Contains
        | otherwise          = Equals

    -- | Maps an 'IntervalRelation' to its corresponding predicate function.
    predicate' :: IntervalRelation (i a) -> ComparativePredicateOf (i a)
    predicate' r =
        case r of
            Before       -> before
            Meets        -> meets
            Overlaps     -> overlaps
            FinishedBy   -> finishedBy
            Contains     -> contains
            Starts       -> starts
            Equals       -> equals
            StartedBy    -> startedBy
            During       -> during
            Finishes     -> finishes
            OverlappedBy -> overlappedBy
            MetBy        -> metBy
            After        -> after

    -- | Given a set of 'IntervalRelation's return a list of 'predicate' functions 
    --   corresponding to each relation.
    predicates :: Set (IntervalRelation (i a)) -> [ComparativePredicateOf (i a)]
    predicates x = Prelude.map predicate' (toList x)

    -- | Forms a predicate function from the union of a set of 'IntervalRelation's.
    predicate :: Set (IntervalRelation (i a)) -> ComparativePredicateOf (i a)
    predicate = unionPredicates.predicates

    -- ** Algebraic operations on IntervalRelations

    -- | Shortcut to creating a 'Set IntervalRelation' from a list.
    toSet :: [IntervalRelation (i a)] -> Set (IntervalRelation (i a))
    toSet = fromList

    -- | Compose two interval relations according to the rules of the algebra.
    --   The rules are enumerated according to <https://thomasalspaugh.org/pub/fnd/allen.html#BasicCompositionsTable this table>.
    compose :: IntervalRelation (i a)
            -> IntervalRelation (i a)
            -> Set (IntervalRelation (i a))
    compose x y = toSet ((composeRelationLookup !! fromEnum x) !! fromEnum y)

    -- | Finds the complement of a 'Set IntervalRelation'.
    complement :: Set (IntervalRelation (i a)) -> Set (IntervalRelation (i a))
    complement = difference intervalRelations

    -- | Find the intersection of two 'Set's of 'IntervalRelation's.
    intersection ::  Set (IntervalRelation (i a))
                  -> Set (IntervalRelation (i a))
                  -> Set (IntervalRelation (i a))
    intersection = Data.Set.intersection

    -- | Find the union of two 'Set's of 'IntervalRelation's.
    union ::  Set (IntervalRelation (i a))
           -> Set (IntervalRelation (i a))
           -> Set (IntervalRelation (i a))
    union = Data.Set.union

    -- | Find the converse of a 'Set IntervalRelation'. 
    converse ::   Set (IntervalRelation (i a))
                  -> Set (IntervalRelation (i a))
    converse = Data.Set.map converseRelation

    -- ** Interval algebra predicates

    -- | Does x equal y?
    equals                 :: ComparativePredicateOf (i a)
    equals   x y  = begin x == begin y && end x == end y

    -- | Does x meet y? Is y metBy x?
    meets, metBy           :: ComparativePredicateOf (i a)
    meets    x y  = end x == begin y
    metBy         = flip meets

    -- | Is x before y? Is x after y?
    before, after          :: ComparativePredicateOf (i a)
    before   x y  = end x < begin y
    after         = flip before

    -- | Does x overlap y? Is x overlapped by y?
    overlaps, overlappedBy :: ComparativePredicateOf (i a)
    overlaps x y  = begin x < begin y && end x < end y && end x > begin y
    overlappedBy  = flip overlaps

    -- | Does x start y? Is x started by y?
    starts, startedBy      :: ComparativePredicateOf (i a)
    starts   x y  = begin x == begin y && (end x < end y)
    startedBy     = flip starts

    -- | Synonyms for 'starts' and 'startedBy'
    precedes, precededBy      :: ComparativePredicateOf (i a)
    precedes      = starts
    precededBy    = startedBy

    -- | Does x finish y? Is x finished by y?
    finishes, finishedBy   :: ComparativePredicateOf (i a)
    finishes x y  = begin x > begin y && end x == end y
    finishedBy    = flip finishes

    -- | Is x during y? Does x contain y?
    during, contains       :: ComparativePredicateOf (i a)
    during   x y  = begin x > begin y && end x < end y
    contains      = flip during

    -- ** Interval Algebra utilities

    -- | Compose a list of interval relations with _or_ to create a new
    -- @'ComparativePredicateOf' i a@. For example, 
    -- @unionPredicates [before, meets]@ creates a predicate function determining
    -- if one interval is either before or meets another interval.
    unionPredicates       :: [ComparativePredicateOf (i a)] ->
                              ComparativePredicateOf (i a)
    unionPredicates fs x y = any (\ f -> f x y) fs

    -- | Operator for composing the union of two predicates
    (<|>) ::  ComparativePredicateOf (i a)
        -> ComparativePredicateOf (i a)
        -> ComparativePredicateOf (i a)
    (<|>) f g = unionPredicates [f, g]

    disjointRelations :: Set (IntervalRelation (i a))
    disjointRelations = toSet [Before, After, Meets, MetBy]

    withinRelations :: Set (IntervalRelation (i a))
    withinRelations = toSet [Starts, During, Finishes, Equals]

    -- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')?
    disjoint               :: ComparativePredicateOf (i a)
    disjoint = predicate disjointRelations

    -- | Are x and y not disjoint; i.e. do they share any support?
    notDisjoint            :: ComparativePredicateOf (i a)
    notDisjoint = predicate (complement disjointRelations)

    -- | A synonym for 'notDisjoint'.
    concur                 :: ComparativePredicateOf (i a)
    concur = notDisjoint

    -- | Is x entirely *within* the endpoints of y? That is, 'during', 
    --   'starts', 'finishes', or 'equals'?
    within                 :: ComparativePredicateOf (i a)
    within = predicate withinRelations

    -- | Does x enclose y? That is, is y 'within' x?
    enclose                :: ComparativePredicateOf (i a)
    enclose = flip enclosedBy

    -- | Synonym for 'within'.
    enclosedBy             :: ComparativePredicateOf (i a)
    enclosedBy = within

{- |
The 'IntervalSizeable' typeclass provides functions to determine the size of an
'Intervallic' type and to resize an 'Interval a'.
-}
class (Show a, Ord a, Num b, Ord b) => IntervalSizeable a b| a -> b where

    -- | The smallest duration for an 'Interval a'.
    moment :: b
    moment = 1

    -- | Gives back a 'moment' based on the input's type.
    moment' :: Intervallic i a => i a -> b
    moment' x = moment @a

    -- | Determine the duration of an @'i a'@.
    duration :: Intervallic i a => i a -> b
    duration x = diff (end x) (begin x)

    -- | Shifts an @a@. Most often, the @b@ will be the same type as @a@. 
    --   But for example, if @a@ is 'Day' then @b@ could be 'Int'.
    add :: b -> a -> a

    -- | Takes the difference between two @a@ to return a @b@.
    diff :: a -> a -> b

-- | Resize an 'i a' to by expanding to "left" by @l@ and to the 
--   "right" by @r@. In the case that @l@ or @r@ are less than a 'moment'
--   the respective endpoints are unchanged. 
expand :: (IntervalSizeable a b, Intervallic i a) => b -> b -> i a -> i a
expand l r p = setInterval p i
  where s = if l < moment' p then 0 else negate l
        e = if r < moment' p then 0 else r
        i = Interval (add s $ begin p, add e $ end p)

-- | Expands an 'i a' to left by i.
expandl :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a
expandl i = expand i 0

-- | Expands an 'i a' to right by i.
expandr :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a
expandr = expand 0

-- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding 
--   @max moment dur@ to @x@ as the 'end'.
beginerval :: (IntervalSizeable a b) => b -> a -> Interval a
beginerval dur x = Interval (x, y)
    where i = Interval (x, x)
          d = max (moment' i) dur
          y = add d x

-- | Safely creates an 'Interval a' using @x@ as the 'end' and adding
--   @negate max moment dur@ to @x@ as the 'begin'.
enderval :: (IntervalSizeable a b) => b -> a -> Interval a
enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x)
    where i = Interval (x, x)

-- | Creates a new @Interval@ spanning the extent x and y.
extenterval :: IntervalAlgebraic i a => i a -> i a -> Interval a
extenterval x y = Interval (s, e)
    where s = min (begin x) (begin y)
          e = max (end x) (end y)

{- |
The @'IntervalCombinable'@ typeclass provides methods for (possibly) combining
two @i a@s to form an @'Interval'@.
-}
class (IntervalAlgebraic i a) => IntervalCombinable i a where

    -- | Maybe form a new @'Interval'@ by the union of two @'Interval'@s that 'meets'.
    (.+.) :: i a -> i a -> Maybe (Interval a)
    (.+.) x y
      | x `meets` y = Just $ Interval (begin x, end y)
      | otherwise   = Nothing

    -- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the 
    --   interval in the "gap" between @x@ and @y@ from the 'end' of @x@ to the
    --   'begin' of @y@. Otherwise, 'Nothing'.
    (><) ::  i a -> i a -> Maybe (Interval a)
    (><) x y
        | x `before` y = Just $ Interval ( end x, begin y )
        | otherwise    = Nothing

    -- | If @x@ is 'before' @y@, return @f x@ appended to @f y@. Otherwise, 
    --   return 'extenterval' of @x@ and @y@ (wrapped in @f@). This is useful for 
    --   (left) folding over an *ordered* container of @Interval@s and combining 
    --   intervals when @x@ is *not* 'before' @y@.
    (<+>):: (Semigroup (f (i a)), Semigroup (f (Interval a)), Applicative f) =>
            i a ->
            i a ->
            f (Interval a)
    (<+>) x y
      | x `before` y = pure (getInterval x) <> pure (getInterval y)
      | otherwise    = pure ( extenterval x y )

    -- | Forms a 'Just' new interval from the intersection of two intervals, 
    --   provided the intervals are not disjoint.
    intersect :: i a -> i a -> Maybe (Interval a)
    intersect x y
       | disjoint x y = Nothing
       | otherwise    = Just $ Interval (b, e)
           where b = max (begin x) (begin y)
                 e = min (end x) (end y)

-- {-
-- Instances
-- -}

-- | Imposes a total ordering on @'Interval' a@ based on first ordering the 
--   'begin's then the 'end's.
instance (Eq (Interval a), Intervallic Interval a) => Ord (Interval a) where
    (<=) x y
      | begin x <  begin y = True
      | begin x == begin y = end x <= end y
      | otherwise = False
    (<)  x y
      | begin x <  begin y = True
      | begin x == begin y = end x < end y
      | otherwise = False

instance (Intervallic Interval a) => Show (Interval a) where
   show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")"

instance (Ord a, Show a) => Intervallic Interval a where
    getInterval = id
    setInterval _ x = x

instance IntervalAlgebraic Interval Int
instance IntervalCombinable Interval Int
instance IntervalSizeable Int Int where
    moment = 1
    add = (+)
    diff = (-)

instance IntervalAlgebraic Interval Integer
instance IntervalCombinable Interval Integer
instance IntervalSizeable Integer Integer where
    moment = 1
    add = (+)
    diff = (-)

instance IntervalAlgebraic Interval DT.Day
instance IntervalCombinable Interval DT.Day
instance IntervalSizeable DT.Day Integer where
    moment = 1
    add = addDays
    diff = diffDays