diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for interval-algebra +## 0.8.0 + +* Removes the `IntervalAlgebraic` typeclass. The functions that were in this class are now regular functions exported in the main module. +* Generalizes all interval predicate functions to work on (potentially) two different `Intervallic` containers. +* Cleans up and reorganizes documentation. + ## 0.7.1 * Adds `Safe` language extension to all library modules. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,28 +1,17 @@ # interval-algebra -The `interval-algebra` package implements [Allen's interval algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html) in [Haskell](https://www.haskell.org). The main module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). - -A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). +The `interval-algebra` package implements [Allen's interval algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html) in [Haskell](https://www.haskell.org). The main module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). ## Design -The module is built around four typeclasses designed to separate concerns of constructing, relating, and combining types that contain `Interval`s: +The module is built around three typeclasses designed to separate concerns of constructing, relating, and combining types that contain `Interval`s: 1. `Intervallic` provides an interface to the data structures which contain an `Interval`. -2. `IntervalAlgebraic` provides an interface to the `IntervalRelation`, the workhorse of Allen's temporal logic. -3. `IntervalCombinable` provides an interface to methods of combining two `Interval`s. -4. `IntervalSizeable` provides methods for measuring and modifying the size of an interval. +2. `IntervalCombinable` provides an interface to methods of combining two `Interval`s. +3. `IntervalSizeable` provides methods for measuring and modifying the size of an interval. An advantage of nested typeclass design is that developers can define an `Interval` of type `a` with just the amount of structure that they need. -## Total Ordering of `Interval`s - -The modules makes the (opinionated) choice of a total ordering for `Intervallic` `Interval`s. Namely, the ordering is based on first ordering the `begin`s then the `end`s. - ## Axiom tests The package [includes tests](test/IntervalAlgebraSpec.hs) that the functions of the `IntervalAlgebraic` typeclass meets the axioms for _intervals_ (not points) as laid out in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). - -## Development - -This module is under development and the API may change in the future. diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra -version: 0.7.1 +version: 0.8.0 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -4,40 +4,24 @@ Copyright : (c) NoviSci, Inc 2020 License : BSD3 Maintainer : bsaul@novisci.com -Stability : experimental The @IntervalAlgebra@ module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). - A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). = Design -The module is built around four typeclasses designed to separate concerns of +The module is built around three typeclasses designed to separate concerns of constructing, relating, and combining types that contain @'Interval'@s: 1. @'Intervallic'@ provides an interface to the data structures which contain an @'Interval'@. -2. @'IntervalAlgebraic'@ provides an interface to the @'IntervalRelation's@, - the workhorse of Allen's temporal logic. -3. @'IntervalCombinable'@ provides an interface to methods of combining two +2. @'IntervalCombinable'@ provides an interface to methods of combining two @'Interval's@. -4. @'IntervalSizeable'@ provides methods for measuring and modifying the size of +3. @'IntervalSizeable'@ provides methods for measuring and modifying the size of an interval. -An advantage of nested typeclass design is that developers can define an -@'Interval'@ of type @a@ with just the amount of structure that they need. - -== Total Ordering of @Interval@s - -The modules makes the (opinionated) choice of a total ordering for @'Intervallic'@ -@'Interval'@s. Namely, the ordering is based on first ordering the 'begin's -then the 'end's. - -= Development - -This module is under development and the API may change in the future. -} {-# LANGUAGE Safe #-} @@ -45,184 +29,252 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} --- {-# LANGUAGE MonoLocalBinds #-} module IntervalAlgebra( - -- * Classes - Intervallic(..) - , IntervalAlgebraic(..) - , IntervalCombinable(..) - , IntervalSizeable(..) + -- * Intervals + Interval + , Intervallic(..) - -- * Types - , Interval + -- ** Create new intervals , parseInterval - , IntervalRelation(..) - , ComparativePredicateOf + , beginerval + , enderval - -- * Functions for creating new intervals from existing + -- ** Modify intervals , expand , expandl , expandr - , beginerval - , enderval - , extenterval -) where -import Prelude (Eq, Ord, Show, Read, Enum(..), Bounded(..), Ordering (LT) - , Maybe(..), Either(..), String, Integer, Int, Bool(..), Num - , Foldable (maximum, minimum, foldMap, foldr) - , map, otherwise, flip, show, fst, snd, min, max, any, negate, not - , replicate, id, uncurry - , (++), (==), (&&), (<), (>), (<=), ($), (+), (-), (.), (!!)) -import Data.Monoid ( (<>), Monoid ) -import Data.Functor ( Functor(fmap) ) -import Data.Time as DT ( Day, addDays, diffDays, addGregorianYearsClip, calendarYear ) -import Data.Semigroup ( Semigroup((<>)) ) -import Data.Set(Set, fromList, difference, intersection, union, map, toList) -import Data.Ord( Ord(..), Ordering(..)) -import Control.Applicative (Applicative(pure)) + -- * Interval Algebra -{- | An @'Interval' a@ is a pair of @a@s \( (x, y) \text{ where } x < y\). The -@'parseInterval'@ function that returns @'Left'@ error if \(y < x\) and -@'Right' 'Interval'@ otherwise. --} -newtype Interval a = Interval (a, a) deriving (Eq) - --- | Safely parse a pair of @a@s to create an @'Interval' a@. -parseInterval :: (Show a, Ord a) => a -> a -> Either String (Interval a) -parseInterval x y - -- TODO: create more general framework for error handling - | y < x = Left $ show y ++ "<" ++ show x - | otherwise = Right $ Interval (x, y) + -- ** Interval Relations and Predicates + , IntervalRelation(..) -intervalBegin :: Interval a -> a -intervalBegin (Interval x) = fst x + {- | + === Meets, Metby -intervalEnd :: Interval a -> a -intervalEnd (Interval x) = snd x + > x `meets` y + > y `metBy` x -{- | -The @'Intervallic'@ typeclass defines how to get and set the 'Interval' content -of a data structure. It also includes functions for getting the @'begin'@ and -@'end'@ this data. --} -class (Ord a, Show a) => Intervallic i a where + @ + x: |-----| + y: |-----| + @ + -} + , meets , metBy - -- | Get the interval from an @i a@ - getInterval :: i a -> Interval a + {- | + === Before, After - -- | Set the interval in an @i a@ - setInterval :: i a -> Interval a -> i a + > x `before` y + > y `after` x - -- | Access the ends of an @i a@ . - begin, end :: i a -> a - begin = intervalBegin . getInterval - end = intervalEnd . getInterval + @ + x: |-----| + y: |-----| + @ + -} + , before , after -{- | + {- | + === Overlaps, OverlappedBy -The 'IntervalRelation' type enumerates the thirteen possible ways that two -@'Interval' a@ objects can relate according to the interval algebra. + > x `overlaps` y + > y `overlappedBy` x -=== Meets, Metby + @ + x: |-----| + y: |-----| + @ + -} + , overlaps , overlappedBy -> x `meets` y -> y `metBy` x + {- | + === Finishes, FinishedBy -@ -x: |-----| -y: |-----| -@ + > x `finishes` y + > y `finishedBy` x -=== Before, After + @ + x: |---| + y: |-----| + @ + -} + , finishedBy , finishes -> x `before` y -> y `after` x + {- | + === During, Contains -@ -x: |-----| -y: |-----| -@ + > x `during` y + > y `contains` x + @ + x: |-| + y: |-----| + @ + -} + , contains , during -=== Overlaps, OverlappedBy + {- | + === Starts, StartedBy -> x `overlaps` y -> y `overlappedBy` x + > x `starts` y + > y `startedBy` x -@ -x: |-----| -y: |-----| -@ + @ + x: |---| + y: |-----| + @ + -} + , starts , startedBy -=== Starts, StartedBy + {- | + === Equal -> x `starts` y -> y `startedBy` x + > x `equal` y + > y `equal` x -@ -x: |---| -y: |-----| -@ + @ + x: |-----| + y: |-----| + @ + -} + , equals -=== Finishes, FinishedBy + -- ** Additional predicates and utilities + , disjoint , notDisjoint, concur + , within, enclose, enclosedBy + , (<|>) + , unionPredicates + , ComparativePredicateOf1 + , ComparativePredicateOf2 -> x `finishes` y -> y `finishedBy` x + -- ** Algebraic operations + , intervalRelations + , relate + , compose + , complement + , union + , intersection + , converse -@ -x: |---| -y: |-----| -@ + -- * Combine two intervals + , IntervalCombinable(..) + , extenterval -=== During, Contains + -- * Measure an interval + , IntervalSizeable(..) -> x `during` y -> y `contains` x +) where -@ -x: |-| -y: |-----| -@ +import Prelude ( Eq, Show, Read, Enum(..), Bounded(..) + , Maybe(..), Either(..), String, Bool(..) + , Integer, Int, Num + , map, otherwise, show + , any, negate, not + , replicate + , (++), (==), (&&), (+), (-), (!!)) +import Data.Function ( ($), id, (.), flip ) +import Data.Functor ( Functor(fmap) ) +import Data.Ord ( Ord(..), Ordering(..), min, max ) +import Data.Semigroup ( Semigroup((<>)) ) +import qualified Data.Set ( Set + , fromList + , difference + , intersection + , union + , map + , toList ) +import Data.Tuple ( fst, snd ) +import Data.Time as DT ( Day + , addDays + , diffDays ) +import Control.Applicative ( Applicative(pure) ) -=== Equal +{- | An @'Interval' a@ is a pair \( (x, y) \text{ such that } x < y\). To create +intervals use the @'parseInterval'@, @'beginerval'@, or @'enderval'@ functions. +-} +newtype Interval a = Interval (a, a) deriving (Eq) -> x `equal` y -> y `equal` x +-- | Safely parse a pair of @a@s to create an @'Interval' a@. +-- +-- >>> parseInterval 0 1 +-- Right (0, 1) +-- +-- >>> parseInterval 1 0 +-- Left "0<1" +-- +parseInterval :: (Show a, Ord a) => a -> a -> Either String (Interval a) +parseInterval x y + -- TODO: create more general framework for error handling + | y < x = Left $ show y ++ "<" ++ show x + | otherwise = Right $ Interval (x, y) -@ -x: |-----| -y: |-----| -@ +intervalBegin :: Interval a -> a +intervalBegin (Interval x) = fst x +intervalEnd :: Interval a -> a +intervalEnd (Interval x) = snd x + +{- | +The @'Intervallic'@ typeclass defines how to get and set the 'Interval' content +of a data structure. It also includes functions for getting the endpoints of the +'Interval' via @'begin'@ and @'end'@. + +>>> getInterval (Interval (0, 10)) +(0, 10) + +>>> begin (Interval (0, 10)) +0 + +>>> end (Interval (0, 10)) +10 -} -data IntervalRelation a = - Meets - | MetBy - | Before - | After - | Overlaps - | OverlappedBy - | Starts - | StartedBy - | Finishes - | FinishedBy - | During - | Contains - | Equals +class (Ord a, Show a) => Intervallic i a where + + -- | Get the interval from an @i a@. + getInterval :: i a -> Interval a + + -- | Set the interval in an @i a@. + setInterval :: i a -> Interval a -> i a + + -- | Access the endpoints of an @i a@ . + begin, end :: i a -> a + begin = intervalBegin . getInterval + end = intervalEnd . getInterval + + +{- | +The 'IntervalRelation' type and the associated predicate functions enumerate +the thirteen possible ways that two @'Interval'@ objects may 'relate' according +to Allen's interval algebra. Constructors are shown with their corresponding +predicate function. +-} +data IntervalRelation = + Meets -- ^ `meets` + | MetBy -- ^ `metBy` + | Before -- ^ `before` + | After -- ^ `after` + | Overlaps -- ^ `overlaps` + | OverlappedBy -- ^ `overlappedBy` + | Starts -- ^ `starts` + | StartedBy -- ^ `startedBy` + | Finishes -- ^ `finishes` + | FinishedBy -- ^ `finishedBy` + | During -- ^ `during` + | Contains -- ^ `contains` + | Equals -- ^ `equals` deriving (Eq, Show, Read) -instance Bounded (IntervalRelation a) where +instance Bounded IntervalRelation where minBound = Before maxBound = After -instance Enum (IntervalRelation a) where +instance Enum IntervalRelation where fromEnum r = case r of Before -> 0 Meets -> 1 @@ -253,19 +305,143 @@ 11 -> MetBy 12 -> After -instance Ord (IntervalRelation a) where +instance Ord IntervalRelation where compare x y = compare (fromEnum x) (fromEnum y) --- | The 'Set' of all 'IntervalRelation's. -intervalRelations :: Set (IntervalRelation a) -intervalRelations = fromList (Prelude.map toEnum [0..12] ::[IntervalRelation a]) +-- | Does x `meets` y? Is x metBy y? +meets, metBy :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +meets x y = end x == begin y +metBy = flip meets +-- | Is x before y? Is x after y? +before, after :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +before x y = end x < begin y +after = flip before + +-- | Does x overlap y? Is x overlapped by y? +overlaps, overlappedBy :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +overlaps x y = begin x < begin y && end x < end y && end x > begin y +overlappedBy = flip overlaps + +-- | Does x start y? Is x started by y? +starts, startedBy, precedes, precededBy :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +starts x y = begin x == begin y && end x < end y +startedBy = flip starts +precedes = starts +precededBy = startedBy + +-- | Does x finish y? Is x finished by y? +finishes, finishedBy :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +finishes x y = begin x > begin y && end x == end y +finishedBy = flip finishes + +-- | Is x during y? Does x contain y? +during, contains :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +during x y = begin x > begin y && end x < end y +contains = flip during + +-- | Does x equal y? +equals :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +equals x y = begin x == begin y && end x == end y + +-- | Operator for composing the union of two predicates +(<|>) :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) + -> ComparativePredicateOf2 (i0 a) (i1 a) + -> ComparativePredicateOf2 (i0 a) (i1 a) +(<|>) f g = unionPredicates [f, g] + +disjointRelations :: Data.Set.Set IntervalRelation +disjointRelations = toSet [Before, After, Meets, MetBy] + +withinRelations :: Data.Set.Set IntervalRelation +withinRelations = toSet [Starts, During, Finishes, Equals] + +-- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')? +disjoint :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +disjoint = predicate disjointRelations + +-- | Are x and y not disjoint (concur); i.e. do they share any support? This is +-- the 'complement' of 'disjoint'. +notDisjoint, concur :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +notDisjoint = predicate (complement disjointRelations) +concur = notDisjoint + +-- | Is x entirely *within* (enclosed by) the endpoints of y? That is, 'during', +-- 'starts', 'finishes', or 'equals'? +within, enclosedBy:: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +within = predicate withinRelations +enclosedBy = within + +-- | Does x enclose y? That is, is y 'within' x? +enclose :: (Intervallic i0 a, Intervallic i1 a)=> + ComparativePredicateOf2 (i0 a) (i1 a) +enclose = flip enclosedBy + +-- | The 'Data.Set.Set' of all 'IntervalRelation's. +intervalRelations :: Data.Set.Set IntervalRelation +intervalRelations = Data.Set.fromList (Prelude.map toEnum [0..12] ::[IntervalRelation]) + -- | Find the converse of a single 'IntervalRelation' -converseRelation :: IntervalRelation a -> IntervalRelation a +converseRelation :: IntervalRelation -> IntervalRelation converseRelation x = toEnum (12 - fromEnum x) +-- | Shortcut to creating a 'Set IntervalRelation' from a list. +toSet :: [IntervalRelation ] -> Data.Set.Set IntervalRelation +toSet = Data.Set.fromList + +-- | Compose a list of interval relations with _or_ to create a new +-- @'ComparativePredicateOf1' i a@. For example, +-- @unionPredicates [before, meets]@ creates a predicate function determining +-- if one interval is either before or meets another interval. +unionPredicates :: [ComparativePredicateOf2 a b] -> ComparativePredicateOf2 a b +unionPredicates fs x y = any (\ f -> f x y) fs + +-- | Maps an 'IntervalRelation' to its corresponding predicate function. +toPredicate :: (Intervallic i0 a, Intervallic i1 a) => + IntervalRelation + -> ComparativePredicateOf2 (i0 a) (i1 a) +toPredicate r = + case r of + Before -> before + Meets -> meets + Overlaps -> overlaps + FinishedBy -> finishedBy + Contains -> contains + Starts -> starts + Equals -> equals + StartedBy -> startedBy + During -> during + Finishes -> finishes + OverlappedBy -> overlappedBy + MetBy -> metBy + After -> after + +-- | Given a set of 'IntervalRelation's return a list of 'predicate' functions +-- corresponding to each relation. +predicates :: (Intervallic i0 a, Intervallic i1 a)=> + Data.Set.Set IntervalRelation + -> [ComparativePredicateOf2 (i0 a) (i1 a)] +predicates x = Prelude.map toPredicate (Data.Set.toList x) + +-- | Forms a predicate function from the union of a set of 'IntervalRelation's. +predicate :: (Intervallic i0 a, Intervallic i1 a)=> + Data.Set.Set IntervalRelation + -> ComparativePredicateOf2 (i0 a) (i1 a) +predicate = unionPredicates.predicates + -- | The lookup table for the compositions of interval relations. -composeRelationLookup :: [[[IntervalRelation a]]] +composeRelationLookup :: [[[IntervalRelation]]] composeRelationLookup = [ [p , p , p , p , p , p , p , p , pmosd, pmosd, pmosd, pmosd, full ] , [p , p , p , p , p , m , m , m , osd , osd , osd , fef , dsomp] @@ -308,187 +484,58 @@ pmosd = p ++ m ++ osd cncr = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o' full = p ++ m ++ cncr ++ m' ++ p' -{- -Misc --} --- | Defines a predicate of two objects of type @a@. -type ComparativePredicateOf a = (a -> a -> Bool) - - -{- | -The @'IntervalAlgebraic'@ typeclass specifies the functions and relational -operators for interval-based temporal logic. The typeclass defines the -relational operators for types that contain an @'Interval a'@, plus other useful - utilities such as @'disjoint'@, @'within'@, and @'unionPredicates'@. --} -class (Eq (i a), Intervallic i a) => IntervalAlgebraic i a where - - -- | Compare two @i a@ to determine their 'IntervalRelation'. - relate :: i a -> i a -> IntervalRelation (i a) - relate x y - | x `before` y = Before - | x `after` y = After - | x `meets` y = Meets - | x `metBy` y = MetBy - | x `overlaps` y = Overlaps - | x `overlappedBy` y = OverlappedBy - | x `starts` y = Starts - | x `startedBy` y = StartedBy - | x `finishes` y = Finishes - | x `finishedBy` y = FinishedBy - | x `during` y = During - | x `contains` y = Contains - | otherwise = Equals - - -- | Maps an 'IntervalRelation' to its corresponding predicate function. - predicate' :: IntervalRelation (i a) -> ComparativePredicateOf (i a) - predicate' r = - case r of - Before -> before - Meets -> meets - Overlaps -> overlaps - FinishedBy -> finishedBy - Contains -> contains - Starts -> starts - Equals -> equals - StartedBy -> startedBy - During -> during - Finishes -> finishes - OverlappedBy -> overlappedBy - MetBy -> metBy - After -> after - - -- | Given a set of 'IntervalRelation's return a list of 'predicate' functions - -- corresponding to each relation. - predicates :: Set (IntervalRelation (i a)) -> [ComparativePredicateOf (i a)] - predicates x = Prelude.map predicate' (toList x) - - -- | Forms a predicate function from the union of a set of 'IntervalRelation's. - predicate :: Set (IntervalRelation (i a)) -> ComparativePredicateOf (i a) - predicate = unionPredicates.predicates - - -- ** Algebraic operations on IntervalRelations - - -- | Shortcut to creating a 'Set IntervalRelation' from a list. - toSet :: [IntervalRelation (i a)] -> Set (IntervalRelation (i a)) - toSet = fromList - - -- | Compose two interval relations according to the rules of the algebra. - -- The rules are enumerated according to . - compose :: IntervalRelation (i a) - -> IntervalRelation (i a) - -> Set (IntervalRelation (i a)) - compose x y = toSet ((composeRelationLookup !! fromEnum x) !! fromEnum y) - - -- | Finds the complement of a 'Set IntervalRelation'. - complement :: Set (IntervalRelation (i a)) -> Set (IntervalRelation (i a)) - complement = difference intervalRelations - - -- | Find the intersection of two 'Set's of 'IntervalRelation's. - intersection :: Set (IntervalRelation (i a)) - -> Set (IntervalRelation (i a)) - -> Set (IntervalRelation (i a)) - intersection = Data.Set.intersection - - -- | Find the union of two 'Set's of 'IntervalRelation's. - union :: Set (IntervalRelation (i a)) - -> Set (IntervalRelation (i a)) - -> Set (IntervalRelation (i a)) - union = Data.Set.union - - -- | Find the converse of a 'Set IntervalRelation'. - converse :: Set (IntervalRelation (i a)) - -> Set (IntervalRelation (i a)) - converse = Data.Set.map converseRelation - - -- ** Interval algebra predicates - - -- | Does x equal y? - equals :: ComparativePredicateOf (i a) - equals x y = begin x == begin y && end x == end y - - -- | Does x meet y? Is y metBy x? - meets, metBy :: ComparativePredicateOf (i a) - meets x y = end x == begin y - metBy = flip meets - - -- | Is x before y? Is x after y? - before, after :: ComparativePredicateOf (i a) - before x y = end x < begin y - after = flip before - - -- | Does x overlap y? Is x overlapped by y? - overlaps, overlappedBy :: ComparativePredicateOf (i a) - overlaps x y = begin x < begin y && end x < end y && end x > begin y - overlappedBy = flip overlaps - - -- | Does x start y? Is x started by y? - starts, startedBy :: ComparativePredicateOf (i a) - starts x y = begin x == begin y && (end x < end y) - startedBy = flip starts - - -- | Synonyms for 'starts' and 'startedBy' - precedes, precededBy :: ComparativePredicateOf (i a) - precedes = starts - precededBy = startedBy - - -- | Does x finish y? Is x finished by y? - finishes, finishedBy :: ComparativePredicateOf (i a) - finishes x y = begin x > begin y && end x == end y - finishedBy = flip finishes - - -- | Is x during y? Does x contain y? - during, contains :: ComparativePredicateOf (i a) - during x y = begin x > begin y && end x < end y - contains = flip during - - -- ** Interval Algebra utilities - - -- | Compose a list of interval relations with _or_ to create a new - -- @'ComparativePredicateOf' i a@. For example, - -- @unionPredicates [before, meets]@ creates a predicate function determining - -- if one interval is either before or meets another interval. - unionPredicates :: [ComparativePredicateOf (i a)] -> - ComparativePredicateOf (i a) - unionPredicates fs x y = any (\ f -> f x y) fs - - -- | Operator for composing the union of two predicates - (<|>) :: ComparativePredicateOf (i a) - -> ComparativePredicateOf (i a) - -> ComparativePredicateOf (i a) - (<|>) f g = unionPredicates [f, g] - - disjointRelations :: Set (IntervalRelation (i a)) - disjointRelations = toSet [Before, After, Meets, MetBy] - - withinRelations :: Set (IntervalRelation (i a)) - withinRelations = toSet [Starts, During, Finishes, Equals] - - -- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')? - disjoint :: ComparativePredicateOf (i a) - disjoint = predicate disjointRelations +-- | Compare two @i a@ to determine their 'IntervalRelation'. +-- +-- >>> relate (Interval (0::Int, 1)) (Interval (1, 2)) +-- Meets +-- +-- >>> relate (Interval (1::Int, 2)) (Interval (0, 1)) +-- MetBy +-- +relate :: (Intervallic i0 a, Intervallic i1 a) => i0 a -> i1 a -> IntervalRelation +relate x y + | x `before` y = Before + | x `after` y = After + | x `meets` y = Meets + | x `metBy` y = MetBy + | x `overlaps` y = Overlaps + | x `overlappedBy` y = OverlappedBy + | x `starts` y = Starts + | x `startedBy` y = StartedBy + | x `finishes` y = Finishes + | x `finishedBy` y = FinishedBy + | x `during` y = During + | x `contains` y = Contains + | otherwise = Equals - -- | Are x and y not disjoint; i.e. do they share any support? - notDisjoint :: ComparativePredicateOf (i a) - notDisjoint = predicate (complement disjointRelations) +-- | Compose two interval relations according to the rules of the algebra. +-- The rules are enumerated according to . +compose :: IntervalRelation + -> IntervalRelation + -> Data.Set.Set IntervalRelation +compose x y = toSet (composeRelationLookup !! fromEnum x !! fromEnum y) - -- | A synonym for 'notDisjoint'. - concur :: ComparativePredicateOf (i a) - concur = notDisjoint +-- | Finds the complement of a @'Data.Set.Set' 'IntervalRelation'@. +complement :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation +complement = Data.Set.difference intervalRelations - -- | Is x entirely *within* the endpoints of y? That is, 'during', - -- 'starts', 'finishes', or 'equals'? - within :: ComparativePredicateOf (i a) - within = predicate withinRelations +-- | Find the intersection of two 'Data.Set.Set's of 'IntervalRelation's. +intersection :: Data.Set.Set IntervalRelation + -> Data.Set.Set IntervalRelation + -> Data.Set.Set IntervalRelation +intersection = Data.Set.intersection - -- | Does x enclose y? That is, is y 'within' x? - enclose :: ComparativePredicateOf (i a) - enclose = flip enclosedBy +-- | Find the union of two 'Data.Set.Set's of 'IntervalRelation's. +union :: Data.Set.Set IntervalRelation + -> Data.Set.Set IntervalRelation + -> Data.Set.Set IntervalRelation +union = Data.Set.union - -- | Synonym for 'within'. - enclosedBy :: ComparativePredicateOf (i a) - enclosedBy = within +-- | Find the converse of a @'Data.Set.Set' 'IntervalRelation'@. +converse :: Data.Set.Set IntervalRelation + -> Data.Set.Set IntervalRelation +converse = Data.Set.map converseRelation {- | The 'IntervalSizeable' typeclass provides functions to determine the size of an @@ -515,49 +562,97 @@ -- | Takes the difference between two @a@ to return a @b@. diff :: a -> a -> b --- | Resize an 'i a' to by expanding to "left" by @l@ and to the +-- | Resize an @i a@ to by expanding to "left" by @l@ and to the -- "right" by @r@. In the case that @l@ or @r@ are less than a 'moment' -- the respective endpoints are unchanged. -expand :: (IntervalSizeable a b, Intervallic i a) => b -> b -> i a -> i a +-- +-- >>> expand 0 0 (Interval (0::Int, 2::Int)) +-- (0, 2) +-- +-- >>> expand 1 1 (Interval (0::Int, 2::Int)) +-- (-1, 3) +-- +expand :: (IntervalSizeable a b, Intervallic i a) => + b -- ^ duration to subtract from the 'begin' + -> b -- ^ duration to add to the 'end' + -> i a + -> i a expand l r p = setInterval p i where s = if l < moment' p then 0 else negate l e = if r < moment' p then 0 else r i = Interval (add s $ begin p, add e $ end p) --- | Expands an 'i a' to left by i. +-- | Expands an @i a@ to "left". +-- +-- >>> expandl 2 (Interval (0::Int, 2::Int)) +-- (-2, 2) +-- expandl :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a expandl i = expand i 0 --- | Expands an 'i a' to right by i. +-- | Expands an @i a@ to "right". +-- +-- >>> expandr 2 (Interval (0::Int, 2::Int)) +-- (0, 4) +-- expandr :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a expandr = expand 0 -- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding --- @max moment dur@ to @x@ as the 'end'. -beginerval :: (IntervalSizeable a b) => b -> a -> Interval a +-- @max 'moment' dur@ to @x@ as the 'end'. +-- +-- >>> beginerval (0::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (1::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (2::Int) (0::Int) +-- (0, 2) +-- +beginerval :: (IntervalSizeable a b) => + b -- ^ @dur@ation to add to the 'begin' + -> a -- ^ the 'begin' point of the 'Interval' + -> Interval a beginerval dur x = Interval (x, y) where i = Interval (x, x) d = max (moment' i) dur y = add d x -- | Safely creates an 'Interval a' using @x@ as the 'end' and adding --- @negate max moment dur@ to @x@ as the 'begin'. -enderval :: (IntervalSizeable a b) => b -> a -> Interval a +-- @negate max 'moment' dur@ to @x@ as the 'begin'. +-- +-- >>> enderval (0::Int) (0::Int) +-- (-1, 0) +-- +-- >>> enderval (1::Int) (0::Int) +-- (-1, 0) +-- +-- >>> enderval (2::Int) (0::Int) +-- (-2, 0) +-- +enderval :: (IntervalSizeable a b) => + b -- ^ @dur@ation to subtract from the 'end' + -> a -- ^ the 'end' point of the 'Interval' + -> Interval a enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x) where i = Interval (x, x) -- | Creates a new @Interval@ spanning the extent x and y. -extenterval :: IntervalAlgebraic i a => i a -> i a -> Interval a +-- +-- >>> extenterval (Interval (0, 1)) (Interval (9, 10)) +-- (0, 10) +-- +extenterval :: Intervallic i a => i a -> i a -> Interval a extenterval x y = Interval (s, e) where s = min (begin x) (begin y) e = max (end x) (end y) - {- | The @'IntervalCombinable'@ typeclass provides methods for (possibly) combining two @i a@s to form an @'Interval'@. -} -class (IntervalAlgebraic i a) => IntervalCombinable i a where +class (Intervallic i a) => IntervalCombinable i a where -- | Maybe form a new @i a@ by the union of two @i a@s that 'meets'. (.+.) :: i a -> i a -> Maybe (i a) @@ -571,7 +666,7 @@ -- interval in the "gap" between @x@ and @y@ from the 'end' of @x@ to the -- 'begin' of @y@. Otherwise, 'Nothing'. (><) :: i a -> i a -> Maybe (i a) - + -- | If @x@ is 'before' @y@, return @f x@ appended to @f y@. Otherwise, -- return 'extenterval' of @x@ and @y@ (wrapped in @f@). This is useful for -- (left) folding over an *ordered* container of @Interval@s and combining @@ -581,7 +676,16 @@ -> i a -> f (i a) +{- +Misc +-} +-- | Defines a predicate of two objects of type @a@. +type ComparativePredicateOf1 a = (a -> a -> Bool) + +-- | Defines a predicate of two object of different types. +type ComparativePredicateOf2 a b = (a -> b -> Bool) + -- {- -- Instances -- -} @@ -607,8 +711,6 @@ instance (Ord a, Show a) => Intervallic Interval a where getInterval = id setInterval _ x = x - -instance (Eq a, Ord a, Show a) => IntervalAlgebraic Interval a instance (Ord a, Show a) => IntervalCombinable Interval a where (><) x y diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -16,27 +16,27 @@ {-# LANGUAGE MonoLocalBinds #-} module IntervalAlgebra.IntervalUtilities ( - relations - , relations' - , intersect - , combineIntervals + + -- * Fold over sequential intervals + combineIntervals , combineIntervals' , gaps , gaps' - , durations - , clip , gapsWithin + + -- * Operations on Meeting sequences of paired intervals + , foldMeetingSafe + , formMeetingSequence + + -- * Withering functions + + -- ** Clear containers based on predicate , nothingIf , nothingIfNone , nothingIfAny , nothingIfAll - -- * Operations on Meeting sequences of intervals - , foldMeetingSafe - , formMeetingSequence - - -- * Filtering functions - , compareIntervals + -- ** Filter containers based on predicate , filterBefore , filterMeets , filterOverlaps @@ -57,6 +57,12 @@ , filterEnclose , filterEnclosedBy + -- * Misc utilities + , relations + , relations' + , intersect + , clip + , durations ) where import Prelude ( (<*>), seq) @@ -78,21 +84,43 @@ import Data.Tuple ( fst ) import Safe ( headMay, lastMay, initSafe, tailSafe) import Witherable ( Filterable(filter) ) -import IntervalAlgebra ( Interval - , Intervallic(..) - , IntervalAlgebraic(..) - , IntervalCombinable(..) - , IntervalSizeable(..) - , IntervalRelation(..) - , ComparativePredicateOf - , beginerval - , enderval - , extenterval ) +import IntervalAlgebra ( (<|>), + after, + before, + beginerval, + concur, + contains, + disjoint, + during, + enclose, + enclosedBy, + enderval, + equals, + extenterval, + finishedBy, + finishes, + meets, + metBy, + notDisjoint, + overlappedBy, + overlaps, + relate, + startedBy, + starts, + within, + ComparativePredicateOf1, + ComparativePredicateOf2, + Interval, + IntervalCombinable((<+>), (><)), + IntervalRelation(Meets), + IntervalSizeable(diff, duration), + Intervallic(..) ) import IntervalAlgebra.PairedInterval ( PairedInterval - , mkPairedInterval + , makePairedInterval , getPairData , equalPairData ) + ------------------------------------------------- -- Unexported utilties used in functions below -- ------------------------------------------------- @@ -101,6 +129,7 @@ iv :: Int -> Int -> Interval Int iv = beginerval +-- TODO: does this function and applyAccume reinvent an existing foldable function? -- Fold over consecutive pairs of foldable structure and collect the results in -- a monoidal structure. foldlAccume :: (Foldable f, Applicative m, Monoid (m a))=> @@ -141,9 +170,9 @@ -- -- >>> relations [iv 1 0, iv 1 1] -- [Meets] -relations :: (IntervalAlgebraic i a, Foldable f)=> +relations :: (Foldable f, Intervallic i a )=> f (i a) - -> [IntervalRelation (i a)] + -> [IntervalRelation] relations = relations' -- | A generic form of 'relations' which can output any 'Applicative' and @@ -151,17 +180,20 @@ -- >>> (relations' [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)] -- [Meets] -- -relations' :: ( IntervalAlgebraic i a - , Foldable f +relations' :: ( Foldable f , Applicative m - , Monoid (m (IntervalRelation (i a))) )=> + , Intervallic i a + , Monoid (m IntervalRelation ))=> f (i a) - -> m (IntervalRelation (i a)) + -> m IntervalRelation relations' = foldlAccume relate -- | Forms a 'Just' new interval from the intersection of two intervals, -- provided the intervals are not disjoint. -intersect :: (IntervalSizeable a b, IntervalAlgebraic i a) => +-- +-- >>> intersect (iv 5 0) (iv 2 3) +-- Just (3, 5) +intersect :: (Intervallic i a, IntervalSizeable a b) => i a -> i a -> Maybe (Interval a) intersect x y | disjoint x y = Nothing @@ -211,7 +243,7 @@ -- -- >>> clip (iv 3 0) (iv 2 4) -- Nothing -clip :: (IntervalAlgebraic Interval a, IntervalSizeable a b)=> +clip :: (IntervalSizeable a b)=> Interval a -> Interval a -> Maybe (Interval a) @@ -231,14 +263,12 @@ -- -- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] -- Just [(5, 7),(9, 10)] --- gapsWithin :: ( Applicative f , Foldable f , Monoid (f (Interval a)) , IntervalSizeable a b , IntervalCombinable Interval a - , Filterable f - , IntervalAlgebraic Interval a)=> + , Filterable f)=> Interval a -- ^ i -> f (Interval a) -- ^ x -> Maybe (f (Interval a)) @@ -266,8 +296,8 @@ -- -- >>> combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] -combineIntervals :: ( IntervalAlgebraic Interval a - , Applicative f +combineIntervals :: ( Applicative f + , Intervallic Interval a , Monoid (f (Interval a)) , Foldable f ) => f (Interval a) -> @@ -280,8 +310,7 @@ -- -- >>> combineIntervals' [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] -combineIntervals' :: (IntervalAlgebraic Interval a) => - [Interval a] -> [Interval a] +combineIntervals' :: (Intervallic Interval a)=> [Interval a] -> [Interval a] combineIntervals' l = unBox $ foldl' (<>) (Box []) (packBoxes l) -- Internal function for combining maybe intervals in the 'combineIntervals'' @@ -295,12 +324,10 @@ (<->) (Just x) Nothing = [x] (<->) (Just x) (Just y) = (<+>) x y - - -- | Given a predicate combinator, a predicate, and list of intervals, returns -- the input unchanged if the predicate combinator is @True@. Otherwise, returns -- an empty list. See 'nothingIfAny' and 'nothingIfNone' for examples. -nothingIf :: (Monoid (f (i a)), Filterable f, IntervalAlgebraic i a)=> +nothingIf :: (Monoid (f (i a)), Filterable f)=> ((i a -> Bool) -> f (i a) -> Bool) -- ^ e.g. 'any' or 'all' -> (i a -> Bool) -- ^ predicate to apply to each element of input list -> f (i a) @@ -321,209 +348,82 @@ -- >>> nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5] -- Just [(3, 6),(5, 6)] -- -nothingIfNone :: (Monoid (f (i a)), Foldable f, Filterable f, IntervalAlgebraic i a)=> +nothingIfNone :: (Monoid (f (i a)), Foldable f, Filterable f)=> (i a -> Bool) -- ^ predicate to apply to each element of input list -> f (i a) -> Maybe (f (i a)) nothingIfNone = nothingIf (\f x -> (not.any f) x) -- | Returns 'Nothing' if *any* of the element of input satisfy the predicate condition. -nothingIfAny :: (Monoid (f (i a)), Foldable f, Filterable f, IntervalAlgebraic i a)=> +-- +-- >>> nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] +-- Just [(3, 6),(5, 6)] +-- +-- >>> nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] +-- Nothing +nothingIfAny :: (Monoid (f (i a)), Foldable f, Filterable f)=> (i a -> Bool) -- ^ predicate to apply to each element of input list -> f (i a) -> Maybe (f (i a)) nothingIfAny = nothingIf any --- | Returns 'Nothing' if *all* of the element of input satisfy the predicate condition -nothingIfAll :: (Monoid (f (i a)), Foldable f, Filterable f, IntervalAlgebraic i a)=> +-- | Returns 'Nothing' if *all* of the element of input satisfy the predicate condition. +-- >>> nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] +-- Nothing +nothingIfAll :: (Monoid (f (i a)), Foldable f, Filterable f)=> (i a -> Bool) -- ^ predicate to apply to each element of input list -> f (i a) -> Maybe (f (i a)) nothingIfAll = nothingIf all -{- | -Filter functions provides means for filtering 'Filterable' containers of -@'Intervallic i a'@s based on @'IntervalAlgebraic'@ relations. --} - --- | Lifts a predicate to be able to compare two different 'IntervalAlgebraic' --- structure by comparing the intervals contain within each. -compareIntervals :: (IntervalAlgebraic i0 a, IntervalAlgebraic i1 a) => - ComparativePredicateOf (Interval a) - -> i0 a - -> i1 a - -> Bool -compareIntervals pf x y = pf (getInterval x) (getInterval y) - -- | Creates a function for filtering a 'Witherable.Filterable' of @i1 a@s -- by comparing the @Interval a@s that of an @i0 a@. -filterMaker :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - ComparativePredicateOf (Interval a) +makeFilter :: ( Filterable f + , Intervallic i0 a + , Intervallic i1 a) => + ComparativePredicateOf2 (i0 a) (i1 a) -> i0 a -> (f (i1 a) -> f (i1 a)) -filterMaker f p = Witherable.filter (compareIntervals f p) - --- | Filter by 'overlaps'. -filterOverlaps :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterOverlaps = filterMaker overlaps - --- | Filter by 'overlappedBy'. -filterOverlappedBy :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterOverlappedBy = filterMaker overlappedBy - --- | Filter by 'before'. -filterBefore :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterBefore = filterMaker before - --- | Filter by 'after'. -filterAfter :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterAfter = filterMaker after - --- | Filter by 'starts'. -filterStarts :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterStarts = filterMaker starts - --- | Filter by 'startedBy'. -filterStartedBy :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterStartedBy = filterMaker startedBy - --- | Filter by 'finishes'. -filterFinishes :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterFinishes = filterMaker finishes - --- | Filter by'finishedBy'. -filterFinishedBy :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterFinishedBy = filterMaker finishedBy - --- | Filter by 'meets'. -filterMeets :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterMeets = filterMaker meets - --- | Filter by 'metBy'. -filterMetBy :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterMetBy = filterMaker metBy - --- | Filter by 'during'. -filterDuring :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterDuring = filterMaker during - --- | Filter by 'contains'. -filterContains :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterContains = filterMaker contains - --- | Filter by 'equals'. -filterEquals :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterEquals = filterMaker equals - --- | Filter by 'disjoint'. -filterDisjoint :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterDisjoint = filterMaker disjoint - --- | Filter by 'notDisjoint'. -filterNotDisjoint :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterNotDisjoint = filterMaker notDisjoint - --- | Filter by 'concur'. -filterConcur :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterConcur = filterMaker concur - --- | Filter by 'within'. -filterWithin :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterWithin = filterMaker within - --- | Filter by 'enclose'. -filterEnclose :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterEnclose = filterMaker enclose +makeFilter f p = Witherable.filter (f p) --- | Filter by 'enclosedBy'. -filterEnclosedBy :: (Filterable f - , IntervalAlgebraic Interval a - , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) -filterEnclosedBy = filterMaker enclosedBy +{- | +Filter 'Filterable' containers of one @'Intervallic'@ type based by comparing to +a (potentially different) 'Intervallic' type using the corresponding interval +predicate function. +-} +filterOverlaps, filterOverlappedBy, filterBefore, filterAfter, + filterStarts, filterStartedBy, filterFinishes, filterFinishedBy, + filterMeets, filterMetBy, filterDuring, filterContains, filterEquals, + filterDisjoint, filterNotDisjoint, filterConcur, filterWithin, + filterEnclose, filterEnclosedBy :: + ( Filterable f , Intervallic i0 a, Intervallic i1 a) => + i0 a -> f (i1 a) -> f (i1 a) +filterOverlaps = makeFilter overlaps +filterOverlappedBy = makeFilter overlappedBy +filterBefore = makeFilter before +filterAfter = makeFilter after +filterStarts = makeFilter starts +filterStartedBy = makeFilter startedBy +filterFinishes = makeFilter finishes +filterFinishedBy = makeFilter finishedBy +filterMeets = makeFilter meets +filterMetBy = makeFilter metBy +filterDuring = makeFilter during +filterContains = makeFilter contains +filterEquals = makeFilter equals +filterDisjoint = makeFilter disjoint +filterNotDisjoint = makeFilter notDisjoint +filterConcur = makeFilter concur +filterWithin = makeFilter within +filterEnclose = makeFilter enclose +filterEnclosedBy = makeFilter enclosedBy -- | Folds over a list of Paired Intervals and in the case that the 'getPairData' -- is equal between two sequential meeting intervals, these two intervals are -- combined into one. This function is "safe" in the sense that if the input is -- invalid and contains any sequential pairs of intervals with an @IntervalRelation@, -- other than 'Meets', then the function returns an empty list. -foldMeetingSafe :: ( IntervalAlgebraic (PairedInterval b) a, Eq b) => +foldMeetingSafe :: (Intervallic (PairedInterval b) a, Eq b) => [ PairedInterval b a ] -- ^ Be sure this only contains intervals -- that sequentially 'meets'. -> [ PairedInterval b a ] @@ -532,7 +432,7 @@ -- | Folds over a list of Meeting Paired Intervals and in the case that the 'getPairData' -- is equal between two sequential meeting intervals, these two intervals are -- combined into one. -foldMeeting :: ( IntervalAlgebraic (PairedInterval b) a, Eq b) => +foldMeeting :: (Eq b, Ord a, Show a) => Meeting [PairedInterval b a ] -> Meeting [PairedInterval b a ] foldMeeting (Meeting l) = foldl' joinMeetingPairedInterval (Meeting []) (packMeeting l) @@ -546,7 +446,7 @@ packMeeting = Data.List.map (\z -> Meeting [z]) -- Test a list of intervals to be sure they all meet; if not return Nothing. -parseMeeting :: (IntervalAlgebraic i a)=> [i a] -> Maybe (Meeting [i a]) +parseMeeting :: Intervallic i a => [i a] -> Maybe (Meeting [i a]) parseMeeting x | all ( == Meets ) (relations x) = Just $ Meeting x | otherwise = Nothing @@ -559,8 +459,8 @@ joinMeetingPairedInterval = joinMeeting equalPairData -- A general function for combining any two @Meeting [i a]@ by 'listCombiner'. -joinMeeting :: (IntervalAlgebraic i a) => - ComparativePredicateOf (i a) +joinMeeting :: Intervallic i a => + ComparativePredicateOf1 (i a) -> Meeting [ i a ] -> Meeting [ i a ] -> Meeting [ i a ] @@ -568,8 +468,8 @@ -- The intervals @x@ and @y@ should meet! The predicate function @p@ determines -- when the two intervals that meet should be combined. -join2MeetingWhen :: (IntervalAlgebraic i a) => - ComparativePredicateOf (i a) +join2MeetingWhen :: Intervallic i a => + ComparativePredicateOf1 (i a) -> Maybe (i a) -> Maybe (i a) -> [i a] @@ -589,7 +489,6 @@ -} disjoinPaired :: ( Eq b , Monoid b - , IntervalAlgebraic (PairedInterval b) a , IntervalSizeable a c) => (PairedInterval b) a -> (PairedInterval b) a @@ -613,7 +512,7 @@ b2 = begin y e1 = end x e2 = end y - ev = flip mkPairedInterval + ev = flip makePairedInterval evp = \b e s -> ev (beginerval (diff e b) b) s {- | @@ -624,16 +523,16 @@ compared to input events. The second of the pair are disjoint events that still need to be compared to be input events. -} -mtEvt :: ( Monoid b, Eq b, IntervalSizeable a c) => +recurseDisjoin :: ( Monoid b, Eq b, IntervalSizeable a c) => ([(PairedInterval b) a ], [(PairedInterval b) a ]) -> [(PairedInterval b) a ] -> [(PairedInterval b) a ] -mtEvt (acc, o:os) [] = acc ++ o:os -- the "final" pattern -mtEvt (acc, []) [] = acc -- another "final" pattern -mtEvt (acc, []) (e:es) = mtEvt (acc, [e]) es -- the "initialize" pattern -mtEvt (acc, o:os) (e:es) -- the "operating" patterns +recurseDisjoin (acc, o:os) [] = acc ++ o:os -- the "final" pattern +recurseDisjoin (acc, []) [] = acc -- another "final" pattern +recurseDisjoin (acc, []) (e:es) = recurseDisjoin (acc, [e]) es -- the "initialize" pattern +recurseDisjoin (acc, o:os) (e:es) -- the "operating" patterns -- If input event is equal to the first comparator, skip the comparison. - | e == o = mtEvt (acc, o:os) es + | e == o = recurseDisjoin (acc, o:os) es {- If the period of o is either before or meets the period of e, then the first of the combined events can be put into the accumulator. @@ -641,10 +540,10 @@ is before or meets e, then we are assured that all periods up to the beginning of o are fully disjoint and subsequent input events will not overlap these in any way. -} - | (before <|> meets) o e = mtEvt (acc ++ nh, mtEvt ([], nt) os ) es + | (before <|> meets) o e = recurseDisjoin (acc ++ nh, recurseDisjoin ([], nt) os ) es --The standard recursive operation. - | otherwise = mtEvt (acc, mtEvt ([], n) os ) es + | otherwise = recurseDisjoin (acc, recurseDisjoin ([], n) os ) es where n = getMeeting $ disjoinPaired o e nh = maybeToList (headMay n) nt = tailSafe n @@ -662,8 +561,8 @@ , IntervalSizeable a c) => [ PairedInterval b a ] -> [ PairedInterval b a ] -formMeetingSequence x = mtEvt ([], []) (mtEvt ([], []) x) - -- the second pass of mtEvt is to handle the situation where the first pass +formMeetingSequence x = recurseDisjoin ([], []) (recurseDisjoin ([], []) x) + -- the second pass of recurseDisjoin is to handle the situation where the first pass -- disjoins all the events correctly into a meeting sequence but -- due to -- nesting of intervals in the input -- some of the sequential pairs have -- the same data after the first pass. The second pass merges any sequential diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -15,20 +15,19 @@ module IntervalAlgebra.PairedInterval ( PairedInterval , Empty - , mkPairedInterval + , makePairedInterval , getPairData , intervals , equalPairData , toTrivialPair , trivialize - -- , makePairPredicate ) where import IntervalAlgebra ( Interval , Intervallic(..) - , IntervalAlgebraic(..) + , before , IntervalCombinable(..) - , ComparativePredicateOf + , ComparativePredicateOf1 , extenterval ) import Witherable ( Filterable(filter) ) import Data.Bifunctor ( Bifunctor(bimap) ) @@ -50,31 +49,29 @@ (<=) x y = getInterval x <= getInterval y (<) x y = getInterval x < getInterval y -instance (Eq b, Show a, Ord a) => IntervalAlgebraic (PairedInterval b) a - instance (Show b, Show a, Ord a) => Show (PairedInterval b a) where show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}" instance (Ord a, Show a, Eq b, Monoid b) => IntervalCombinable (PairedInterval b) a where - (><) x y = fmap (mkPairedInterval mempty) (getInterval x >< getInterval y) + (><) x y = fmap (makePairedInterval mempty) (getInterval x >< getInterval y) (<+>) x y | x `before` y = pure x <> pure y - | otherwise = pure $ mkPairedInterval (getPairData x <> getPairData y) + | otherwise = pure $ makePairedInterval (getPairData x <> getPairData y) (extenterval x y) -- | Make a paired interval. -mkPairedInterval :: b -> Interval a -> PairedInterval b a -mkPairedInterval d i = PairedInterval (i, d) +makePairedInterval :: b -> Interval a -> PairedInterval b a +makePairedInterval d i = PairedInterval (i, d) -- | Gets the data (i.e. non-interval) part of a @PairedInterval@. getPairData :: PairedInterval b a -> b getPairData (PairedInterval (_, y)) = y -- | Tests for equality of the data in a @PairedInterval@. -equalPairData :: (Eq b) => ComparativePredicateOf (PairedInterval b a) +equalPairData :: (Eq b) => ComparativePredicateOf1 (PairedInterval b a) equalPairData x y = getPairData x == getPairData y -- | Gets the intervals from a list of paired intervals. @@ -92,20 +89,9 @@ -- | Lifts an @Interval a@ into a @PairedInterval Empty a@, where @Empty@ is a -- trivial type that contains no data. toTrivialPair :: Interval a -> PairedInterval Empty a -toTrivialPair = mkPairedInterval Empty +toTrivialPair = makePairedInterval Empty -- | Lifts a @Functor@ containing @Interval a@(s) into a @Functor@ containing -- @PairedInterval Empty a@(s). trivialize :: Functor f => f (Interval a) -> f (PairedInterval Empty a) trivialize = fmap toTrivialPair - --- | Takes a predicate of intervals and a predicate on the data part of a --- paired interval to create a single predicate such that both input --- predicates should hold. --- makePairPredicate :: (IntervalAlgebraic (PairedInterval b) a) => --- ComparativePredicateOf (Interval a) --- -> ComparativePredicateOf b --- -> ComparativePredicateOf (PairedInterval b a) --- makePairPredicate intervalPredicate dataPredicate x y = --- compareIntervals intervalPredicate x y && --- dataPredicate (getPairData x) (getPairData y) diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -18,9 +18,10 @@ import IntervalAlgebra ( Interval , Intervallic(..) , IntervalCombinable(..) - , IntervalAlgebraic(..) , IntervalRelation (..) - , beginerval, IntervalSizeable ) + , beginerval + , IntervalSizeable + , starts ) import IntervalAlgebra.IntervalUtilities ( gaps , durations , intersect @@ -34,7 +35,7 @@ , foldMeetingSafe , formMeetingSequence ) import IntervalAlgebra.PairedInterval ( trivialize - , mkPairedInterval + , makePairedInterval , PairedInterval, getPairData ) import Control.Monad ( liftM2 ) import Data.Foldable @@ -55,14 +56,14 @@ arbitrary = State <$> suchThat (listOf arbitrary) (\x -> length x == 3) instance Arbitrary (PairedInterval State Int) where - arbitrary = liftM2 mkPairedInterval arbitrary arbitrary + arbitrary = liftM2 makePairedInterval arbitrary arbitrary instance Arbitrary (Events Int) where arbitrary = Events <$> orderedList -- Testing functions -checkSeqStates :: (IntervalAlgebraic i Int)=> [i Int] -> Bool +checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool checkSeqStates x = (length x > 1) || all (== Meets) (relations x) -- Creation functions @@ -70,7 +71,7 @@ iv = beginerval evpi :: Int -> Int -> [Bool] -> StateEvent Int -evpi i j s = mkPairedInterval (State s) (beginerval i j) +evpi i j s = makePairedInterval (State s) (beginerval i j) -- Test cases containmentInt :: Interval Int @@ -92,14 +93,14 @@ meets2 = [iv 2 0, iv 2 2, iv 10 4, iv 2 14] meets3 :: [PairedInterval Int Int] -meets3 = map (uncurry mkPairedInterval) [ +meets3 = map (uncurry makePairedInterval) [ (5, iv 2 0) , (5, iv 2 2) , (9, iv 10 4) , (10, iv 2 14)] meets3eq :: [PairedInterval Int Int] -meets3eq = map (uncurry mkPairedInterval) [ +meets3eq = map (uncurry makePairedInterval) [ (5, iv 4 0) , (9, iv 10 4) , (10, iv 2 14)] @@ -159,7 +160,7 @@ -- Properties -- Check that the only relation remaining after applying a function is Before -prop_before:: (IntervalAlgebraic Interval a, IntervalCombinable Interval a)=> +prop_before:: (Intervallic Interval a, IntervalCombinable Interval a)=> ([Interval a] -> [Interval a]) -> [Interval a] -> Property @@ -171,7 +172,7 @@ -> Property prop_combineIntervals1 = prop_before combineIntervals -prop_gaps1:: (IntervalAlgebraic Interval a, IntervalCombinable Interval a)=> +prop_gaps1:: (Intervallic Interval a, IntervalCombinable Interval a)=> [Interval a] -> Property prop_gaps1 = prop_before gaps diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -1,15 +1,16 @@ module IntervalAlgebra.PairedIntervalSpec (spec) where import Test.Hspec ( it, describe, Spec, shouldBe ) -import IntervalAlgebra.PairedInterval ( PairedInterval, mkPairedInterval ) +import IntervalAlgebra.PairedInterval ( PairedInterval, makePairedInterval ) import IntervalAlgebra ( beginerval , IntervalSizeable(duration) - , IntervalAlgebraic(equals, before) ) + , equals + , before ) type TestPair = PairedInterval String Int mkTestPr :: String -> Int -> Int -> TestPair -mkTestPr x i j = mkPairedInterval x (beginerval i j) +mkTestPr x i j = makePairedInterval x (beginerval i j) t1 :: TestPair t1 = mkTestPr "hi" 5 0 diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -23,17 +23,27 @@ , expandl , expand , parseInterval + , before + , meets + , overlaps + , finishedBy + , contains + , starts + , equals + , startedBy + , during + , finishes + , overlappedBy + , metBy + , after + , relate + , compose + , disjoint + , (<|>) , IntervalCombinable((.+.)) , IntervalSizeable(moment, diff) - , IntervalAlgebraic( equals, starts - , finishes, finishedBy - , overlaps, during - , contains, compose - , relate, startedBy - , overlappedBy, disjoint - , before, after, meets - , metBy, (<|>)) - , ComparativePredicateOf + , ComparativePredicateOf1 + , ComparativePredicateOf2 , Intervallic(begin, end) , Interval ) @@ -93,7 +103,7 @@ \forall i,j,k,l s.t. (i:j & i:k & l:j) \implies l:k \] -} -prop_IAaxiomM1 :: (IntervalAlgebraic Interval a) => M1set a -> Property +prop_IAaxiomM1 :: (Intervallic Interval a) => M1set a -> Property prop_IAaxiomM1 x = (i `meets` j && i `meets` k && l `meets` j) ==> (l `meets` k) where i = m11 x @@ -157,7 +167,7 @@ \] -} -prop_IAaxiomM2 :: (IntervalAlgebraic Interval a, IntervalSizeable a b) => M2set a -> Property +prop_IAaxiomM2 :: (Intervallic Interval a, IntervalSizeable a b) => M2set a -> Property prop_IAaxiomM2 x = (i `meets` j && k `meets` l) ==> (i `meets` l) `xor` @@ -187,7 +197,7 @@ \] -} -prop_IAaxiomML1 :: (IntervalAlgebraic Interval a) => Interval a -> Property +prop_IAaxiomML1 :: (Intervallic Interval a) => Interval a -> Property prop_IAaxiomML1 x = not (x `meets` x) === True prop_IAaxiomML1_Int :: Interval Int -> Property @@ -207,7 +217,7 @@ \] -} -prop_IAaxiomML2 :: (IntervalAlgebraic Interval a)=> M2set a -> Property +prop_IAaxiomML2 :: (Intervallic Interval a)=> M2set a -> Property prop_IAaxiomML2 x = (i `meets` j) ==> not (j `meets` i) where i = m21 x @@ -230,7 +240,7 @@ \] -} -prop_IAaxiomM3 :: (IntervalAlgebraic Interval a, IntervalSizeable a b)=> +prop_IAaxiomM3 :: (Intervallic Interval a, IntervalSizeable a b)=> b -> Interval a -> Property prop_IAaxiomM3 b i = (j `meets` i && i `meets` k) === True @@ -254,7 +264,7 @@ \] -} -prop_IAaxiomM4 :: (IntervalAlgebraic Interval a, IntervalSizeable a b)=> +prop_IAaxiomM4 :: (Intervallic Interval a, IntervalSizeable a b)=> b -> M2set a -> Property prop_IAaxiomM4 b x = ((m `meets` i && i `meets` j && j `meets` n) && @@ -309,7 +319,7 @@ ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i -prop_IAaxiomM5 :: (IntervalAlgebraic Interval a, IntervalSizeable a b) => +prop_IAaxiomM5 :: (Intervallic Interval a, IntervalSizeable a b) => M5set a -> Property prop_IAaxiomM5 x = ((i `meets` j && j `meets` l) && @@ -358,7 +368,7 @@ * Interval Relation property testing -} -class ( IntervalAlgebraic Interval a +class ( Intervallic Interval a , IntervalCombinable Interval a , IntervalSizeable a b ) => IntervalRelationProperties a b where @@ -403,7 +413,7 @@ instance IntervalRelationProperties Int Int -allIArelations:: IntervalAlgebraic Interval a => [ComparativePredicateOf (Interval a)] +allIArelations:: Intervallic Interval a => [ComparativePredicateOf1 (Interval a)] allIArelations = [ IA.equals , IA.meets , IA.metBy @@ -418,14 +428,14 @@ , IA.during , IA.contains ] -prop_expandl_end ::(IntervalAlgebraic Interval a, IntervalSizeable a b)=> +prop_expandl_end ::(Intervallic Interval a, IntervalSizeable a b)=> b -> Interval a -> Property prop_expandl_end d i = end (expandl d i) === end i -prop_expandr_begin ::(IntervalAlgebraic Interval a, IntervalSizeable a b)=> +prop_expandr_begin ::(Intervallic Interval a, IntervalSizeable a b)=> b -> Interval a -> Property @@ -433,7 +443,7 @@ -- | The relation between x and z should be an element of the set of the -- composed relations between x y and between y z. -prop_compose :: IntervalAlgebraic Interval a => +prop_compose :: Intervallic Interval a => Interval a -> Interval a -> Interval a @@ -474,7 +484,7 @@ it "enderval -2 10 should be Interval (9, 10)" $ Right (enderval (-2::Int) 10) `shouldBe` parseInterval (9::Int) (10::Int) - describe "IntervalAlgebraic tests" $ + describe "Intervallic tests" $ modifyMaxSuccess (*10000) $ do it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True" $