-- |
-- 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 <- StateT IntervalGraph Identity IntervalGraph
forall s (m :: * -> *). MonadState s m => m s
get

    let iD :: IntervalID
iD         = IntervalGraph -> IntervalID
forall k a. Map k a -> IntervalID
Map.size IntervalGraph
intervals
        iRelations :: Map IntervalID RelationBits
iRelations = [(IntervalID, RelationBits)] -> Map IntervalID RelationBits
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(IntervalID
x, RelationBits
allRelationBits) | IntervalID
x <- [IntervalID
0 .. IntervalID
iD IntervalID -> IntervalID -> IntervalID
forall a. Num a => a -> a -> a
- IntervalID
1]]
        intervals' :: IntervalGraph
intervals' = (Interval -> Interval) -> IntervalGraph -> IntervalGraph
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

    IntervalGraph -> StateT IntervalGraph Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntervalGraph -> StateT IntervalGraph Identity ())
-> IntervalGraph -> StateT IntervalGraph Identity ()
forall a b. (a -> b) -> a -> b
$ IntervalID -> Interval -> IntervalGraph -> IntervalGraph
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
iD Interval
i IntervalGraph
intervals'
    IntervalID -> Allen IntervalID
forall a. a -> StateT IntervalGraph Identity a
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 = (IntervalGraph -> IntervalID) -> Allen IntervalID
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IntervalGraph -> IntervalID
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 = IntervalID
-> RelationBits
-> Map IntervalID RelationBits
-> Map IntervalID RelationBits
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
i2 RelationBits
r (Map IntervalID RelationBits -> Map IntervalID RelationBits)
-> Map IntervalID RelationBits -> Map IntervalID RelationBits
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 (RelationBits -> IntervalID -> StateT IntervalGraph Identity ())
-> ([Relation] -> RelationBits)
-> [Relation]
-> IntervalID
-> StateT IntervalGraph Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelationBits] -> RelationBits
relationUnion ([RelationBits] -> RelationBits)
-> ([Relation] -> [RelationBits]) -> [Relation] -> RelationBits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relation -> RelationBits) -> [Relation] -> [RelationBits]
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

    (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntervalGraph -> IntervalGraph)
 -> StateT IntervalGraph Identity ())
-> (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall a b. (a -> b) -> a -> b
$ IntervalID -> Interval -> IntervalGraph -> IntervalGraph
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IntervalID
id1 Interval
i1' (IntervalGraph -> IntervalGraph)
-> (IntervalGraph -> IntervalGraph)
-> IntervalGraph
-> IntervalGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalID -> Interval -> IntervalGraph -> IntervalGraph
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 = StateT
  [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
-> [(IntervalID, IntervalID)] -> StateT IntervalGraph Identity ()
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 <- StateT
  [(IntervalID, IntervalID)]
  (StateT IntervalGraph Identity)
  [(IntervalID, IntervalID)]
forall s (m :: * -> *). MonadState s m => m s
get
    case [(IntervalID, IntervalID)]
toDo of 
        [] -> ()
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall a.
a
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ((IntervalID
i, IntervalID
j):[(IntervalID, IntervalID)]
_) -> do 
            ([(IntervalID, IntervalID)] -> [(IntervalID, IntervalID)])
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify [(IntervalID, IntervalID)] -> [(IntervalID, IntervalID)]
forall a. HasCallStack => [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 <- Allen IntervalID
-> StateT
     [(IntervalID, IntervalID)]
     (StateT IntervalGraph Identity)
     IntervalID
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [(IntervalID, IntervalID)] m a
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 IntervalID -> IntervalID -> IntervalID
forall a. Num a => a -> a -> a
- IntervalID
1], IntervalID
k IntervalID -> IntervalID -> Bool
forall a. Eq a => a -> a -> Bool
/= IntervalID
i, IntervalID
k IntervalID -> IntervalID -> Bool
forall a. Eq a => a -> a -> Bool
/= IntervalID
j]

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

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

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

        Interval
intervalK <- Allen Interval
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) Interval
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [(IntervalID, IntervalID)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Allen Interval
 -> StateT
      [(IntervalID, IntervalID)]
      (StateT IntervalGraph Identity)
      Interval)
-> Allen Interval
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) Interval
forall a b. (a -> b) -> a -> b
$ IntervalID -> Allen Interval
fromID IntervalID
k
        StateT IntervalGraph Identity ()
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [(IntervalID, IntervalID)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT IntervalGraph Identity ()
 -> StateT
      [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ())
-> StateT IntervalGraph Identity ()
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall a b. (a -> b) -> a -> b
$ (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntervalGraph -> IntervalGraph)
 -> StateT IntervalGraph Identity ())
-> (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall a b. (a -> b) -> a -> b
$ IntervalID -> Interval -> IntervalGraph -> IntervalGraph
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)

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

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

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

        Interval
intervalI <- Allen Interval
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) Interval
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [(IntervalID, IntervalID)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Allen Interval
 -> StateT
      [(IntervalID, IntervalID)]
      (StateT IntervalGraph Identity)
      Interval)
-> Allen Interval
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) Interval
forall a b. (a -> b) -> a -> b
$ IntervalID -> Allen Interval
fromID IntervalID
i
        StateT IntervalGraph Identity ()
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [(IntervalID, IntervalID)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT IntervalGraph Identity ()
 -> StateT
      [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ())
-> StateT IntervalGraph Identity ()
-> StateT
     [(IntervalID, IntervalID)] (StateT IntervalGraph Identity) ()
forall a b. (a -> b) -> a -> b
$ (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntervalGraph -> IntervalGraph)
 -> StateT IntervalGraph Identity ())
-> (IntervalGraph -> IntervalGraph)
-> StateT IntervalGraph Identity ()
forall a b. (a -> b) -> a -> b
$ IntervalID -> Interval -> IntervalGraph -> IntervalGraph
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 -> Allen RelationBits
getConstraints IntervalID
id1 IntervalID
id2 = RelationBits
-> IntervalID -> Map IntervalID RelationBits -> RelationBits
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault RelationBits
0 IntervalID
id2 (Map IntervalID RelationBits -> RelationBits)
-> (Interval -> Map IntervalID RelationBits)
-> Interval
-> RelationBits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval -> Map IntervalID RelationBits
intervalRelations (Interval -> RelationBits) -> Allen Interval -> Allen RelationBits
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalID -> Allen Interval
fromID IntervalID
id1