-- |
-- Module      : Data.Allen.Relation
-- Description : Functions for working with Allen's interval algebra relations.
-- Maintainer  : Archaversine 
--
-- This module provides functions for working with relations. Note that almost 
-- all exposed functions only work with relation bitsets. This is done mainly 
-- to optimize the speed in calculations involving relations. 
--
-- The 'RelationBits' type is a synonym for a 16 bit unsigned integer. Note that 
-- since Allen's interval algebra only defines 13 relations, the remaining 3 bits 
-- are unused. So the bit representation of every possible relation looks like 
-- this: 
--
-- @ 
-- 0b0001111111111111
-- @ 
--
-- Modifying the extra 3 bits will not affect the result of any calculations.
-- To view in exact detail how a `Relation` converted to a bit representation, 
-- see the `toBits` function.

module Data.Allen.Relation ( converse
                           , testRelation
                           , testRelationSet 
                           , testRelationBits
                           , composeSingle
                           , compose
                           , bitsFromString
                           ) where

import Data.Allen.Types
import Data.Bits

import qualified Data.Map.Strict as Map
import qualified Data.Vector.Unboxed as U

-- | Lookup table for converse function.
converseLookup :: [(RelationBits, RelationBits)]
converseLookup :: [(RelationBits, RelationBits)]
converseLookup = forall a b. [a] -> [b] -> [(a, b)]
zip [RelationBits]
bits (forall a. [a] -> [a]
reverse [RelationBits]
bits)
    where bits :: [RelationBits]
bits = forall a b. (a -> b) -> [a] -> [b]
map Relation -> RelationBits
toBits [Relation]
allRelations

-- | Return the converse of a Relation bitset.
converse :: RelationBits -> RelationBits 
converse :: RelationBits -> RelationBits
converse RelationBits
0 = RelationBits
0
converse RelationBits
x = [RelationBits] -> RelationBits
relationUnion forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map IntervalID -> RelationBits
func [IntervalID
0 .. forall a. Enum a => a -> IntervalID
fromEnum (forall a. Bounded a => a
maxBound :: Relation)]
    where func :: IntervalID -> RelationBits
func IntervalID
i | forall a. Bits a => a -> IntervalID -> Bool
testBit RelationBits
x IntervalID
i = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== forall a. Bits a => IntervalID -> a
bit IntervalID
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(RelationBits, RelationBits)]
converseLookup
                 | Bool
otherwise = RelationBits
0

-- | Return if a relation exists between two intervals.
testRelation :: Relation -> IntervalID -> IntervalID -> Allen Bool
testRelation :: Relation -> IntervalID -> IntervalID -> Allen Bool
testRelation Relation
r IntervalID
id1 IntervalID
id2 = do 
    RelationBits
relations <- 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 
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Relation -> RelationBits
toBits Relation
r forall a. Bits a => a -> a -> a
.&. RelationBits
relations forall a. Eq a => a -> a -> Bool
/= RelationBits
0

-- | Return if all relations in a set exist between two intervals. 
--
-- IF the set of relations between interval @a@ and interval @b@ is @full@, 
-- then the function will always return @True@.
testRelationSet :: [Relation] -> IntervalID -> IntervalID -> Allen Bool 
testRelationSet :: [Relation] -> IntervalID -> IntervalID -> Allen Bool
testRelationSet [Relation]
r = RelationBits -> IntervalID -> IntervalID -> Allen Bool
testRelationBits ([RelationBits] -> RelationBits
relationUnion forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Relation -> RelationBits
toBits [Relation]
r)

-- | Return if all relations in a set exist between two intervals.
--  
-- If the set of relations between interval @a@ and interval @b@ is @full@, 
-- then the function will always return @True@.
testRelationBits :: RelationBits -> IntervalID -> IntervalID -> Allen Bool
testRelationBits :: RelationBits -> IntervalID -> IntervalID -> Allen Bool
testRelationBits RelationBits
r IntervalID
id1 IntervalID
id2 = do 
    RelationBits
relations <- 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 
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RelationBits
r forall a. Bits a => a -> a -> a
.&. RelationBits
relations forall a. Ord a => a -> a -> Bool
>= RelationBits
r

-- | Valid Chars: pmoFDseSdfoMP.
relationFromChar :: Char -> Relation
relationFromChar :: Char -> Relation
relationFromChar Char
x = case Char
x of 
    Char
'p' -> Relation
Precedes 
    Char
'm' -> Relation
Meets 
    Char
'o' -> Relation
Overlaps 
    Char
'F' -> Relation
FinishedBy 
    Char
'D' -> Relation
Contains 
    Char
's' -> Relation
Starts 
    Char
'e' -> Relation
Equals 
    Char
'S' -> Relation
StartedBy 
    Char
'd' -> Relation
During 
    Char
'f' -> Relation
Finishes 
    Char
'O' -> Relation
OverlappedBy 
    Char
'M' -> Relation
MetBy 
    Char
'P' -> Relation
PrecededBy 
    Char
_   -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"relationFromChar: invalid relation " forall a. Semigroup a => a -> a -> a
<> [Char
x]


-- | Given a string, return the bit representation of the set of relations.
-- Valid characters: pmoFDseSdfoMP.
--
-- You may also use @full@ to represent all relations, or @concur@ to represent
-- all relations excluding Precedes and PrecededBy.
--
-- Example:
-- 
-- @
-- let x = 'bitsFromString' "pms"    -- [Precedes, Meets, StartedBy]
--     y = 'bitsFromString' "full"   -- [Precedes .. PrecededBy]
--     z = 'bitsFromString' "concur" -- [Overlaps .. OverlappedBy]
-- @
bitsFromString :: String -> RelationBits
bitsFromString :: [Char] -> RelationBits
bitsFromString [Char]
x | [Char]
x forall a. Eq a => a -> a -> Bool
== [Char]
"full"   = [Relation] -> RelationBits
rBits [Relation]
allRelations 
                 | [Char]
x forall a. Eq a => a -> a -> Bool
== [Char]
"concur" = [Relation] -> RelationBits
rBits [Relation
Overlaps .. Relation
OverlappedBy]
                 | Bool
otherwise = [Relation] -> RelationBits
rBits forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Relation
relationFromChar [Char]
x
    where rBits :: [Relation] -> RelationBits
rBits = [RelationBits] -> RelationBits
relationUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Relation -> RelationBits
toBits

-- Table referenced from here: https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html
composeLookup :: U.Vector RelationBits
composeLookup :: Vector RelationBits
composeLookup = forall a. Unbox a => [a] -> Vector a
U.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> RelationBits
bitsFromString [[Char]]
table 
--                |    p   |    m   |   o     |  F     |  D     |  s     |  e |   S    |     d   |    f   |     O   |    M   |    P
-- ---------------+--------+--------+---------+--------+--------+--------+----+--------+---------+--------+---------+--------+-------------
    where table :: [[Char]]
table = [     [Char]
"p",     [Char]
"p",      [Char]
"p",     [Char]
"p",     [Char]
"p",     [Char]
"p", [Char]
"p",     [Char]
"p",  [Char]
"pmosd", [Char]
"pmosd",  [Char]
"pmosd", [Char]
"pmosd",  [Char]
"full" -- p
                  ,     [Char]
"p",     [Char]
"p",      [Char]
"p",     [Char]
"p",     [Char]
"p",     [Char]
"m", [Char]
"m",     [Char]
"m",    [Char]
"osd",   [Char]
"osd",    [Char]
"osd",   [Char]
"Fef", [Char]
"DSOMP" -- m
                  ,     [Char]
"p",     [Char]
"p",    [Char]
"pmo",   [Char]
"pmo", [Char]
"pmoFD",     [Char]
"o", [Char]
"o",   [Char]
"oFD",    [Char]
"osd",   [Char]
"osd", [Char]
"concur",   [Char]
"DSO", [Char]
"DSOMP" -- o
                  ,     [Char]
"p",     [Char]
"m",      [Char]
"o",     [Char]
"F",     [Char]
"D",     [Char]
"o", [Char]
"F",     [Char]
"D",    [Char]
"osd",   [Char]
"Fef",    [Char]
"DSO",   [Char]
"DSO", [Char]
"DSOMP" -- F
                  , [Char]
"pmoFD",   [Char]
"oFD",    [Char]
"oFD",     [Char]
"D",     [Char]
"D",   [Char]
"oFD", [Char]
"D",     [Char]
"D", [Char]
"concur",   [Char]
"DSO",    [Char]
"DSO",   [Char]
"DSO", [Char]
"DSOMP" -- D
                  ,     [Char]
"p",     [Char]
"p",    [Char]
"pmo",   [Char]
"pmo", [Char]
"pmoFD",     [Char]
"s", [Char]
"s",   [Char]
"seS",      [Char]
"d",     [Char]
"d",    [Char]
"dfO",     [Char]
"M",     [Char]
"P" -- s
                  ,     [Char]
"p",     [Char]
"m",      [Char]
"o",     [Char]
"F",     [Char]
"D",     [Char]
"s", [Char]
"e",     [Char]
"S",      [Char]
"d",     [Char]
"f",      [Char]
"O",     [Char]
"M",     [Char]
"P" -- e
                  , [Char]
"pmoFD",   [Char]
"oFD",    [Char]
"oFD",     [Char]
"D",     [Char]
"D",   [Char]
"seS", [Char]
"S",     [Char]
"S",    [Char]
"dfO",     [Char]
"O",      [Char]
"O",     [Char]
"M",     [Char]
"P" -- S
                  ,     [Char]
"p",     [Char]
"p",  [Char]
"pmosd", [Char]
"pmosd",  [Char]
"full",     [Char]
"d", [Char]
"d", [Char]
"dfOMP",      [Char]
"d",     [Char]
"d",  [Char]
"dfOMP",     [Char]
"P",     [Char]
"P" -- d
                  ,     [Char]
"p",     [Char]
"m",    [Char]
"osd",   [Char]
"Fef", [Char]
"DSOMP",     [Char]
"d", [Char]
"f",   [Char]
"OMP",      [Char]
"d",     [Char]
"f",    [Char]
"OMP",     [Char]
"P",     [Char]
"P" -- f
                  , [Char]
"pmoFD",   [Char]
"oFD", [Char]
"concur",   [Char]
"DSO", [Char]
"DSOMP",   [Char]
"dfO", [Char]
"O",   [Char]
"OMP",    [Char]
"dfO",     [Char]
"O",    [Char]
"OMP",     [Char]
"P",     [Char]
"P" -- O
                  , [Char]
"pmoFD",   [Char]
"seS",    [Char]
"dfO",     [Char]
"M",     [Char]
"P",   [Char]
"dfO", [Char]
"M",     [Char]
"P",    [Char]
"dfO",     [Char]
"M",      [Char]
"P",     [Char]
"P",     [Char]
"P" -- M
                  ,  [Char]
"full", [Char]
"dfOMP", [Char]
"dfOMOP",     [Char]
"P",     [Char]
"P", [Char]
"dfOMP", [Char]
"P",     [Char]
"P",  [Char]
"dfOMP",     [Char]
"P",      [Char]
"P",     [Char]
"P",     [Char]
"P" -- P
                  ]

-- | Compose two relations.
--
-- Composition table available at <https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html>.
composeSingle :: Relation -> Relation -> RelationBits 
composeSingle :: Relation -> Relation -> RelationBits
composeSingle Relation
r1 Relation
r2 = Vector RelationBits
composeLookup forall a. Unbox a => Vector a -> IntervalID -> a
U.! IntervalID
index
    where index :: IntervalID
index = IntervalID
13 forall a. Num a => a -> a -> a
* forall a. Enum a => a -> IntervalID
fromEnum Relation
r1 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> IntervalID
fromEnum Relation
r2

-- | Compose two sets of relations.
--
-- Composition table available at <https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html>.
compose :: RelationBits -> RelationBits -> RelationBits
compose :: RelationBits -> RelationBits -> RelationBits
compose RelationBits
r1 RelationBits
r2 = [RelationBits] -> RelationBits
relationUnion [Relation -> Relation -> RelationBits
composeSingle Relation
a Relation
b | Relation
a <- RelationBits -> [Relation]
fromBits RelationBits
r1, Relation
b <- RelationBits -> [Relation]
fromBits RelationBits
r2]