diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `allen` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# Haskell - Allen's Interval Algebra Implementation + +An Implementation of Allen's Interval Algebra in Haskell. + +This library provides a monadic way to perform computations related to Allen's +interval algebra. The interval network strucutre is implicitly updated upon +the creation of a new interval and when a set of relations is applied to two +intervals. + +## Sources + +This library is based off of the interval algebra described in +[Maintaining Knowledge about Temporal Intervals](https://cse.unl.edu/~choueiry/Documents/Allen-CACM1983.pdf), +and [Allen's Interval Algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html). + +## Examples + +Assume a situation with three intervals: + +1. I am walking. +2. I am talking. +3. My friend calls me. + +and assume that we know the following: + +- When I am walking, I am not talking. +- When my friend called me, I started talking. + +we can easily compute the relations between when I was walking and when my friend called me: + +```haskell +calc :: Allen [Relation] +calc = do + walking <- interval + talking <- interval + friend <- interval + + assumeSet walking [Precedes, Meets, MetBy, PrecededBy] talking + assume friend Starts talking + + relations <- getConstraints walking friend + + return (fromBits relations) + +main :: IO () +main = print $ evalAllen calc +``` + +And this gives the result: + +``` +[Precedes,Meets,PrecededBy] +``` + +Which means that we can deduce that walking either happens before, directly +before, or after my friend calls. + +## Documentation + +To view more information for library functions, you can view the documentation +for this library [here](https://archaversine.github.io/allen/Data-Allen.html). + +## Interactive REPL + +You can use an interactive REPL to perform calculations from the command line. +Executables are available for both Linux and Windows. + +You can download the interactive version here: + +- [Linux](https://github.com/Archaversine/allen/releases/tag/v1.0.1-linux) +- [Windows](https://github.com/Archaversine/allen/releases/tag/v1.0.1-windows) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/allen.cabal b/allen.cabal new file mode 100644 --- /dev/null +++ b/allen.cabal @@ -0,0 +1,96 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: allen +version: 0.1.0.0 +synopsis: A monadic way of calculating relations between intervals of time. +description: Please see the README on GitHub at +category: Algebra +homepage: https://github.com/archaversine/allen#readme +bug-reports: https://github.com/archaversine/allen/issues +author: Adam Brohl +maintainer: awbrohl@knox.edu +copyright: 2023 Adam Brohl +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/archaversine/allen + +library + exposed-modules: + Data.Allen + Data.Allen.Interval + Data.Allen.Relation + Data.Allen.Types + other-modules: + Paths_allen + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , containers >=0.6.4 && <0.7 + , mtl >=2.2.2 && <2.3 + , vector >=0.13.0 && <0.14 + default-language: Haskell2010 + +executable allen-calculator + main-is: Main.hs + other-modules: + Paths_allen + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=2.1.2 && <2.2 + , allen + , base >=4.7 && <5 + , bytestring >=0.11.2.0 && <0.12 + , containers >=0.6.4 && <0.7 + , mtl >=2.2.2 && <2.3 + , text ==2.0.2.* + , vector >=0.13.0 && <0.14 + default-language: Haskell2010 + +test-suite allen-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_allen + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.14.3 && <2.15 + , allen + , base >=4.7 && <5 + , containers >=0.6.4 && <0.7 + , mtl >=2.2.2 && <2.3 + , vector >=0.13.0 && <0.14 + default-language: Haskell2010 + +benchmark allen-benchmarks + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Paths_allen + hs-source-dirs: + bench + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + allen + , base >=4.7 && <5 + , containers >=0.6.4 && <0.7 + , criterion >=1.6.2 && <1.7 + , mtl >=2.2.2 && <2.3 + , vector >=0.13.0 && <0.14 + default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Monad +import Control.Monad.State + +import Data.Aeson +import Data.Allen +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Text (Text, pack, unpack) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.ByteString as BS + +import GHC.Generics (Generic) + +import System.IO +import System.Environment + +data RelationJSON = RelationJSON { relationFrom :: Int + , relationTo :: Int + , relChars :: Text + } deriving Generic + +data NetworkJSON = NetworkJSON { ivCount :: Int + , relations :: [RelationJSON] + } + +data IntervalJSON = IntervalJSON { ivID :: Int + , ivRels :: [RelationJSON] + } deriving Generic + +newtype ResultJSON = ResultJSON { result :: [IntervalJSON] } deriving Generic + +instance ToJSON RelationJSON where + toJSON (RelationJSON a b r) = object [ "from" .= a, "to" .= b, "relation" .= r ] + +instance ToJSON IntervalJSON where + toJSON (IntervalJSON i r) = object [ "id" .= i, "relations" .= r ] + +instance ToJSON ResultJSON where + toJSON (ResultJSON r) = object [ "intervals" .= r ] + +instance FromJSON RelationJSON where + parseJSON = withObject "RelationJSON" $ \v -> RelationJSON + <$> v .: "from" + <*> v .: "to" + <*> v .: "relation" + +instance FromJSON NetworkJSON where + parseJSON = withObject "NetworkJSON" $ \v -> NetworkJSON + <$> v .: "intervals" + <*> v .: "relations" + +data REPLState = REPLState { graph :: Allen (), intervalNames :: Map String IntervalID } +type REPL = StateT REPLState IO + +newREPLState :: REPLState +newREPLState = REPLState (return ()) Map.empty + +withIntervals :: String -> String -> (IntervalID -> IntervalID -> REPL ()) -> REPL () +withIntervals a b func = do + names <- gets intervalNames + + case (Map.lookup a names, Map.lookup b names) of + (Just aID, Just bID) -> func aID bID + (Nothing, _) -> liftIO $ putStrLn $ "Interval " <> a <> " does not exist" + (_, Nothing) -> liftIO $ putStrLn $ "Interval " <> b <> " does not exist" + +createInterval :: String -> REPL () +createInterval name = do + REPLState calc names <- get + + case Map.lookup name names of + Just _ -> error $ "Interval " ++ name ++ " already exists" + Nothing -> do + let newID = Map.size names + put $ REPLState (void $ calc >> interval) (Map.insert name newID names) + +assumeRelation :: String -> RelationBits -> String -> REPL () +assumeRelation a r b = do + REPLState calc names <- get + + withIntervals a b $ \aID bID -> do + put $ REPLState (calc >> assumeBits aID r bID) names + +showConstraints :: String -> String -> REPL () +showConstraints a b = do + calc <- gets graph + + withIntervals a b $ \aID bID -> do + let constraints = fromBits $ evalAllen $ calc >> getConstraints aID bID + liftIO $ putStrLn $ a <> " --(" <> map relationToChar constraints <> ")--> " <> b + +showGraph :: REPL () +showGraph = do + REPLState calc names <- get + + let sorted = sortBy (comparing fst) $ Map.toList names + + liftIO $ mapM_ printPair sorted + liftIO $ putStrLn "---------------------------------------------" + liftIO $ mapM_ (print . snd) $ Map.toList $ execAllen calc + where printPair (name, iD) = putStrLn $ show iD <> ": " <> name + +resetGraph :: REPL () +resetGraph = put newREPLState + +data Command = CreateInterval String + | AssumeRelation String RelationBits String + | GetConstraints String String + | ShowGraph + | ResetGraph + | Help + | Quit + | InvalidCommand + +parseCommand :: String -> Command +parseCommand str = case words str of + [ "create", name ] -> CreateInterval name + [ "assume", a, rel, b ] -> AssumeRelation a (bitsFromString rel) b + [ "constraints", a, b ] -> GetConstraints a b + [ "graph" ] -> ShowGraph + [ "clear" ] -> ResetGraph + [ "help" ] -> Help + [ "exit" ] -> Quit + _ -> InvalidCommand + +readCommand :: IO Command +readCommand = do + putStr "Allen > " + command <- parseCommand <$> getLine + + case command of + InvalidCommand -> do + putStrLn "Invalid command" + readCommand + _ -> return command + +printHelp :: IO () +printHelp = do + putStrLn "Commands:" + putStrLn " create Create a new interval with the given name" + putStrLn " assume Assume that a and b have the given relation" + putStrLn " (Use: pmoFDseSdfoMP to represent relations)" + putStrLn " constraints Show the constraints between a and b" + putStrLn " graph Show the current graph" + putStrLn " clear Clear the current graph" + putStrLn " help Show this help message" + putStrLn " exit Exit the program" + +repl :: REPL () +repl = do + command <- liftIO readCommand + + case command of + CreateInterval name -> createInterval name >> repl + AssumeRelation a r b -> assumeRelation a r b >> repl + GetConstraints a b -> showConstraints a b >> repl + ShowGraph -> showGraph >> repl + ResetGraph -> resetGraph >> repl + Help -> liftIO printHelp >> repl + Quit -> return () + InvalidCommand -> do + liftIO $ putStrLn "Error: Invalid Command" + repl + +addRelationJSON :: RelationJSON -> Allen () +addRelationJSON rel = assumeBits a r b + where a = relationFrom rel + b = relationTo rel + r = bitsFromString $ unpack $ relChars rel + +jsonToGraph :: NetworkJSON -> IntervalGraph +jsonToGraph network = execAllen $ do + replicateM_ (ivCount network) interval + mapM_ addRelationJSON (relations network) + +toResultJSON :: IntervalGraph -> ResultJSON +toResultJSON = ResultJSON . map toIntervalJSON . Map.toList + where toIntervalJSON (iD, iv ) = IntervalJSON iD (map toRelationJSON $ Map.toList $ intervalRelations iv) + toRelationJSON (iD, bits) = RelationJSON iD (iD + 1) (pack $ map relationToChar $ fromBits bits) + +calcJSON :: NetworkJSON -> ResultJSON +calcJSON = toResultJSON . jsonToGraph + +startRepl :: IO () +startRepl = do + putStrLn "Interactive Allen's Interval Algebra Solver" + putStrLn "Author: Archaversine" + putStrLn "Type 'help' for a list of commands" + putStrLn "------------------------------------------" + evalStateT repl newREPLState + +main :: IO () +main = do + -- Fix buffering so that we can see the prompt + hSetBuffering stdout NoBuffering + + args <- getArgs + + case args of + [ ] -> startRepl + [from, to] -> do + contents <- BS.readFile from + + let decoded = eitherDecode (BS.fromStrict contents) :: Either String NetworkJSON + case decoded of + Left m -> errorWithoutStackTrace m + Right j -> BS.writeFile to (BS.toStrict $ encode $ calcJSON j) + + _ -> do + putStrLn "Usage: allen [input] [output]" + putStrLn " allen" + + errorWithoutStackTrace "Invalid Arguments." + diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BinaryLiterals #-} + +module Main (main) where + +import Criterion.Main +import Criterion.Types + +import Data.Allen + +benchConfig :: Config +benchConfig = defaultConfig { reportFile = Just "benchmark.html" } + +main :: IO () +main = defaultMainWith benchConfig [ + bgroup "Relation" [ bench "compose-0bits " $ whnf testCompose 0b0000000000000000 + , bench "compose-1bit " $ whnf testCompose 0b0000000000000001 + , bench "compose-2bits " $ whnf testCompose 0b0000000000000011 + , bench "compose-4bits " $ whnf testCompose 0b0000000000001111 + , bench "compose-8bits " $ whnf testCompose 0b0000000011111111 + , bench "compose-13bits" $ whnf testCompose 0b0001111111111111 + ] + ] + +testCompose :: RelationBits -> RelationBits +testCompose x = compose x x diff --git a/src/Data/Allen.hs b/src/Data/Allen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Allen.hs @@ -0,0 +1,131 @@ +-- | +-- Module : Data.Allen +-- Description : Main module for Allen's interval algebra. +-- Maintainer : Archaversine +-- +-- This module provides a monad for computing with Allen's interval algebra. +-- The monad keeps track of the interval graph that is being built up during +-- the computation. The interval graph is represented as a map from interval +-- identifiers to intervals. +-- +-- = Intervals +-- Intervals can be created using the 'interval' function: +-- +-- @ +-- calc :: 'Allen' () +-- calc = do +-- sleeps <- 'interval' +-- snores <- 'interval' +-- wakeup <- 'interval' +-- ... +-- @ +-- +-- == Retrieving interval data +-- Most functions perform operations on intervals solely with the use of their +-- IDs. However, sometimes it is useful to retrieve the actual interval data. +-- To get the actual interval data, use the 'fromID' function: +-- +-- @ +-- calc :: Allen () +-- calc = do +-- sleeps <- 'interval' +-- sleepsInterval <- 'fromID' sleeps +-- ... +-- @ +-- +-- Note that in the above example, updating the interval @sleeps@ will not +-- update the interval @sleepsInterval@. +-- +-- == Combining calculations +-- Sometimes, it is useful to define a set of intervals in one place and use +-- then repeatedly in other places. Here is an example that reuses the intervals +-- @a@ and @b@: +-- +-- @ +-- network :: 'Allen' ('IntervalID', 'IntervalID') +-- network = do +-- a <- 'interval' +-- b <- 'interval' +-- +-- 'assume' a 'During' b +-- +-- return (a, b) +-- +-- calc1 :: 'Allen' () +-- calc1 = do +-- (a, b) <- network +-- c <- 'interval' +-- +-- 'assume' a 'Precedes' c +-- ... +-- +-- calc2 :: 'Allen' () +-- calc2 = do +-- (a, b) <- network +-- c <- 'interval' +-- +-- 'assume' a 'Contains' c +-- ... +-- @ +-- +-- = Relations +-- Intervals can have relations with one another. For example, in the above +-- example a valid relation would be that one sleeps during snores. Adding +-- relations is done using one of the assume functions: +-- +-- @ +-- calc :: Allen () +-- calc = do +-- sleeps <- 'interval' +-- snores <- 'interval' +-- wakeup <- 'interval' +-- +-- 'assume' snores 'During' sleeps +-- 'assume' wakeup 'PrecededBy' sleeps +-- @ +-- +-- Sometimes, intervals have more than one possible relation with one another. +-- For example, snores is 'During' sleeps, but it could also be 'StartedBy' sleeps, +-- or it could 'Equals' sleeps. In such cases, the 'assumeSet' function can be +-- used: +-- +-- @ +-- calc :: 'Allen' () +-- calc = do +-- sleeps <- 'interval' +-- snores <- 'interval' +-- wakeup <- 'interval' +-- +-- 'assumeSet' snores ['During', 'StartedBy', 'Equals'] sleeps +-- @ +-- +-- There are thirteen different relations intervals can have with each other. +-- They are identified with the 'Relation' type. + +module Data.Allen ( module Data.Allen.Types + , module Data.Allen.Interval + , module Data.Allen.Relation + , execAllen + , evalAllen + , runAllen + ) where + +import Control.Monad.State + +import Data.Allen.Types +import Data.Allen.Interval +import Data.Allen.Relation + +import qualified Data.Map.Strict as Map + +-- | Return the resulting interval graph of an allen computation +execAllen :: Allen a -> IntervalGraph +execAllen = snd . runAllen + +-- | Return the result of an allen computation +evalAllen :: Allen a -> a +evalAllen = fst . runAllen + +-- | Return the result of an allen computation and the resulting interval graph +runAllen :: Allen a -> (a, IntervalGraph) +runAllen = flip runState Map.empty diff --git a/src/Data/Allen/Interval.hs b/src/Data/Allen/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Allen/Interval.hs @@ -0,0 +1,211 @@ +-- | +-- 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 = do + intervals <- get + + let iD = Map.size intervals + iRelations = Map.fromList [(x, allRelationBits) | x <- [0 .. iD - 1]] + intervals' = Map.map (\x -> setRelation x allRelationBits iD) intervals + i = Interval iD iRelations + + put $ Map.insert iD i intervals' + return iD + +-- | Return the number of intervals that are currently in the graph. +intervalCount :: Allen Int +intervalCount = gets 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 i1 r i2 = i1 { intervalRelations = relations } + where relations = Map.insert i2 r $ intervalRelations i1 + +-- | Define a relation between two intervals. +assume :: IntervalID -> Relation -> IntervalID -> Allen () +assume id1 r = assumeBits id1 (toBits r) + +-- | Define a set of relations between two intervals. +assumeSet :: IntervalID -> [Relation] -> IntervalID -> Allen () +assumeSet id1 = assumeBits id1 . relationUnion . map toBits + +-- | Define a relation between two intervals using RelationBits. +assumeBits :: IntervalID -> RelationBits -> IntervalID -> Allen () +assumeBits id1 r id2 = do + i1 <- fromID id1 + i2 <- fromID id2 + + let i1' = setRelation i1 r id2 + i2' = setRelation i2 (converse r) id1 + + modify $ Map.insert id1 i1' . Map.insert id2 i2' + propogate (id1, 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 r = evalStateT propogate' [r] + +propogate' :: StateT [(IntervalID, IntervalID)] Allen () +propogate' = do + toDo <- get + case toDo of + [] -> return () + ((i, j):_) -> do + modify tail -- Remove the first element from the queue + propogate'' (i, j) + propogate'' (j, i) + propogate' + +propogate'' :: (IntervalID, IntervalID) -> StateT [(IntervalID, IntervalID)] Allen () +propogate'' (i, j) = do + count <- lift intervalCount + + let range = [k | k <- [0 .. count - 1], k /= i, k /= j] + + forM_ range $ \k -> do + constraints <- lift $ compose <$> getConstraints k i <*> getConstraints i j + nkj <- lift $ getConstraints k j + + let rkj = nkj .&. constraints + + -- If rkj is a proper subset of nkj, then add (k, j) to the queue + when (rkj .|. nkj == nkj && rkj < nkj) $ do + modify ((k, j):) + + intervalK <- lift $ fromID k + lift $ modify $ Map.insert k (setRelation intervalK rkj j) + + forM_ range $ \k -> do + constraints <- lift $ compose <$> getConstraints i j <*> getConstraints j k + nik <- lift $ getConstraints i k + + let rik = nik .&. constraints + + -- If rik is a proper subset of nik, then add (i, k) to the queue + when (rik .|. nik == nik && rik < nik) $ do + modify ((i, k):) + + intervalI <- lift $ fromID i + lift $ modify $ Map.insert i (setRelation intervalI rik k) + +-- | Return the set of possible constraints/relations between two intervals. +getConstraints :: IntervalID -> IntervalID -> Allen RelationBits +getConstraints id1 id2 = Map.findWithDefault 0 id2 . intervalRelations <$> fromID id1 + diff --git a/src/Data/Allen/Relation.hs b/src/Data/Allen/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Allen/Relation.hs @@ -0,0 +1,141 @@ +-- | +-- 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] diff --git a/src/Data/Allen/Types.hs b/src/Data/Allen/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Allen/Types.hs @@ -0,0 +1,154 @@ +-- | +-- Module : Data.Allen.Types +-- Description : Types for Allen's interval algebra. +-- Maintainer : Archaversine +-- +-- This module provides types that are used throughout the rest of the library. +-- This includes types for intervals, relations, and the interval graph. +-- +-- = Intervals +-- An Interval is a data type that represents a single interval. It contains +-- an ID of type 'IntervalID' and a map of relations to other intervals of type +-- Map 'IntervalID' 'RelationBits'. +-- +-- An `IntervalID` is essentially the same as an @Int@, but it is helpful to +-- have a dedicated type synonym to distinguish functions that perform operations +-- interval IDs. +-- +-- = Relations +-- A 'Relation' is a data type that represents a relation between two intervals. +-- It is defined in terms of thirteen constructors, where each constructor +-- represents one of the thirteen possible relations in Allen's interval algebra. +-- +-- The 'RelationBits' is used to represent a set of possible representation. +-- It is synonymous with a @Word16@, and is used to represent a set of possible +-- relations. Since there are only thirteen different relations, only 13 of the +-- 16 bits in the @Word16@ are used. +-- +-- = Interval Graph +-- An interval graph is a map of 'IntervalID's to 'Interval's. It is used to +-- represent the network of intervals and their relations to each other. +-- +-- = Allen Monad +-- The Allen monad is a state monad that is used to keep track of the interval +-- graph that is being built up during the computation. Since it is a synonym +-- of the @State@ monad, it is possible to use all of the functions in the +-- @Control.Monad.State@ module. + +module Data.Allen.Types ( Interval(..) + , Allen + , IntervalID + , IntervalGraph + , Relation(..) + , RelationBits + , allRelations + , allRelationBits + , toBits + , fromBits + , relationUnion + , relationIntersection + , relationToChar + , fromID + ) where + +import Control.Monad.State + +import Data.Bits +import Data.List (intercalate, foldl') +import Data.Word (Word16) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +-- | How intervals are uniquely identified. +type IntervalID = Int + +-- | This is the main type that is used to represent the network of intervals. +type IntervalGraph = Map IntervalID Interval + +-- | An interval is a data type that represents a single interval. It contains +-- an ID of type 'IntervalID' and a map of relations to other intervals of type +-- Map 'IntervalID' 'RelationBits'. It should not be directly used in a +-- computation unless the 'IntervalGraph' is in its final state. +data Interval = Interval { intervalID :: Int + , intervalRelations :: Map IntervalID RelationBits + } + +-- | Ex: Interval 3 (d 1, D 2) +instance Show Interval where + show (Interval iD rels) = "Interval " <> show iD <> " (" <> rels' <> ")" + where rels' = intercalate ", " $ map showRel $ Map.toList rels + showRel (n, r) | r == allRelationBits = "??? " <> show n + | otherwise = map relationToChar (fromBits r) <> " " <> show n + +-- | Return the interval given it's ID. +-- Panics if ID doesn't exist. +fromID :: IntervalID -> Allen Interval +fromID n = gets (Map.! n) + +-- | A specific instance of the state monad that is used to keep track of the +-- 'IntervalGraph' that is being built up during the computation. +type Allen = State IntervalGraph + +-- | A type where each constructor represents one of the thirteen relations in +-- Allen's interval algebra. +data Relation = Precedes -- ^ In Char form: __p__ + | Meets -- ^ In Char form: __m__ + | Overlaps -- ^ In Char form: __o__ + | FinishedBy -- ^ In Char form: __F__ + | Contains -- ^ In Char form: __D__ + | Starts -- ^ In Char form: __s__ + | Equals -- ^ In Char form: __e__ + | StartedBy -- ^ In Char form: __S__ + | During -- ^ In Char form: __d__ + | Finishes -- ^ In Char form: __f__ + | OverlappedBy -- ^ In Char form: __O__ + | MetBy -- ^ In Char form: __M__ + | PrecededBy -- ^ In Char form: __P__ + deriving (Eq, Show, Enum, Bounded) + +-- | Convert a relation to its Char representation. +relationToChar :: Relation -> Char +relationToChar r = case r of + Precedes -> 'p' + Meets -> 'm' + Overlaps -> 'o' + FinishedBy -> 'F' + Contains -> 'D' + Starts -> 's' + Equals -> 'e' + StartedBy -> 'S' + During -> 'd' + Finishes -> 'f' + OverlappedBy -> 'O' + MetBy -> 'M' + PrecededBy -> 'P' + +-- | A bit representation that acts as a set of possible relations between +-- intervals. +type RelationBits = Word16 + +-- | List of all possible relations. +allRelations :: [Relation] +allRelations = [minBound..] + +-- | Bit representation of all possible relations. +allRelationBits :: RelationBits +allRelationBits = relationUnion $ map toBits allRelations + +-- | Convert a Relation type to its bit representation. +toBits :: Relation -> RelationBits +toBits = bit . fromEnum + +-- | Convert a bit representation to a list of Relation types. +fromBits :: RelationBits -> [Relation] +fromBits bits = [x | x <- allRelations, bits .&. toBits x /= 0] + +-- | Calculate the union of a list of relations. +relationUnion :: [RelationBits] -> RelationBits +relationUnion = foldl' (.|.) 0 + +-- | Calculate the intersection of a list of relations. +relationIntersection :: [RelationBits] -> RelationBits +relationIntersection = foldl' (.&.) 0 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ViewPatterns #-} + +import Test.QuickCheck + +import Control.Monad (unless) + +import Data.Allen +import Data.Bits + +import qualified Data.Map as Map + +-- To Avoid orphaned instance warning +newtype ValidRelation = ValidRelation { toRelation :: Relation } +newtype ValidInterval = ValidInterval { toInterval :: Interval } + +instance Arbitrary ValidRelation where + arbitrary = do + index <- arbitrary + let n = fromEnum (maxBound :: Relation) + + return $ ValidRelation $ toEnum $ index `mod` n + +instance Arbitrary ValidInterval where + arbitrary = do + iD <- abs <$> arbitrary + return $ ValidInterval $ Interval iD Map.empty + +instance Show ValidRelation where + show = show . toRelation + +instance Show ValidInterval where + show = show . toInterval + +main :: IO () +main = do + putStrLn "Testing Relations...\n" + + test prop_relationBits + test prop_relationInverse + test prop_relationBitAmount + test prop_relationSet + test prop_relationTestSet + + putStrLn "\nTesting Intervals...\n" + + test prop_intervalAssume + testAllen prop_intervalAllBitsDefault + + putStrLn "\nTests from Allen (1983)...\n" + + testAllen prop_Section4Subsection2Part1 + testAllen prop_Section4Subsection2Part2 + testAllen prop_Section4Subsection2Part3 + + +-- Throw error on test failure so that +-- Spec.hs can properly recognize that a test has failed. +test :: Testable prop => prop -> IO () +test func = do + result <- quickCheckWithResult stdArgs func + unless (isSuccess result) $ error "Test Failed!" + +-- Similar to the `test` function but for Allen calculations +-- Upon failure: throws error and prints results of the calculation +testAllen :: Allen Bool -> IO () +testAllen calc = do + let (successful, result) = runAllen calc + if successful then + putStrLn "+++ OK, passed 1 test." + else do + putStrLn "--- [ Test Failed! ] ---" + putStrLn "Result: " + putStrLn "------------------------" + mapM_ (print . snd) $ Map.toList result + putStrLn "------------------------" + errorWithoutStackTrace "Test Failure." + +prop_relationBits :: ValidRelation -> Bool +prop_relationBits (toRelation -> r) = r == head (fromBits $ toBits r) + +prop_relationInverse :: ValidRelation -> Bool +prop_relationInverse (toRelation -> toBits -> r) = r == doubleConverse r + where doubleConverse = converse . converse + +prop_relationBitAmount :: Bool +prop_relationBitAmount = and $ zipWith (==) twos relations + where twos = map bit [0.. fromEnum (maxBound :: Relation)] + relations = map toBits allRelations + +prop_relationSet :: ValidInterval -> ValidRelation -> ValidRelation -> IntervalID -> Bool +prop_relationSet (toInterval -> i) (toRelation -> toBits -> r1) (toRelation -> toBits -> r2) iD = r == r2 + where i' = setRelation i r1 iD + i'' = setRelation i' r2 iD + r = intervalRelations i'' Map.! iD + +prop_relationTestSet :: [ValidRelation] -> Bool +prop_relationTestSet (map toRelation -> r) = evalAllen calc + where calc :: Allen Bool + calc = do + a <- interval + b <- interval + + assumeBits a allRelationBits b + testRelationSet r a b + +prop_intervalAssume :: ValidRelation -> Bool +prop_intervalAssume (toRelation -> r) = evalAllen calc + where calc :: Allen Bool + calc = do + a <- interval + b <- interval + + assume a r b + + r1 <- getConstraints a b + r2 <- getConstraints b a + + return $ r1 == converse r2 + +prop_intervalAllBitsDefault :: Allen Bool +prop_intervalAllBitsDefault = do + a <- interval + b <- interval + + c1 <- getConstraints a b + c2 <- getConstraints b a + + return (c1 == c2 && c1 == allRelationBits) + +-- +-- Examples from Section 4.2 of the Allen (1983) paper. +-- + +networkSection4Subsection2 :: Allen (IntervalID, IntervalID, IntervalID) +networkSection4Subsection2 = do + r <- interval + s <- interval + l <- interval + + assumeSet s [Precedes, Meets, MetBy, PrecededBy] r + assumeSet s [Overlaps, Meets] l + + return (r, s, l) + +-- First inference from Section 4.2 +prop_Section4Subsection2Part1 :: Allen Bool +prop_Section4Subsection2Part1 = do + -- Set up basic network. + -- s is discarded since it is not used + (r, _, l) <- networkSection4Subsection2 + + lrInferredBits <- getConstraints l r + -- expected [Precedes, PrecededBy, Overlaps, Meets, Contains, Starts, StartedBy, FinishedBy, Equals] + let lrExpectedBits = bitsFromString "pPomDsSFe" + + return (lrInferredBits == lrExpectedBits) + +-- Additional inference from Section 4.2. +-- Assumes part 1 inference works. +prop_Section4Subsection2Part2 :: Allen Bool +prop_Section4Subsection2Part2 = do + -- Set up same network as Part 1, but with added l->r relations. + (r, s, l) <- networkSection4Subsection2 + + assumeSet l [Overlaps, Starts, During] r + + lrInferredBits <- getConstraints l r + srInferredBits <- getConstraints s r + -- lrExpected [Overlaps, Starts] + -- srExpected [Precedes, Meets] + let lrExpectedBits = bitsFromString "os" + srExpectedBits = bitsFromString "pm" + + return (lrInferredBits == lrExpectedBits + && srInferredBits == srExpectedBits) + +-- Final inference from Section 4.2. +-- Assumes inferences from parts 1 and 2 works. +prop_Section4Subsection2Part3 :: Allen Bool +prop_Section4Subsection2Part3 = do + -- Set up same network as Part 2. + (r, s, l) <- networkSection4Subsection2 + + assumeSet l [Overlaps, Starts, During] r + + -- Add new interval D + -- w/ D -[During]-> S + d <- interval + let dsRelationBits = bitsFromString "d" + assumeBits d dsRelationBits s + + drInferredBits <- getConstraints d r + dlInferredBits <- getConstraints d l + -- drExpected [Precedes] + -- dlExpected [Precedes, Overlaps, Meets, During, Starts] + let drExpectedBits = bitsFromString "p" + dlExpectedBits = bitsFromString "pomds" + + return (drInferredBits == drExpectedBits + && dlInferredBits == dlExpectedBits) +