-- | -- 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 = zip bits (reverse bits) where bits = map toBits allRelations -- | Return the converse of a Relation bitset. converse :: RelationBits -> RelationBits converse 0 = 0 converse x = relationUnion $ map func [0 .. fromEnum (maxBound :: Relation)] where func i | testBit x i = snd $ head $ filter ((== bit i) . fst) converseLookup | otherwise = 0 -- | Return if a relation exists between two intervals. testRelation :: Relation -> IntervalID -> IntervalID -> Allen Bool testRelation r id1 id2 = do relations <- Map.findWithDefault 0 id2 . intervalRelations <$> fromID id1 return $ toBits r .&. relations /= 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 r = testRelationBits (relationUnion $ map toBits 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 r id1 id2 = do relations <- Map.findWithDefault 0 id2 . intervalRelations <$> fromID id1 return $ r .&. relations >= r -- | Valid Chars: pmoFDseSdfoMP. relationFromChar :: Char -> Relation relationFromChar x = case x of 'p' -> Precedes 'm' -> Meets 'o' -> Overlaps 'F' -> FinishedBy 'D' -> Contains 's' -> Starts 'e' -> Equals 'S' -> StartedBy 'd' -> During 'f' -> Finishes 'O' -> OverlappedBy 'M' -> MetBy 'P' -> PrecededBy _ -> error $ "relationFromChar: invalid relation " <> [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 x | x == "full" = rBits allRelations | x == "concur" = rBits [Overlaps .. OverlappedBy] | otherwise = rBits $ map relationFromChar x where rBits = relationUnion . map toBits -- Table referenced from here: https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html composeLookup :: U.Vector RelationBits composeLookup = U.fromList $ map bitsFromString table -- | p | m | o | F | D | s | e | S | d | f | O | M | P -- ---------------+--------+--------+---------+--------+--------+--------+----+--------+---------+--------+---------+--------+------------- where table = [ "p", "p", "p", "p", "p", "p", "p", "p", "pmosd", "pmosd", "pmosd", "pmosd", "full" -- p , "p", "p", "p", "p", "p", "m", "m", "m", "osd", "osd", "osd", "Fef", "DSOMP" -- m , "p", "p", "pmo", "pmo", "pmoFD", "o", "o", "oFD", "osd", "osd", "concur", "DSO", "DSOMP" -- o , "p", "m", "o", "F", "D", "o", "F", "D", "osd", "Fef", "DSO", "DSO", "DSOMP" -- F , "pmoFD", "oFD", "oFD", "D", "D", "oFD", "D", "D", "concur", "DSO", "DSO", "DSO", "DSOMP" -- D , "p", "p", "pmo", "pmo", "pmoFD", "s", "s", "seS", "d", "d", "dfO", "M", "P" -- s , "p", "m", "o", "F", "D", "s", "e", "S", "d", "f", "O", "M", "P" -- e , "pmoFD", "oFD", "oFD", "D", "D", "seS", "S", "S", "dfO", "O", "O", "M", "P" -- S , "p", "p", "pmosd", "pmosd", "full", "d", "d", "dfOMP", "d", "d", "dfOMP", "P", "P" -- d , "p", "m", "osd", "Fef", "DSOMP", "d", "f", "OMP", "d", "f", "OMP", "P", "P" -- f , "pmoFD", "oFD", "concur", "DSO", "DSOMP", "dfO", "O", "OMP", "dfO", "O", "OMP", "P", "P" -- O , "pmoFD", "seS", "dfO", "M", "P", "dfO", "M", "P", "dfO", "M", "P", "P", "P" -- M , "full", "dfOMP", "dfOMOP", "P", "P", "dfOMP", "P", "P", "dfOMP", "P", "P", "P", "P" -- P ] -- | Compose two relations. -- -- Composition table available at . composeSingle :: Relation -> Relation -> RelationBits composeSingle r1 r2 = composeLookup U.! index where index = 13 * fromEnum r1 + fromEnum r2 -- | Compose two sets of relations. -- -- Composition table available at . compose :: RelationBits -> RelationBits -> RelationBits compose r1 r2 = relationUnion [composeSingle a b | a <- fromBits r1, b <- fromBits r2]