-- |
-- Module      : Data.Allen.Interval
-- Description : Functions for working with intervals.
-- Maintainer  : Archaversine 
--
-- This module provides functions for working with intervals. Note that almost 
-- all exposed functions only work with interval IDs. This is because the 
-- internal representation of intervals is subject to change, but the IDs will 
-- remain the same no matter what.
-- 
-- = Creating intervals
-- Intervals are created with the 'interval' function, which creates an interval 
-- adds it to the internal network representation, then returns its corresponding 
-- ID. Note that upon creating a new interval, it will have all relations to all 
-- other intervals. This is because the creation of an interval does not provide 
-- any meaningful information about its relations to other intervals.
--
-- Creating two intervals sleeps and snores:
--
-- @ 
-- sleeps <- 'interval' 
-- snores <- 'interval'
-- @
--
-- = Defining Relations Between Intervals
-- There are three main ways to define relations betweek intervals:
--
-- (1) Define a single relation using the 'Relation' type.
-- (2) Define a set of relations using a list of 'Relation' types.
-- (3) Define a set of relations using a 'RelationBits' type.
--
-- == Defining a single relation
-- This is the easiest to do, and is done with the 'assume' function. This 
-- function takes three arguments: the ID of the first interval, the relation 
-- between the two intervals, and the ID of the second interval. 
--
-- Example:
--
-- @ 
-- sleeps <- 'interval' 
-- snores <- 'interval' 
--
-- 'assume' snores 'During' sleeps
-- @
--
-- == Defining a Set of Relations 
-- This is done with the 'assumeSet' function. This function takes three 
-- arguments: the ID of the first interval, a list of relations between the 
-- two intervals, and the ID of the second interval. 
--
-- Example: 
--
-- @ 
-- sleeps <- 'interval' 
-- snores <- 'interval' 
--
-- 'assumeSet' snores ['StartedBy', 'During', 'FinishedBy'] sleeps
-- @
--
-- == Defining a Set of Relations Using Bit Representation
-- This is done with the 'assumeBits' function. This function takes three 
-- arguments: the ID of the first interval, a 'RelationBits' type representing 
-- the relations between the two intervals, and the ID of the second interval. 
-- Generally, this function should not be used directly, but it can be used 
-- to speed up calculations if you already know the bit representation.
--
-- Example: 
--
-- @ 
-- sleeps <- 'interval' 
-- snores <- 'interval' 
--
-- let relations = 'relationUnion' $ map 'toBits' ['StartedBy', 'During', 'FinishedBy']
--
-- 'assumeBits' snores relations sleeps
-- @
--
-- = Getting Constraints
-- The 'getConstraints' function returns a 'RelationBits' type representing the 
-- set of all possible relations between two intervals. This is useful for 
-- determining specific information between two intervals.
--
-- Example: 
--
-- @
-- sleeps <- 'interval' 
-- snores <- 'interval' 
--
-- 'assume' snores 'During' sleeps
--
-- 'fromBits' \<$\> 'getConstraints' snores sleeps
-- @

module Data.Allen.Interval ( interval
                           , intervalCount
                           , fromID
                           , assume
                           , assumeSet
                           , assumeBits
                           , setRelation
                           , getConstraints
                           ) where

import Control.Monad
import Control.Monad.State

import Data.Allen.Types
import Data.Allen.Relation

import Data.Bits

import qualified Data.Map.Strict as Map

-- | Create a new interval. 
-- Returns the interval ID.
interval :: Allen IntervalID 
interval :: Allen IntervalID
interval = do
    IntervalGraph
intervals <- forall s (m :: * -> *). MonadState s m => m s
get

    let iD :: IntervalID
iD         = forall k a. Map k a -> IntervalID
Map.size IntervalGraph
intervals
        iRelations :: Map IntervalID RelationBits
iRelations = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(IntervalID
x, RelationBits
allRelationBits) | IntervalID
x <- [IntervalID
0 .. IntervalID
iD forall a. Num a => a -> a -> a
- IntervalID
1]]
        intervals' :: IntervalGraph
intervals' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Interval
x -> Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
x RelationBits
allRelationBits IntervalID
iD) IntervalGraph
intervals
        i :: Interval
i          = IntervalID -> Map IntervalID RelationBits -> Interval
Interval IntervalID
iD Map IntervalID RelationBits
iRelations

    forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
iD Interval
i IntervalGraph
intervals'
    forall (m :: * -> *) a. Monad m => a -> m a
return IntervalID
iD 

-- | Return the number of intervals that are currently in the graph.
intervalCount :: Allen Int 
intervalCount :: Allen IntervalID
intervalCount = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall k a. Map k a -> IntervalID
Map.size

-- | Given two intervals, return a copy of the first interval such that it now 
-- has the specified set of relations to the second interval.
--
-- This has no effect on the second interval or the network representation.
setRelation :: Interval -> RelationBits -> IntervalID -> Interval 
setRelation :: Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
i1 RelationBits
r IntervalID
i2 = Interval
i1 { intervalRelations :: Map IntervalID RelationBits
intervalRelations = Map IntervalID RelationBits
relations }
    where relations :: Map IntervalID RelationBits
relations = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
i2 RelationBits
r forall a b. (a -> b) -> a -> b
$ Interval -> Map IntervalID RelationBits
intervalRelations Interval
i1

-- | Define a relation between two intervals. 
assume :: IntervalID -> Relation -> IntervalID -> Allen ()
assume :: IntervalID
-> Relation -> IntervalID -> StateT IntervalGraph Identity ()
assume IntervalID
id1 Relation
r = IntervalID
-> RelationBits -> IntervalID -> StateT IntervalGraph Identity ()
assumeBits IntervalID
id1 (Relation -> RelationBits
toBits Relation
r)

-- | Define a set of relations between two intervals.
assumeSet :: IntervalID -> [Relation] -> IntervalID -> Allen ()
assumeSet :: IntervalID
-> [Relation] -> IntervalID -> StateT IntervalGraph Identity ()
assumeSet IntervalID
id1 = IntervalID
-> RelationBits -> IntervalID -> StateT IntervalGraph Identity ()
assumeBits IntervalID
id1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelationBits] -> RelationBits
relationUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Relation -> RelationBits
toBits

-- | Define a relation between two intervals using RelationBits.
assumeBits :: IntervalID -> RelationBits -> IntervalID -> Allen ()
assumeBits :: IntervalID
-> RelationBits -> IntervalID -> StateT IntervalGraph Identity ()
assumeBits IntervalID
id1 RelationBits
r IntervalID
id2 = do 
    Interval
i1 <- IntervalID -> Allen Interval
fromID IntervalID
id1 
    Interval
i2 <- IntervalID -> Allen Interval
fromID IntervalID
id2 

    let i1' :: Interval
i1' = Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
i1 RelationBits
r IntervalID
id2 
        i2' :: Interval
i2' = Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
i2 (RelationBits -> RelationBits
converse RelationBits
r) IntervalID
id1

    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
id1 Interval
i1' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
id2 Interval
i2'
    (IntervalID, IntervalID) -> StateT IntervalGraph Identity ()
propogate (IntervalID
id1, IntervalID
id2)

-- | Propogate the relations between two intervals to all other intervals 
-- that are related to either of the two intervals.
propogate :: (IntervalID, IntervalID) -> Allen ()
propogate :: (IntervalID, IntervalID) -> StateT IntervalGraph Identity ()
propogate (IntervalID, IntervalID)
r = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate' [(IntervalID, IntervalID)
r]

propogate' :: StateT [(IntervalID, IntervalID)] Allen ()
propogate' :: StateT
  [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate' = do 
    [(IntervalID, IntervalID)]
toDo <- forall s (m :: * -> *). MonadState s m => m s
get
    case [(IntervalID, IntervalID)]
toDo of 
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ((IntervalID
i, IntervalID
j):[(IntervalID, IntervalID)]
_) -> do 
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. [a] -> [a]
tail -- Remove the first element from the queue
            (IntervalID, IntervalID)
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate'' (IntervalID
i, IntervalID
j)
            (IntervalID, IntervalID)
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate'' (IntervalID
j, IntervalID
i)
            StateT
  [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate'

propogate'' :: (IntervalID, IntervalID) -> StateT [(IntervalID, IntervalID)] Allen () 
propogate'' :: (IntervalID, IntervalID)
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
propogate'' (IntervalID
i, IntervalID
j) = do 
    IntervalID
count <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Allen IntervalID
intervalCount

    let range :: [IntervalID]
range = [IntervalID
k | IntervalID
k <- [IntervalID
0 .. IntervalID
count forall a. Num a => a -> a -> a
- IntervalID
1], IntervalID
k forall a. Eq a => a -> a -> Bool
/= IntervalID
i, IntervalID
k forall a. Eq a => a -> a -> Bool
/= IntervalID
j]

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IntervalID]
range forall a b. (a -> b) -> a -> b
$ \IntervalID
k -> do 
        RelationBits
constraints <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ RelationBits -> RelationBits -> RelationBits
compose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
k IntervalID
i forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
i IntervalID
j
        RelationBits
nkj         <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
k IntervalID
j

        let rkj :: RelationBits
rkj = RelationBits
nkj forall a. Bits a => a -> a -> a
.&. RelationBits
constraints 

        -- If rkj is a proper subset of nkj, then add (k, j) to the queue
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelationBits
rkj forall a. Bits a => a -> a -> a
.|. RelationBits
nkj forall a. Eq a => a -> a -> Bool
== RelationBits
nkj Bool -> Bool -> Bool
&& RelationBits
rkj forall a. Ord a => a -> a -> Bool
< RelationBits
nkj) forall a b. (a -> b) -> a -> b
$ do 
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntervalID
k, IntervalID
j)forall a. a -> [a] -> [a]
:)

        Interval
intervalK <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ IntervalID -> Allen Interval
fromID IntervalID
k
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
k (Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
intervalK RelationBits
rkj IntervalID
j)

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IntervalID]
range forall a b. (a -> b) -> a -> b
$ \IntervalID
k -> do 
        RelationBits
constraints <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ RelationBits -> RelationBits -> RelationBits
compose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
i IntervalID
j forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
j IntervalID
k
        RelationBits
nik         <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
i IntervalID
k 

        let rik :: RelationBits
rik = RelationBits
nik forall a. Bits a => a -> a -> a
.&. RelationBits
constraints

        -- If rik is a proper subset of nik, then add (i, k) to the queue
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelationBits
rik forall a. Bits a => a -> a -> a
.|. RelationBits
nik forall a. Eq a => a -> a -> Bool
== RelationBits
nik Bool -> Bool -> Bool
&& RelationBits
rik forall a. Ord a => a -> a -> Bool
< RelationBits
nik) forall a b. (a -> b) -> a -> b
$ do 
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntervalID
i, IntervalID
k)forall a. a -> [a] -> [a]
:)

        Interval
intervalI <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ IntervalID -> Allen Interval
fromID IntervalID
i
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
i (Interval -> RelationBits -> IntervalID -> Interval
setRelation Interval
intervalI RelationBits
rik IntervalID
k)
   
-- | Return the set of possible constraints/relations between two intervals.
getConstraints :: IntervalID -> IntervalID -> Allen RelationBits
getConstraints :: IntervalID
-> IntervalID -> StateT IntervalGraph Identity RelationBits
getConstraints IntervalID
id1 IntervalID
id2 = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault RelationBits
0 IntervalID
id2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval -> Map IntervalID RelationBits
intervalRelations forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalID -> Allen Interval
fromID IntervalID
id1