allen (empty) → 0.1.0.0
raw patch · 12 files changed
+1294/−0 lines, 12 filesdep +QuickCheckdep +aesondep +allensetup-changed
Dependencies added: QuickCheck, aeson, allen, base, bytestring, containers, criterion, mtl, text, vector
Files
- CHANGELOG.md +11/−0
- LICENSE +30/−0
- README.md +71/−0
- Setup.hs +2/−0
- allen.cabal +96/−0
- app/Main.hs +221/−0
- bench/Bench.hs +25/−0
- src/Data/Allen.hs +131/−0
- src/Data/Allen/Interval.hs +211/−0
- src/Data/Allen/Relation.hs +141/−0
- src/Data/Allen/Types.hs +154/−0
- test/Spec.hs +201/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ allen.cabal view
@@ -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 <https://github.com/archaversine/allen#readme>+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
+ app/Main.hs view
@@ -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 <name> Create a new interval with the given name"+ putStrLn " assume <a> <rel> <b> Assume that a and b have the given relation"+ putStrLn " (Use: pmoFDseSdfoMP to represent relations)"+ putStrLn " constraints <a> <b> 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."+
+ bench/Bench.hs view
@@ -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
+ src/Data/Allen.hs view
@@ -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
+ src/Data/Allen/Interval.hs view
@@ -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+
+ src/Data/Allen/Relation.hs view
@@ -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 <https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html>.+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 <https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html>.+compose :: RelationBits -> RelationBits -> RelationBits+compose r1 r2 = relationUnion [composeSingle a b | a <- fromBits r1, b <- fromBits r2]
+ src/Data/Allen/Types.hs view
@@ -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+
+ test/Spec.hs view
@@ -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)+