diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,29 @@ # Changelog for interval-algebra +## 2.2.0 + +* Redesigns the core typeclasses: + * Decouples the interval algebra functionality from that of defining and + manipulating intervals as pairs of points. + * New `Iv` class to implement the relation algebra from Allen 1983, over any + abstract interval type `iv`. + * `PointedIv` class for intervals that can be cast to the canonical `Interval`. + * `SizedIv` class for intervals that can be manipulated, providing stronger tools + to create intervals that are consistent with the interval algebra when more + structure is available. In effect replaces the `b` in the old + `IntervalSizeable b a` with an associated `Moment` type of `SizedIv`. +* Reimplements various interval constructors, such as `safeInterval`, to use + the new typeclass methods while maintaining the previous implementation's + behavior. +* Removes the `Safe` pragma. +* Removes `witch`, `witherable` and `safe` package dependencies. +* Cleans up the `IntervalAlgebra.IntervalUtilities` module, removing many + esoteric functions and tidying the type signatures and implementations of the + remaining ones. +* Fixes a bug in the `gaps` utility. +* Fixes the `Arbitrary` for constructing valid intervals, which was made easier + by the switch from `IntervalSizeable` to the redesigned `SizedIv`. + ## 2.1.3 * Removes the version constraints on the `witch` package. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright NoviSci, Inc (c) 2020 +Copyright NoviSci, Inc (c) 2020-2022 +Copyright Target RWE (c) 2023 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,72 @@ # 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://en.wikipedia.org/wiki/Allen%27s_interval_algebra) in +[Haskell](https://www.haskell.org), for a canonical representation of intervals +as a pair of points representing a begin and an end. 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 provides an `Interval` type wrapping the most basic type of interval +needed for the relation algebra defined in the papers cited above. `Interval a` +wraps `(a, a)`, giving the interval's `begin` and `end` points. -The module is built around three typeclasses designed to separate concerns of constructing, relating, and combining types that contain `Interval`s: +However, the module provides typeclasses to generalize an `Interval` and the +interval algebra for temporal logic: -1. `Intervallic` provides an interface to the data structures which contain 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. +1. `Iv` provides an abstract interface for defining the 13 relations of the + interval algebra. Instances are provided for the canonical `Interval a`, + when `a` is an instance of `Ord`, as described in Allen 1983. However, + the interval algebra can be used for temporal logic on "intervals" that + are qualitative and not represented as pairs of points in an ordered set, + as provided in examples of that paper. +2. `PointedIv` is an interface for types that, in effect, be cast to the + canonical `Interval`. +3. `SizedIv` provides a generic interface for creating and + manipulating `PointedIv` intervals. In particular, when the interval type also + is an instance of `Iv`, it specifies class properties to ensure + intervals created or altered via its methods are valid for the purpose using the interval + algebra. +1. `Intervallic` provides an interface for data structures which contain an + `Interval`, allowing the relation algebra to be performed relative to the + `Interval` within. The `PairedInterval` defined here is the prototypical + case. -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. +The module defines instances of the classes above for `Interval a`, and only +provides `SizedIv (Interval a)` instances for a few common `a`. See class +documentation for examples of other possible use-cases. It also defines a +variety of ways to construct valid `Interval a` values for supported point +types `a`. +The loose naming convention is: "Bare" names such as `starts` or `contains` are +generalized over `Intervallic` and their `Iv*` class counterparts start with +`iv`, for example `ivStarts` and `ivContains`. + ## 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). +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). + +## Comparisons + +`interval-algebra` differs from `data-interval` mainly in that it is more +general and has as its starting point the relation algebra from Allen 1983. The +latter package provides an interval type that is tied to the notion of an +interval as a connected convex subset of the integer or real lines, +differentiating for example between closed and open endpoints. It provides +a `Relation` type codifying the 13 temporal relations from Allen 1983. + +For use-cases where that structure is meaningful, `data-interval` might be a +more natural choice. `interval-algebra` might be used instead when more +abstract concepts are needed or there is no need for the notion of +connectedness between the starting and ending points. + +An important difference is that `data-interval` supports empty +intervals. `interval-algebra` does not, since Allen's interval relations cannot +be defined for such intervals. diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,18 +1,16 @@ cabal-version: 2.2 name: interval-algebra -version: 2.1.3 +version: 2.2.0 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time homepage: https://github.com/novisci/interval-algebra#readme bug-reports: https://github.com/novisci/interval-algebra/issues -author: Bradley Saul - Brendan Brown -maintainer: bsaul@novisci.com, 2020-2022 - bbrown@targetrwe.com, 2023 +author: Bradley Saul, Brendan Brown +maintainer: 2020-2022, 2023 -copyright: (c) NoviSci, 2020-2022 - Target RWE, 2023 +copyright: (c) NoviSci 2020-2022, + Target RWE 2023 license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -48,11 +46,8 @@ , foldl ^>= 1.4 , prettyprinter ^>= 1.7 , QuickCheck ^>= 2.14 - , safe ^>= 0.3 , text ^>= 1.2 || ^>= 2.0 , time >= 1.9 && < 2 - , witch - , witherable ^>= 0.4 default-language: Haskell2010 test-suite axioms @@ -65,7 +60,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , hspec + , hspec < 2.12 , interval-algebra , QuickCheck , time @@ -81,7 +76,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , hspec + , hspec < 2.12 , interval-algebra , QuickCheck , time @@ -103,12 +98,10 @@ build-depends: base >=4.7 && <5 , containers - , hspec + , hspec < 2.12 , interval-algebra , QuickCheck - , safe , time - , witherable build-tool-depends: hspec-discover:hspec-discover >= 2.9.2 default-language: Haskell2010 @@ -122,5 +115,4 @@ , interval-algebra , prettyprinter ^>= 1.7 , time >= 1.9 && < 2 - , witch default-language: Haskell2010 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -1,9 +1,11 @@ {-| Module : Interval Algebra Description : Implementation of Allen's interval algebra -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022 + bbrown@targetrwe.com 2023 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) @@ -16,14 +18,13 @@ -} -{-# LANGUAGE Safe #-} module IntervalAlgebra ( module IntervalAlgebra.Core , module IntervalAlgebra.IntervalUtilities , module IntervalAlgebra.PairedInterval ) where -import safe IntervalAlgebra.Core -import safe IntervalAlgebra.IntervalDiagram -import safe IntervalAlgebra.IntervalUtilities -import safe IntervalAlgebra.PairedInterval +import IntervalAlgebra.Core +import IntervalAlgebra.IntervalDiagram +import IntervalAlgebra.IntervalUtilities +import IntervalAlgebra.PairedInterval diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -1,22 +1,21 @@ {-| Module : Generate arbitrary Intervals Description : Functions for generating arbitrary intervals -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 Stability : experimental -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -module IntervalAlgebra.Arbitrary - ( arbitraryWithRelation - ) where +module IntervalAlgebra.Arbitrary where import Control.Applicative (liftA2, (<$>)) import Control.Monad (liftM2) @@ -37,11 +36,10 @@ import GHC.Num import GHC.Real import IntervalAlgebra (Interval, IntervalRelation (..), - IntervalSizeable, Intervallic, - PairedInterval, beginerval, converse, + Intervallic, PairedInterval, Point, + SizedIv (..), beginerval, converse, duration, makePairedInterval, moment, predicate, strictWithinRelations) -import Prelude (Eq, (==)) import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, NonNegative, arbitrarySizedNatural, elements, resize, sized, suchThat) @@ -55,21 +53,56 @@ maxDiffTime :: Int maxDiffTime = 86399 -instance Arbitrary DT.Day where - arbitrary = sized (\s -> DT.ModifiedJulianDay <$> s `resize` arbitrary) - shrink = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay +--instance Arbitrary DT.DiffTime where +-- arbitrary = sized +-- +-- +--instance Arbitrary DT.UTCTime where +-- arbitrary = liftA2 UTCTime arbitrary arbitrary -instance Arbitrary DT.NominalDiffTime where - arbitrary = sized - (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural)) +-- Helper +-- NOTE: You likely want to restrict the size of `dur` in a more appropriate +-- way, to be uniform over the range >= moment. +sizedIntervalGen :: (SizedIv (Interval a), Ord (Moment (Interval a))) => Int -> Gen a -> Gen (Moment (Interval a)) -> Gen (Interval a) +sizedIntervalGen s gpt gmom = do + b <- s `resize` gpt + dur <- s `resize` gmom + pure $ beginerval dur b -instance Arbitrary DT.DiffTime where - arbitrary = sized - (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural)) +-- Generators for types that do not implement Arbitrary. This avoids creating +-- orphan instances for these types. -instance Arbitrary DT.UTCTime where - arbitrary = liftA2 UTCTime arbitrary arbitrary +genDay :: Gen DT.Day +genDay = sized (\s -> DT.ModifiedJulianDay <$> s `resize` arbitrary) +genNominalDiffTime :: Gen DT.NominalDiffTime +genNominalDiffTime = sized (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural)) + +genDiffTime :: Gen DT.DiffTime +genDiffTime = sized (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural)) + +genUTCTime :: Gen DT.UTCTime +genUTCTime = sized (\s -> liftA2 UTCTime genDay genDiffTime) + +-- Arbitrary instances +-- for SizedIv instances defined in Core + +instance Arbitrary (Interval Int) where + arbitrary = sized (\s -> sizedIntervalGen s arbitrary arbitrary) + +instance Arbitrary (Interval Integer) where + arbitrary = sized (\s -> sizedIntervalGen s arbitrary arbitrary) + +instance Arbitrary (Interval Double) where + arbitrary = sized (\s -> sizedIntervalGen s arbitrary arbitrary) + +instance Arbitrary (Interval DT.Day) where + arbitrary = sized (\s -> sizedIntervalGen s genDay arbitrary) + +instance Arbitrary (Interval DT.UTCTime) where + arbitrary = sized (\s -> sizedIntervalGen s genUTCTime genNominalDiffTime) + + -- | Conditional generation of intervals relative to a reference. If the -- reference @iv@ is of 'moment' duration, it is not possible to generate -- intervals from the strict enclose relations StartedBy, Contains, FinishedBy. @@ -91,10 +124,10 @@ -- arbitraryWithRelation :: forall i a b - . (IntervalSizeable a b, Intervallic i, Arbitrary (i a)) - => i a -- ^ reference interval + . (SizedIv (Interval a), Ord a, Eq (Moment (Interval a)), Arbitrary (Interval a)) + => Interval a -- ^ reference interval -> Data.Set.Set IntervalRelation -- ^ set of `IntervalRelation`s, of which at least one will hold for the generated interval relative to the reference - -> Gen (Maybe (i a)) + -> Gen (Maybe (Interval a)) arbitraryWithRelation iv rs | rs == Data.Set.singleton Equals = elements [Just iv] | isEnclose && isMom = elements [Nothing] @@ -103,4 +136,4 @@ where notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations) isEnclose = Data.Set.null notStrictEnclose - isMom = duration iv == moment @a + isMom = duration iv == moment @(Interval a) diff --git a/src/IntervalAlgebra/Axioms.hs b/src/IntervalAlgebra/Axioms.hs --- a/src/IntervalAlgebra/Axioms.hs +++ b/src/IntervalAlgebra/Axioms.hs @@ -2,39 +2,43 @@ {-| Module : Interval Algebra Axioms Description : Properties of Intervals -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 -This module exports a single typeclass @IntervalAxioms@ which contains -property-based tests for the axioms in section 1 of [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). -The notation below is that of the original paper. +This module exports utilities for property-based tests for the axioms in +section 1 of [Allen and Hayes +(1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). The notation +below is that of the original paper. This module is useful if creating a new instance of interval types that you want to test. -} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -module IntervalAlgebra.Axioms - ( IntervalAxioms(..) - , M1set(..) - , M2set(..) - , M5set(..) - ) where +module IntervalAlgebra.Axioms where -import Data.Either (isRight) -import Data.Maybe (fromJust, isJust, isNothing) -import Data.Set (Set, disjointUnion, fromList, - member) -import Data.Time as DT (Day (..), DiffTime, - NominalDiffTime, UTCTime (..)) +import Data.Either (isRight) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Set (Set, disjointUnion, + fromList, member) +import Data.Time as DT (Day (..), DiffTime, + NominalDiffTime, + UTCTime (..)) import IntervalAlgebra.Arbitrary import IntervalAlgebra.Core -import Test.QuickCheck (Arbitrary (arbitrary), Property, - (===), (==>)) +import IntervalAlgebra.IntervalUtilities ((.+.)) +import Test.QuickCheck (Arbitrary (arbitrary), + Property, (===), (==>)) xor :: Bool -> Bool -> Bool @@ -47,13 +51,14 @@ | otherwise = x -- | A set used for testing M1 defined so that the M1 condition is true. -data M1set a = M1set - { m11 :: Interval a - , m12 :: Interval a - , m13 :: Interval a - , m14 :: Interval a - } - deriving Show +data M1set a + = M1set + { m11 :: Interval a + , m12 :: Interval a + , m13 :: Interval a + , m14 :: Interval a + } + deriving (Show) instance Arbitrary (M1set Int) where arbitrary = do @@ -72,19 +77,20 @@ instance Arbitrary (M1set DT.UTCTime) where arbitrary = do x <- arbitrary - a <- arbitrary - b <- arbitrary - m1set x a b <$> arbitrary + a <- genNominalDiffTime + b <- genNominalDiffTime + m1set x a b <$> genNominalDiffTime -- | A set used for testing M2 defined so that the M2 condition is true. -data M2set a = M2set - { m21 :: Interval a - , m22 :: Interval a - , m23 :: Interval a - , m24 :: Interval a - } - deriving Show +data M2set a + = M2set + { m21 :: Interval a + , m22 :: Interval a + , m23 :: Interval a + , m24 :: Interval a + } + deriving (Show) instance Arbitrary (M2set Int) where arbitrary = do @@ -104,15 +110,16 @@ arbitrary = do x <- arbitrary a <- arbitrary - b <- arbitrary - m2set x a b <$> arbitrary + b <- genNominalDiffTime + m2set x a b <$> genNominalDiffTime -- | A set used for testing M5. -data M5set a = M5set - { m51 :: Interval a - , m52 :: Interval a - } - deriving Show +data M5set a + = M5set + { m51 :: Interval a + , m52 :: Interval a + } + deriving (Show) instance Arbitrary (M5set Int) where arbitrary = do @@ -129,212 +136,206 @@ instance Arbitrary (M5set DT.UTCTime) where arbitrary = do x <- arbitrary - a <- arbitrary - m5set x a <$> arbitrary + a <- genNominalDiffTime + m5set x a <$> genNominalDiffTime --- | = "An Axiomatization of Interval Time". -class ( IntervalSizeable a b ) => IntervalAxioms a b where +-- Axiom functions - -- | Smart constructor of 'M1set'. - m1set :: (IntervalSizeable a b) => Interval a -> b -> b -> b -> M1set a - m1set x a b c = M1set p1 p2 p3 p4 - where p1 = x -- interval i in prop_IAaxiomM1 - p2 = beginerval a (end x) -- interval j in prop_IAaxiomM1 - p3 = beginerval b (end x) -- interval k in prop_IAaxiomM1 - p4 = enderval (makePos c) (begin p2) +-- | Smart constructor of 'M1set'. +m1set :: (SizedIv (Interval a), b ~ Moment (Interval a), Ord b, Num b) => Interval a -> b -> b -> b -> M1set a +m1set x a b c = M1set p1 p2 p3 p4 + where p1 = x -- interval i in prop_IAaxiomM1 + p2 = beginerval a (end x) -- interval j in prop_IAaxiomM1 + p3 = beginerval b (end x) -- interval k in prop_IAaxiomM1 + p4 = enderval (makePos c) (begin p2) - {- | - == Axiom M1 +{- | - The first axiom of Allen and Hayes (1987) states that if "two periods both - meet a third, thn any period met by one must also be met by the other." - That is: +== Axiom M1 - \[ - \forall \text{ i,j,k,l } s.t. (i:j \text{ & } i:k \text{ & } l:j) \implies l:k - \] - -} - prop_IAaxiomM1 :: (Ord a) => M1set a -> Property - prop_IAaxiomM1 x = - (i `meets` j && i `meets` k && l `meets` j) ==> (l `meets` k) - where i = m11 x - j = m12 x - k = m13 x - l = m14 x +The first axiom of Allen and Hayes (1987) states that if "two periods both +meet a third, thn any period met by one must also be met by the other." +That is: - -- | Smart constructor of 'M2set'. - m2set :: (IntervalSizeable a b)=> Interval a -> Interval a -> b -> b -> M2set a - m2set x y a b = M2set p1 p2 p3 p4 - where p1 = x -- interval i in prop_IAaxiomM2 - p2 = beginerval a (end x) -- interval j in prop_IAaxiomM2 - p3 = y -- interval k in prop_IAaxiomM2 - p4 = beginerval b (end y) -- interval l in prop_IAaxiomM2 +\[ + \forall \text{ i,j,k,l } s.t. (i:j \text{ & } i:k \text{ & } l:j) \implies l:k +\] +-} +prop_IAaxiomM1 :: (Iv (Interval a), SizedIv (Interval a)) => M1set a -> Property +prop_IAaxiomM1 x = + (i `meets` j && i `meets` k && l `meets` j) ==> (l `meets` k) + where i = m11 x + j = m12 x + k = m13 x + l = m14 x - {- | +-- | Smart constructor of 'M2set'. +m2set :: (SizedIv (Interval a)) => Interval a -> Interval a -> Moment (Interval a) -> Moment (Interval a) -> M2set a +m2set x y a b = M2set p1 p2 p3 p4 + where p1 = x -- interval i in prop_IAaxiomM2 + p2 = beginerval a (end x) -- interval j in prop_IAaxiomM2 + p3 = y -- interval k in prop_IAaxiomM2 + p4 = beginerval b (end y) -- interval l in prop_IAaxiomM2 - == Axiom M2 +{- | - If period i meets period j and period k meets l, - then exactly one of the following holds: +== Axiom M2 - 1) i meets l; - 2) there is an m such that i meets m and m meets l; - 3) there is an n such that k meets n and n meets j. +If period i meets period j and period k meets l, +then exactly one of the following holds: - That is, + 1) i meets l; + 2) there is an m such that i meets m and m meets l; + 3) there is an n such that k meets n and n meets j. - \[ - \forall i,j,k,l s.t. (i:j \text { & } k:l) \implies - i:l \oplus - (\exists m s.t. i:m:l) \oplus - (\exists m s.t. k:m:j) - \] +That is, - -} +\[ + \forall i,j,k,l s.t. (i:j \text { & } k:l) \implies + i:l \oplus + (\exists m s.t. i:m:l) \oplus + (\exists m s.t. k:m:j) +\] - prop_IAaxiomM2 :: (IntervalSizeable a b, Show a) => - M2set a -> Property - prop_IAaxiomM2 x = - (i `meets` j && k `meets` l) ==> - (i `meets` l) `xor` - isRight m `xor` - isRight n - where i = m21 x - j = m22 x - k = m23 x - l = m24 x - m = parseInterval (end i) (begin l) - n = parseInterval (end k) (begin j) +-} - {- | +prop_IAaxiomM2 :: (SizedIv (Interval a), Show a, Ord a) => + M2set a -> Property +prop_IAaxiomM2 x = + (i `meets` j && k `meets` l) ==> + (i `meets` l) `xor` + isRight m `xor` + isRight n + where i = m21 x + j = m22 x + k = m23 x + l = m24 x + m = parseInterval (end i) (begin l) + n = parseInterval (end k) (begin j) - == Axiom ML1 +{- | - An interval cannot meet itself. +== Axiom ML1 - \[ - \forall i \lnot i:i - \] - -} +An interval cannot meet itself. - prop_IAaxiomML1 :: (Ord a) => Interval a -> Property - prop_IAaxiomML1 x = not (x `meets` x) === True +\[ + \forall i \lnot i:i +\] +-} - {- | +prop_IAaxiomML1 :: (Iv (Interval a), SizedIv (Interval a)) => Interval a -> Property +prop_IAaxiomML1 x = not (x `meets` x) === True - == Axiom ML2 +{- | - If i meets j then j does not meet i. +== Axiom ML2 - \[ - \forall i,j i:j \implies \lnot j:i - \] - -} +If i meets j then j does not meet i. - prop_IAaxiomML2 :: (Ord a)=> M2set a -> Property - prop_IAaxiomML2 x = - (i `meets` j) ==> not (j `meets` i) - where i = m21 x - j = m22 x +\[ +\forall i,j i:j \implies \lnot j:i +\] +-} - {- | +prop_IAaxiomML2 :: (Iv (Interval a), SizedIv (Interval a))=> M2set a -> Property +prop_IAaxiomML2 x = + (i `meets` j) ==> not (j `meets` i) + where i = m21 x + j = m22 x - == Axiom M3 +{- | - Time does not start or stop: +== Axiom M3 - \[ - \forall i \exists j,k s.t. j:i:k - \] - -} +Time does not start or stop: - prop_IAaxiomM3 :: (IntervalSizeable a b)=> - b -> Interval a -> Property - prop_IAaxiomM3 b i = - (j `meets` i && i `meets` k) === True - where j = enderval b (begin i) - k = beginerval b (end i) +\[ +\forall i \exists j,k s.t. j:i:k +\] +-} - {- | - ML3 says that For all i, there does not exist m such that i meets m and - m meet i. Not testing that this axiom holds, as I'm not sure how I would - test the lack of existence easily. - -} +prop_IAaxiomM3 :: (Iv (Interval a), SizedIv (Interval a))=> + Moment (Interval a) -> Interval a -> Property +prop_IAaxiomM3 b i = + (j `meets` i && i `meets` k) === True + where j = enderval b (begin i) + k = beginerval b (end i) - {- | +{- | + ML3 says that For all i, there does not exist m such that i meets m and + m meet i. Not testing that this axiom holds, as I'm not sure how I would + test the lack of existence easily. +-} - == Axiom M4 +{- | - If two meets are separated by intervals, then this sequence is a longer interval. +== Axiom M4 - \[ - \forall i,j i:j \implies (\exists k,m,n s.t m:i:j:n \text { & } m:k:n) - \] - -} +If two meets are separated by intervals, then this sequence is a longer interval. - prop_IAaxiomM4 :: (IntervalSizeable a b)=> - b -> M2set a -> Property - prop_IAaxiomM4 b x = - ((m `meets` i && i `meets` j && j `meets` n) && - (m `meets` k && k `meets` n)) === True - where i = m21 x - j = m22 x - m = enderval b (begin i) - n = beginerval b (end j) - k = beginerval g (end m) - g = diff (begin n) (end m) +\[ +\forall i,j i:j \implies (\exists k,m,n s.t m:i:j:n \text { & } m:k:n) +\] +-} +prop_IAaxiomM4 :: forall a. (Iv (Interval a), SizedIv (Interval a), Ord (Moment (Interval a)))=> + Moment (Interval a) -> M2set a -> Property +prop_IAaxiomM4 b x = + ((m `meets` i && i `meets` j && j `meets` n) && + (m `meets` k && k `meets` n)) === True + where i = m21 x + j = m22 x + m = enderval b (begin i) + n = beginerval b (end j) + k = safeInterval (end m, begin n) - -- | Smart constructor of 'M5set'. - m5set :: (IntervalSizeable a b)=> Interval a -> b -> b -> M5set a - m5set x a b = M5set p1 p2 - where p1 = x -- interval i in prop_IAaxiomM5 - p2 = beginerval a ps -- interval l in prop_IAaxiomM5 - ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i - {- | +-- | Smart constructor of 'M5set'. +m5set :: (SizedIv (Interval a), Eq a, Ord (Moment (Interval a)), Num (Moment (Interval a)))=> Interval a -> Moment (Interval a) -> Moment (Interval a) -> M5set a +m5set x a b = M5set p1 p2 + where p1 = x -- interval i in prop_IAaxiomM5 + p2 = beginerval a ps -- interval l in prop_IAaxiomM5 + ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i - == Axiom M5 +{- | - There is only one time period between any two meeting places. +== Axiom M5 - \[ - \forall i,j,k,l (i:j:l \text{ & } i:k:l) \equiv j = k - \] - -} - prop_IAaxiomM5 :: (IntervalSizeable a b) => - M5set a -> Property - prop_IAaxiomM5 x = - ((i `meets` j && j `meets` l) && - (i `meets` k && k `meets` l)) === (j == k) - where i = m51 x - j = beginerval g (end i) - k = beginerval g (end i) - g = diff (begin l) (end i) - l = m52 x +There is only one time period between any two meeting places. - {- | +\[ +\forall i,j,k,l (i:j:l \text{ & } i:k:l) \equiv j = k +\] +-} +prop_IAaxiomM5 :: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => + M5set a -> Property +prop_IAaxiomM5 x = + ((i `meets` j && j `meets` l) && + (i `meets` k && k `meets` l)) === (j == k) + where i = m51 x + j = safeInterval (end i, begin l) + k = j + l = m52 x - == Axiom M4.1 +{- | - Ordered unions: +== Axiom M4.1 - \[ - \forall i,j i:j \implies (\exists m,n s.t. m:i:j:n \text{ & } m:(i+j):n) - \] - -} - prop_IAaxiomM4_1 :: (IntervalSizeable a b)=> - b -> M2set a -> Property - prop_IAaxiomM4_1 b x = - ((m `meets` i && i `meets` j && j `meets` n) && - (m `meets` ij && ij `meets` n)) === True - where i = m21 x - j = m22 x - m = enderval b (begin i) - n = beginerval b (end j) - ij = fromJust $ i .+. j +Ordered unions: -instance IntervalAxioms Int Int -instance IntervalAxioms Day Integer -instance IntervalAxioms UTCTime NominalDiffTime +\[ +\forall i,j i:j \implies (\exists m,n s.t. m:i:j:n \text{ & } m:(i+j):n) +\] +-} +prop_IAaxiomM4_1 :: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => + Moment (Interval a) -> M2set a -> Property +prop_IAaxiomM4_1 b x = + ((m `meets` i && i `meets` j && j `meets` n) && + (m `meets` ij && ij `meets` n)) === True + where i = m21 x + j = m22 x + m = enderval b (begin i) + n = beginerval b (end j) + ij = fromJust $ i .+. j diff --git a/src/IntervalAlgebra/Core.hs b/src/IntervalAlgebra/Core.hs --- a/src/IntervalAlgebra/Core.hs +++ b/src/IntervalAlgebra/Core.hs @@ -1,1349 +1,1619 @@ -{-| -Module : Interval Algebra -Description : Implementation of Allen's interval algebra -Copyright : (c) NoviSci, Inc 2020 -License : BSD3 -Maintainer : bsaul@novisci.com - -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 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. @'IntervalCombinable'@ provides an interface to methods of combining two - @'Interval's@. -3. @'IntervalSizeable'@ provides methods for measuring and modifying the size of - an interval. - --} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module IntervalAlgebra.Core - ( - - -- * Intervals - Interval - , Intervallic(..) - , ParseErrorInterval(..) - , begin - , end - - -- ** Create new intervals - , parseInterval - , prsi - , beginerval - , bi - , enderval - , ei - , safeInterval - , si - - -- ** Modify intervals - , expand - , expandl - , expandr - - -- * Interval Algebra - - -- ** Interval Relations and Predicates - , IntervalRelation(..) - , meets - , metBy - , before - , after - , overlaps - , overlappedBy - , finishedBy - , finishes - , contains - , during - , starts - , startedBy - , equals - - -- ** Additional predicates and utilities - , precedes - , precededBy - , disjoint - , notDisjoint - , concur - , within - , encloses - , enclosedBy - , (<|>) - , predicate - , unionPredicates - , disjointRelations - , withinRelations - , strictWithinRelations - , ComparativePredicateOf1 - , ComparativePredicateOf2 - , beginervalFromEnd - , endervalFromBegin - , beginervalMoment - , endervalMoment - , shiftFromBegin - , shiftFromEnd - , momentize - , toEnumInterval - , fromEnumInterval - - -- ** Algebraic operations - , intervalRelations - , relate - , compose - , complement - , union - , intersection - , converse - - -- * Combine two intervals - , IntervalCombinable(..) - , extenterval - - -- * Measure an interval - , IntervalSizeable(..) - ) where - -import Control.Applicative (Applicative (pure), liftA2) -import Control.DeepSeq (NFData) -import Data.Binary (Binary) -import Data.Fixed (Pico) -import Data.Function (flip, id, ($), (.)) -import Data.Ord (Ord (..), Ordering (..), max, min) -import Data.Semigroup (Semigroup ((<>))) -import qualified Data.Set (Set, difference, fromList, intersection, - map, toList, union) -import Data.Time as DT (Day, DiffTime, NominalDiffTime, - UTCTime, addDays, addUTCTime, - diffDays, diffUTCTime, - nominalDiffTimeToSeconds, - secondsToNominalDiffTime) -import Data.Tuple (fst, snd) -import GHC.Generics (Generic) -import Prelude (Bool (..), Bounded (..), Either (..), - Enum (..), Eq, Int, Integer, Maybe (..), - Num, Rational, Show, String, any, curry, - fromInteger, fromRational, map, negate, - not, otherwise, realToFrac, replicate, - show, toInteger, toRational, (!!), (&&), - (+), (++), (-), (==)) -import Test.QuickCheck (Arbitrary (..), resize, sized, suchThat) - -{- $setup ->>> import IntervalAlgebra.IntervalDiagram --} - -{- | 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, Generic) - --- | A type identifying interval parsing errors. -newtype ParseErrorInterval = ParseErrorInterval String - deriving (Eq, Show) - -{- | Helper defining what a valid relation is between begin and end of an -Interval. --} -isValidBeginEnd :: (Ord a) => a -> a -> Bool -isValidBeginEnd b e = b < e - -{- | Safely parse a pair of @a@s to create an @'Interval' a@. - ->>> parseInterval 0 1 -Right (0, 1) - ->>> parseInterval 1 0 -Left (ParseErrorInterval "0<=1") --} -parseInterval - :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) -parseInterval x y - | isValidBeginEnd x y = Right $ Interval (x, y) - | otherwise = Left $ ParseErrorInterval $ show y ++ "<=" ++ show x --- | A synonym for `parseInterval` -prsi :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) -prsi = parseInterval - -intervalBegin :: Interval a -> a -intervalBegin (Interval x) = fst x - -intervalEnd :: Interval a -> a -intervalEnd (Interval x) = snd x - -instance (Show a, Ord a) => Show (Interval a) where - show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")" - -instance Binary a => Binary (Interval a) -instance NFData a => NFData (Interval a) - -{- | 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 --} -class Intervallic i where - - -- | Get the interval from an @i a@. - getInterval :: i a -> Interval a - - -- | Set the interval in an @i a@. - setInterval :: i a -> Interval b -> i b - --- | Access the endpoints of an @i a@ . -begin, end :: (Intervallic i) => i a -> a -begin = intervalBegin . getInterval -end = intervalEnd . getInterval - -{- | This *unexported* function is an internal convenience function for cases in -which @f@ is known to be strictly monotone. --} -imapStrictMonotone :: (Intervallic i) => (a -> b) -> i a -> i b -imapStrictMonotone f i = setInterval i (op f (getInterval i)) - where op f (Interval (b, e)) = Interval (f b, f e) - -{- | 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 = - 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` - deriving (Eq, Show, Enum) - -instance Bounded IntervalRelation where - minBound = Before - maxBound = After - -instance Ord IntervalRelation where - compare x y = compare (fromEnum x) (fromEnum y) - - -{- | Does x `meets` y? Is x `metBy` y? - -Example data with corresponding diagram: - ->>> x = bi 5 0 ->>> y = bi 5 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ------ <- [x] - ----- <- [y] -========== - -Examples: - ->>> x `meets` y -True - ->>> x `metBy` y -False - ->>> y `meets` x -False - ->>> y `metBy` x -True --} -meets, metBy - :: (Eq a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -meets x y = end x == begin y -metBy = flip meets - - -{- | Is x `before` y? Does x `precedes` y? Is x `after` y? Is x `precededBy` y? - -Example data with corresponding diagram: - ->>> x = bi 3 0 ->>> y = bi 4 6 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ---- <- [x] - ---- <- [y] -========== - -Examples: - ->>> x `before` y -True ->>> x `precedes` y -True - ->>> x `after`y -False ->>> x `precededBy` y -False - ->>> y `before` x -False ->>> y `precedes` x -False - ->>> y `after` x -True ->>> y `precededBy` x -True --} -before, after, precedes, precededBy - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -before x y = end x < begin y -after = flip before -precedes = before -precededBy = after - - -{- | Does x `overlaps` y? Is x `overlappedBy` y? - -Example data with corresponding diagram: - ->>> x = bi 6 0 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ------- <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `overlaps` y -True - ->>> x `overlappedBy` y -False - ->>> y `overlaps` x -False - ->>> y `overlappedBy` x -True --} -overlaps, overlappedBy - :: (Ord a, Intervallic i0, Intervallic i1) - => 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 `starts` y? Is x `startedBy` y? - -Example data with corresponding diagram: - ->>> x = bi 3 4 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - --- <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `starts` y -True - ->>> x `startedBy` y -False - ->>> y `starts` x -False - ->>> y `startedBy` x -True --} -starts, startedBy - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -starts x y = begin x == begin y && end x < end y -startedBy = flip starts - - -{- | Does x `finishes` y? Is x `finishedBy` y? - -Example data with corresponding diagram: - ->>> x = bi 3 7 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - --- <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `finishes` y -True - ->>> x `finishedBy` y -False - ->>> y `finishes` x -False - ->>> y `finishedBy` x -True --} -finishes, finishedBy - :: (Ord a, Intervallic i0, Intervallic i1) - => 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 `contains` y? - -Example data with corresponding diagram: - ->>> x = bi 3 5 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - --- <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `during` y -True - ->>> x `contains` y -False - ->>> y `during` x -False - ->>> y `contains` x -True --} -during, contains - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -during x y = begin x > begin y && end x < end y -contains = flip during - - -{- | Does x `equals` y? - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `equals` y -True - ->>> y `equals` x -True --} -equals - :: (Ord a, Intervallic i0, Intervallic i1) - => 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, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) - -> ComparativePredicateOf2 (i0 a) (i1 a) - -> ComparativePredicateOf2 (i0 a) (i1 a) -(<|>) f g = unionPredicates [f, g] - --- | The set of @IntervalRelation@ meaning two intervals are disjoint. -disjointRelations :: Data.Set.Set IntervalRelation -disjointRelations = toSet [Before, After, Meets, MetBy] - --- | The set of @IntervalRelation@ meaning one interval is within the other. -withinRelations :: Data.Set.Set IntervalRelation -withinRelations = toSet [Starts, During, Finishes, Equals] - --- | The set of @IntervalRelation@ meaning one interval is *strictly* within the other. -strictWithinRelations :: Data.Set.Set IntervalRelation -strictWithinRelations = Data.Set.difference withinRelations (toSet [Equals]) - - -{- | Are x and y `disjoint` ('before', 'after', 'meets', or 'metBy')? - -Example data with corresponding diagram: - ->>> x = bi 3 0 ->>> y = bi 3 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ---- <- [x] - --- <- [y] -======== - -Examples: - ->>> x `disjoint` y -True - ->>> y `disjoint` x -True - -Example data with corresponding diagram: - ->>> x = bi 3 0 ->>> y = bi 3 3 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ---- <- [x] - --- <- [y] -====== - -Examples: - ->>> x `disjoint` y -True - ->>> y `disjoint` x -True - -Example data with corresponding diagram: - ->>> x = bi 6 0 ->>> y = bi 3 3 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ------- <- [x] - --- <- [y] -====== - -Examples: - ->>> x `disjoint` y -False - ->>> y `disjoint` x -False --} -disjoint - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -disjoint = predicate disjointRelations - - -{-| Does x `concur` with y? Is x `notDisjoint` with y?); This is -the 'complement' of 'disjoint'. - -Example data with corresponding diagram: - ->>> x = bi 3 0 ->>> y = bi 3 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ---- <- [x] - --- <- [y] -======= - -Examples: - ->>> x `notDisjoint` y -False ->>> y `concur` x -False - -Example data with corresponding diagram: - ->>> x = bi 3 0 ->>> y = bi 3 3 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ---- <- [x] - --- <- [y] -====== - -Examples: - ->>> x `notDisjoint` y -False ->>> y `concur` x -False - -Example data with corresponding diagram: - ->>> x = bi 6 0 ->>> y = bi 3 3 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] ------- <- [x] - --- <- [y] -====== - -Examples: - ->>> x `notDisjoint` y -True ->>> y `concur` x -True --} -notDisjoint, concur - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -notDisjoint = predicate (complement disjointRelations) -concur = notDisjoint - - -{- | Is x `within` (`enclosedBy`) y? That is, 'during', 'starts', 'finishes', or -'equals'? - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `within` y -True - ->>> y `enclosedBy` x -True - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 5 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ----- <- [y] -========== - -Examples: - ->>> x `within` y -False - ->>> y `enclosedBy` x -True - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 4 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ---- <- [y] -========== - -Examples: - ->>> x `within` y -False ->>> y `enclosedBy` x -True - -Example data with corresponding diagram: - ->>> x = bi 2 7 ->>> y = bi 1 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - -- <- [x] - - <- [y] -========= - -Examples: - ->>> x `within` y -False - ->>> y `enclosedBy` x -False --} -within, enclosedBy - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -within = predicate withinRelations -enclosedBy = within - - -{- | Does x `encloses` y? That is, is y 'within' x? - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 6 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ------ <- [y] -========== - -Examples: - ->>> x `encloses` y -True - ->>> y `encloses` x -True - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 5 4 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ----- <- [y] -========== - -Examples: - ->>> x `encloses` y -True - ->>> y `encloses` x -False - -Example data with corresponding diagram: - ->>> x = bi 6 4 ->>> y = bi 4 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - ------ <- [x] - ---- <- [y] -========== - -Examples: - ->>> x `encloses` y -True - ->>> y `encloses` x -False - -Example data with corresponding diagram: - ->>> x = bi 2 7 ->>> y = bi 1 5 ->>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] - -- <- [x] - - <- [y] -========= - -Examples: - ->>> x `encloses` y -False - ->>> y `encloses` x -False --} -encloses - :: (Ord a, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) -encloses = 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 -> 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 - :: (Ord a, Intervallic i0, Intervallic i1) - => 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 - :: (Ord a, Intervallic i0, Intervallic i1) - => 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 - :: (Ord a, Intervallic i0, Intervallic i1) - => Data.Set.Set IntervalRelation - -> ComparativePredicateOf2 (i0 a) (i1 a) -predicate = unionPredicates . predicates - --- | The lookup table for the compositions of interval relations. -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] - , [p, p, pmo, pmo, pmofd, o, o, ofd, osd, osd, cncr, dso, dsomp] - , [p, m, o, f', d', o, f', d', osd, fef, dso, dso, dsomp] - , [pmofd, ofd, ofd, d', d', ofd, d', d', cncr, dso, dso, dso, dsomp] - , [p, p, pmo, pmo, pmofd, s, s, ses, d, d, dfo, m', p'] - , [p, m, o, f', d', s, e, s', d, f, o', m', p'] - , [pmofd, ofd, ofd, d', d', ses, s', s', dfo, o', o', m', p'] - , [p, p, pmosd, pmosd, full, d, d, dfomp, d, d, dfomp, p', p'] - , [p, m, osd, fef, dsomp, d, f, omp, d, f, omp, p', p'] - , [pmofd, ofd, cncr, dso, dsomp, dfo, o', omp, dfo, o', omp, p', p'] - , [pmofd, ses, dfo, m', p', dfo, m', p', dfo, m', p', p', p'] - , [full, dfomp, dfomp, p', p', dfomp, p', p', dfomp, p', p', p', p'] - ] - where - p = [Before] - m = [Meets] - o = [Overlaps] - f' = [FinishedBy] - d' = [Contains] - s = [Starts] - e = [Equals] - s' = [StartedBy] - d = [During] - f = [Finishes] - o' = [OverlappedBy] - m' = [MetBy] - p' = [After] - ses = s ++ e ++ s' - fef = f' ++ e ++ f - pmo = p ++ m ++ o - pmofd = pmo ++ f' ++ d' - osd = o ++ s ++ d - ofd = o ++ f' ++ d' - omp = o' ++ m' ++ p' - dfo = d ++ f ++ o' - dfomp = dfo ++ m' ++ p' - dso = d' ++ s' ++ o' - dsomp = dso ++ m' ++ p' - pmosd = p ++ m ++ osd - cncr = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o' - full = p ++ m ++ cncr ++ m' ++ p' - -{- | 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 - :: (Ord a, Intervallic i0, Intervallic i1) => 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 - -{- | 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) - --- | Finds the complement of a @'Data.Set.Set' 'IntervalRelation'@. -complement :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation -complement = Data.Set.difference intervalRelations - --- | 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 - --- | 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 - --- | 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 'Intervallic' type and to resize an 'Interval a'. --} -class (Ord a, Num b, Ord b) => IntervalSizeable a b | a -> b where - - -- | The smallest duration for an 'Interval a'. - moment :: forall a . b - moment = 1 - - -- | Determine the duration of an @'i a'@. - duration :: (Intervallic i) => i a -> b - duration x = diff (end x) (begin x) - - -- | Shifts an @a@. Most often, the @b@ will be the same type as @a@. - -- But for example, if @a@ is 'Day' then @b@ could be 'Int'. - add :: b -> a -> a - - -- | 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 "right" by @r@. -In the case that @l@ or @r@ are less than a 'moment' the respective endpoints -are unchanged. - ->>> iv2to4 = safeInterval (2::Int, 4::Int) ->>> iv2to4' = expand 0 0 iv2to4 ->>> iv1to5 = expand 1 1 iv2to4 - ->>> iv2to4 -(2, 4) - ->>> iv2to4' -(2, 4) - ->>> iv1to5 -(1, 5) - ->>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv1to5, "iv1to5")] [] - -- <- [iv2to4] - ---- <- [iv1to5] -===== --} -expand - :: forall i a b - . (IntervalSizeable a b, Intervallic i) - => 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 @a then 0 else negate l - e = if r < moment @a then 0 else r - i = Interval (add s $ begin p, add e $ end p) - -{- | Expands an @i a@ to the "left". - ->>> iv2to4 = (safeInterval (2::Int, 4::Int)) ->>> iv0to4 = expandl 2 iv2to4 - ->>> iv2to4 -(2, 4) - ->>> iv0to4 -(0, 4) - ->>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv0to4, "iv0to4")] [] - -- <- [iv2to4] ----- <- [iv0to4] -==== --} -expandl :: (IntervalSizeable a b, Intervallic i) => b -> i a -> i a -expandl i = expand i 0 - -{- | Expands an @i a@ to the "right". - ->>> iv2to4 = (safeInterval (2::Int, 4::Int)) ->>> iv2to6 = expandr 2 iv2to4 - ->>> iv2to4 -(2, 4) - ->>> iv2to6 -(2, 6) - ->>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv2to6, "iv2to6")] [] - -- <- [iv2to4] - ---- <- [iv2to6] -====== --} -expandr :: (IntervalSizeable a b, Intervallic i) => 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 (0::Int) (0::Int) -(0, 1) - ->>> beginerval (1::Int) (0::Int) -(0, 1) - ->>> beginerval (2::Int) (0::Int) -(0, 2) --} -beginerval - :: forall a b - . (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 @a) dur - y = add d x -{-# INLINABLE beginerval #-} - --- | A synonym for `beginerval` -bi - :: (IntervalSizeable a b) - => b -- ^ @dur@ation to add to the 'begin' - -> a -- ^ the 'begin' point of the 'Interval' - -> Interval a -bi = beginerval - - -{- | Safely creates an 'Interval a' using @x@ as the 'end' and adding @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 - :: forall a b - . (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 @a) dur) x, x) - where i = Interval (x, x) -{-# INLINABLE enderval #-} - --- | A synonym for `enderval` -ei - :: (IntervalSizeable a b) - => b -- ^ @dur@ation to subtract from the 'end' - -> a -- ^ the 'end' point of the 'Interval' - -> Interval a -ei = enderval - - --- | Safely creates an @'Interval'@ from a pair of endpoints. --- IMPORTANT: This function uses 'beginerval', --- thus if the second element of the pair is `<=` the first element, --- the duration will be an @"Interval"@ of 'moment' duration. --- --- >>> safeInterval (4, 5 ::Int) --- (4, 5) --- >>> safeInterval (4, 3 :: Int) --- (4, 5) --- -safeInterval :: IntervalSizeable a b => (a, a) -> Interval a -safeInterval (b, e) = beginerval (diff e b) b - --- | A synonym for `safeInterval` -si :: IntervalSizeable a b => (a, a) -> Interval a -si = safeInterval - --- | Creates a new Interval from the 'end' of an @i a@. -beginervalFromEnd - :: (IntervalSizeable a b, Intervallic i) - => b -- ^ @dur@ation to add to the 'end' - -> i a -- ^ the @i a@ from which to get the 'end' - -> Interval a -beginervalFromEnd d i = beginerval d (end i) - --- | Creates a new Interval from the 'begin' of an @i a@. -endervalFromBegin - :: (IntervalSizeable a b, Intervallic i) - => b -- ^ @dur@ation to subtract from the 'begin' - -> i a -- ^ the @i a@ from which to get the 'begin' - -> Interval a -endervalFromBegin d i = enderval d (begin i) - -{- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@ - ->>> beginervalMoment (10 :: Int) -(10, 11) --} -beginervalMoment :: forall a b . (IntervalSizeable a b) => a -> Interval a -beginervalMoment x = beginerval (moment @a) x where i = Interval (x, x) - -{- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ - ->>> endervalMoment (10 :: Int) -(9, 10) --} -endervalMoment :: forall a b . (IntervalSizeable a b) => a -> Interval a -endervalMoment x = enderval (moment @a) x where i = Interval (x, x) - -{- | Creates a new @Interval@ spanning the extent x and y. - ->>> extenterval (Interval (0, 1)) (Interval (9, 10)) -(0, 10) --} -extenterval :: (Ord a, Intervallic i) => 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) - -{- | Modifies the endpoints of second argument's interval by taking the difference -from the first's input's 'begin'. - -Example data with corresponding diagram: - ->>> a = bi 3 2 :: Interval Int ->>> a -(2, 5) ->>> x = bi 3 7 :: Interval Int ->>> x -(7, 10) ->>> y = bi 4 9 :: Interval Int ->>> y -(9, 13) ->>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] - --- <- [a] - --- <- [x] - ---- <- [y] -============= - -Examples: - ->>> x' = shiftFromBegin a x ->>> x' -(5, 8) ->>> y' = shiftFromBegin a y ->>> y' -(7, 11) ->>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] - --- <- [x'] - ---- <- [y'] -=========== --} -shiftFromBegin - :: (IntervalSizeable a b, Intervallic i1, Intervallic i0) - => i0 a - -> i1 a - -> i1 b -shiftFromBegin i = imapStrictMonotone (`diff` begin i) - -{- | Modifies the endpoints of second argument's interval by taking the difference -from the first's input's 'end'. - -Example data with corresponding diagram: - ->>> a = bi 3 2 :: Interval Int ->>> a -(2, 5) ->>> x = bi 3 7 :: Interval Int ->>> x -(7, 10) ->>> y = bi 4 9 :: Interval Int ->>> y -(9, 13) ->>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] - --- <- [a] - --- <- [x] - ---- <- [y] -============= - -Examples: - ->>> x' = shiftFromEnd a x ->>> x' -(2, 5) ->>> y' = shiftFromEnd a y ->>> y' -(4, 8) ->>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] - --- <- [x'] - ---- <- [y'] -======== --} -shiftFromEnd - :: (IntervalSizeable a b, Intervallic i1, Intervallic i0) - => i0 a - -> i1 a - -> i1 b -shiftFromEnd i = imapStrictMonotone (`diff` end i) - --- | Converts an @i a@ to an @i Int@ via @fromEnum@. This assumes the provided --- @fromEnum@ method is strictly monotone increasing: For @a@ types that are --- @Ord@ with values @x, y@, then @x < y@ implies @fromEnum x < fromEnum y@, so --- long as the latter is well-defined. -fromEnumInterval :: (Enum a, Intervallic i) => i a -> i Int -fromEnumInterval = imapStrictMonotone fromEnum - --- | Converts an @i Int@ to an @i a@ via @toEnum@. This assumes the provided --- @toEnum@ method is strictly monotone increasing: For @a@ types that are --- @Ord@, then for @Int@ values @x, y@ it holds that @x < y@ implies @toEnum x --- < toEnum y@. -toEnumInterval :: (Enum a, Intervallic i) => i Int -> i a -toEnumInterval = imapStrictMonotone toEnum - - - -{- | Changes the duration of an 'Intervallic' value to a moment starting at the -'begin' of the interval. - ->>> momentize (Interval (6, 10)) -(6, 7) --} -momentize - :: forall i a b . (IntervalSizeable a b, Intervallic i) => i a -> i a -momentize i = setInterval i (beginerval (moment @a) (begin i)) - -{- | The @'IntervalCombinable'@ typeclass provides methods for (possibly) -combining two @i a@s to form a @'Maybe' i a@, or in case of @><@, a possibly -different @Intervallic@ type. --} -class (Ord a, Intervallic i) => 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) - (.+.) x y - | x `meets` y = Just $ setInterval y $ Interval (b, e) - | otherwise = Nothing - where b = begin x - e = end y - {-# INLINABLE (.+.) #-} - - -- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the - -- 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 - -- intervals when @x@ is *not* 'before' @y@. - (<+>):: ( Semigroup (f (i a)), Applicative f) => - i a - -> i a - -> f (i a) -{-# DEPRECATED (<+>) "A specialized function without clear use-cases." #-} - -{- -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 --- -} - --- | Imposes a total ordering on @'Interval' a@ based on first ordering the --- 'begin's then the 'end's. -instance (Ord a) => Ord (Interval a) where - (<=) x y | begin x < begin y = True - | begin x == begin y = end x <= end y - | otherwise = False - (<) x y | begin x < begin y = True - | begin x == begin y = end x < end y - | otherwise = False - -instance Intervallic Interval where - getInterval = id - setInterval _ x = x - -instance (Ord a) => IntervalCombinable Interval a where - (><) x y | x `before` y = Just $ Interval (end x, begin y) - | otherwise = Nothing - {-# INLINABLE (><) #-} - - (<+>) x y | x `before` y = pure x <> pure y - | otherwise = pure (extenterval x y) - {-# INLINABLE (<+>) #-} - -instance IntervalSizeable Int Int where - moment = 1 - add = (+) - diff = (-) - -instance IntervalSizeable Integer Integer where - moment = 1 - add = (+) - diff = (-) - -instance IntervalSizeable DT.Day Integer where - moment = 1 - add = addDays - diff = diffDays - --- | Note that the @moment@ of this instance is a @'Data.Fixed.Pico'@ -instance IntervalSizeable DT.UTCTime NominalDiffTime where - moment = toEnum 1 :: NominalDiffTime - add = addUTCTime - diff = diffUTCTime - --- Arbitrary instances -instance (Ord a, Arbitrary a) => Arbitrary (Interval a) where - arbitrary = - sized - (\s -> liftA2 (curry Interval) - (s `resize` arbitrary) - (s `resize` arbitrary) - ) - `suchThat` (\i -> isValidBeginEnd (intervalBegin i) (intervalEnd i)) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Interval Algebra +-- Description : Implementation of Allen's interval algebra +-- Copyright : (c) NoviSci, Inc 2020-2022 +-- TargetRWE, 2023 +-- License : BSD3 +-- Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 +-- +-- 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 provides an 'Interval' type wrapping a canonical interval to be used with the +-- relation algebra defined in the papers cited above. @'Interval' a@ +-- wraps @(a, a)@, giving the interval's 'begin' and 'end' points. +-- +-- However, the module provides typeclasses to generalize an 'Interval' and the +-- interval algebra for temporal logic, such that it could be used in settings +-- where there is no need for continguity between the begin and end points, or +-- where the "intervals" are qualitative and do not have a begin or end. See +-- 'Iv' for an example. + +-- Many exports of this module require `FlexibleContexts` and `TypeFamilies` +-- extensions to be enabled. +module IntervalAlgebra.Core + ( -- * Canonical intervals + Interval, + PointedIv (..), + SizedIv (..), + Intervallic (..), + begin, + end, + + -- ** Create new intervals + ParseErrorInterval (..), + parseInterval, + prsi, + beginerval, + bi, + enderval, + ei, + safeInterval, + si, + + -- ** Modify intervals within an @Intervallic@ + expand, + expandl, + expandr, + + -- ** Combine two intervals + extenterval, + + -- * Interval Algebra + Iv (..), + + -- ** Interval Relations and Predicates + IntervalRelation (..), + meets, + metBy, + before, + after, + overlaps, + overlappedBy, + finishedBy, + finishes, + contains, + during, + starts, + startedBy, + equals, + + -- ** Additional predicates and utilities + precedes, + precededBy, + disjoint, + notDisjoint, + concur, + within, + encloses, + enclosedBy, + (<|>), + predicate, + unionPredicates, + disjointRelations, + withinRelations, + strictWithinRelations, + ComparativePredicateOf1, + ComparativePredicateOf2, + beginervalFromEnd, + endervalFromBegin, + beginervalMoment, + endervalMoment, + shiftFromBegin, + shiftFromEnd, + momentize, + toEnumInterval, + fromEnumInterval, + + -- ** Algebraic operations + intervalRelations, + relate, + compose, + complement, + union, + intersection, + converse, + converseRelation, + ) +where + +import Control.Applicative (Applicative (pure), liftA2) +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Fixed (Pico) +import Data.Function (flip, id, ($), (.)) +import Data.Kind (Type) +import Data.Ord (Ord (..), Ordering (..), max, min) +import Data.Semigroup (Semigroup ((<>))) +import qualified Data.Set (Set, difference, fromList, intersection, + map, toList, union) +import Data.Time as DT (Day, DiffTime, NominalDiffTime, + UTCTime, addDays, addUTCTime, + diffDays, diffUTCTime, + nominalDiffTimeToSeconds, + secondsToNominalDiffTime) +import Data.Tuple (fst, snd) +import GHC.Generics (Generic) +import GHC.IO.Handle (NewlineMode (inputNL)) +import Test.QuickCheck (Arbitrary (..), resize, sized, suchThat) + +-- $setup +-- >>> import IntervalAlgebra.IntervalDiagram +-- >>> :set -XTypeFamilies + +-- | 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, Generic) + +-- | A type identifying interval parsing errors. +newtype ParseErrorInterval + = ParseErrorInterval String + deriving (Eq, Show) + +-- | Helper defining what a valid relation is between begin and end of an +-- Interval. +isValidBeginEnd :: (Ord a) => a -> a -> Bool +isValidBeginEnd b e = b < e + +-- | Parse a pair of @a@s to create an @'Interval' a@. Note this +-- checks only that @begin < end@ and has no relation to checking +-- the conditions of 'SizedIv'. +-- +-- >>> parseInterval 0 1 +-- Right (0, 1) +-- +-- >>> parseInterval 1 0 +-- Left (ParseErrorInterval "0<=1") +parseInterval :: + (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) +parseInterval x y + | isValidBeginEnd x y = Right $ Interval (x, y) + | otherwise = Left $ ParseErrorInterval $ show y ++ "<=" ++ show x + +-- | A synonym for `parseInterval` +prsi :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) +prsi = parseInterval + +instance (Show a, Ord a) => Show (Interval a) where + show (Interval x) = "(" ++ show (fst x) ++ ", " ++ show (snd x) ++ ")" + +instance Binary a => Binary (Interval a) + +instance NFData a => NFData (Interval a) + +{- INTERVALLIC -} + +-- | The @'Intervallic'@ typeclass defines how to get and set the 'Interval' +-- content of a data structure. 'Intervallic' types can be compared via +-- 'IntervalRelation' s on their underlying 'Interval', and functions of this +-- module define versions of the methods from 'Iv', 'PointedIv' and 'SizedIv' +-- for instances of 'Intervallic' by applying them to the contained interval. +-- +-- Only the canonical representation @'Interval'@ should define an instance of all four +-- classes. +-- +-- 'PairedInterval' is the prototypical example of an 'Intervallic'. +-- +-- >>> getInterval (Interval (0, 10)) +-- (0, 10) +-- +-- >>> begin (Interval (0, 10)) +-- 0 +-- +-- >>> end (Interval (0, 10)) +-- 10 +class Intervallic i where + -- | Get the interval from an @i a@. + getInterval :: i a -> Interval a + + -- | Set the interval in an @i a@. + setInterval :: i a -> Interval b -> i b + +-- | Access the endpoints of an @i a@ . +begin, end :: forall i a. (SizedIv (Interval a), Intervallic i) => i a -> a +begin = ivBegin . getInterval +end = ivEnd . getInterval + +-- | This *unexported* function is an internal convenience function for cases in +-- which @f@ is known to be strictly monotone. +imapStrictMonotone :: (Intervallic i) => (a -> b) -> i a -> i b +imapStrictMonotone f i = setInterval i (op f (getInterval i)) + where + op f (Interval (b, e)) = Interval (f b, f e) + +{- RELATIONS -} + +-- | The 'IntervalRelation' type and the associated predicate functions enumerate +-- the thirteen possible ways that two @'SizedIv'@ objects may 'relate' +-- according to Allen's interval algebra. Constructors are shown with their +-- corresponding predicate function. +data IntervalRelation + = -- | `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 + deriving (Enum, Eq, Show) + +instance Bounded IntervalRelation where + minBound = Before + maxBound = After + +instance Ord IntervalRelation where + compare x y = compare (fromEnum x) (fromEnum y) + +-- | Does x `meets` y? Is x `metBy` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 5 0 +-- >>> y = bi 5 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ----- <- [x] +-- ----- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `meets` y +-- True +-- +-- >>> x `metBy` y +-- False +-- +-- >>> y `meets` x +-- False +-- +-- >>> y `metBy` x +-- True +meets, + metBy :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +meets x y = ivMeets (getInterval x) (getInterval y) +metBy = flip meets + +-- | Is x `before` y? Does x `precedes` y? Is x `after` y? Is x `precededBy` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 0 +-- >>> y = bi 4 6 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- ---- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `before` y +-- True +-- >>> x `precedes` y +-- True +-- +-- >>> x `after`y +-- False +-- >>> x `precededBy` y +-- False +-- +-- >>> y `before` x +-- False +-- >>> y `precedes` x +-- False +-- +-- >>> y `after` x +-- True +-- >>> y `precededBy` x +-- True +before, + after, + precedes, + precededBy :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +before x y = ivBefore (getInterval x) (getInterval y) +after = flip before +precedes = before +precededBy = after + +-- | Aliases for 'ivBefore' and 'ivAfter'. +ivPrecedes, ivPrecededBy :: (Iv iv) => iv -> iv -> Bool +ivPrecedes = ivBefore +ivPrecededBy = ivAfter + +-- | Does x `overlaps` y? Is x `overlappedBy` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 0 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `overlaps` y +-- True +-- +-- >>> x `overlappedBy` y +-- False +-- +-- >>> y `overlaps` x +-- False +-- +-- >>> y `overlappedBy` x +-- True +overlaps, + overlappedBy :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +overlaps x y = ivOverlaps (getInterval x) (getInterval y) +overlappedBy = flip overlaps + +-- | Does x `starts` y? Is x `startedBy` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 4 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `starts` y +-- True +-- +-- >>> x `startedBy` y +-- False +-- +-- >>> y `starts` x +-- False +-- +-- >>> y `startedBy` x +-- True +starts, + startedBy :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +starts x y = ivStarts (getInterval x) (getInterval y) +startedBy = flip starts + +-- | Does x `finishes` y? Is x `finishedBy` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 7 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `finishes` y +-- True +-- +-- >>> x `finishedBy` y +-- False +-- +-- >>> y `finishes` x +-- False +-- +-- >>> y `finishedBy` x +-- True +finishes, + finishedBy :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +finishes x y = ivFinishes (getInterval x) (getInterval y) +finishedBy = flip finishes + +-- | Is x `during` y? Does x `contains` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 5 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `during` y +-- True +-- +-- >>> x `contains` y +-- False +-- +-- >>> y `during` x +-- False +-- +-- >>> y `contains` x +-- True +during, + contains :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +during x y = ivDuring (getInterval x) (getInterval y) +contains = flip during + +-- | Does x `equals` y? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `equals` y +-- True +-- +-- >>> y `equals` x +-- True +equals :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +equals x y = ivEquals (getInterval x) (getInterval y) + +{- Intervallic-specific relation utilities -} + +-- | Operator for composing the union of two predicates on 'Intervallic' s. +(<|>) :: + (Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) -> + ComparativePredicateOf2 (i0 a) (i1 a) -> + ComparativePredicateOf2 (i0 a) (i1 a) +(<|>) f g = unionPredicates [f, g] + +-- | The set of @IntervalRelation@ meaning two intervals are disjoint. +disjointRelations :: Data.Set.Set IntervalRelation +disjointRelations = toSet [Before, After, Meets, MetBy] + +-- | The set of @IntervalRelation@ meaning one interval is within the other. +withinRelations :: Data.Set.Set IntervalRelation +withinRelations = toSet [Starts, During, Finishes, Equals] + +-- | The set of @IntervalRelation@ meaning one interval is *strictly* within the other. +strictWithinRelations :: Data.Set.Set IntervalRelation +strictWithinRelations = Data.Set.difference withinRelations (toSet [Equals]) + +-- | Are x and y `disjoint` ('before', 'after', 'meets', or 'metBy')? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 0 +-- >>> y = bi 3 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- --- <- [y] +-- ======== +-- +-- Examples: +-- +-- >>> x `disjoint` y +-- True +-- +-- >>> y `disjoint` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 0 +-- >>> y = bi 3 3 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- --- <- [y] +-- ====== +-- +-- Examples: +-- +-- >>> x `disjoint` y +-- True +-- +-- >>> y `disjoint` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 0 +-- >>> y = bi 3 3 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- --- <- [y] +-- ====== +-- +-- Examples: +-- +-- >>> x `disjoint` y +-- False +-- +-- >>> y `disjoint` x +-- False +disjoint :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +disjoint = predicate disjointRelations + +-- | Does @x `concur` y@, meaning @x@ and @y@ share some support? Is @x `notDisjoint` y@? This is +-- the 'complement' of 'disjoint'. +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 0 +-- >>> y = bi 3 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- --- <- [y] +-- ======= +-- +-- Examples: +-- +-- >>> x `notDisjoint` y +-- False +-- >>> y `concur` x +-- False +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 3 0 +-- >>> y = bi 3 3 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- --- <- [x] +-- --- <- [y] +-- ====== +-- +-- Examples: +-- +-- >>> x `notDisjoint` y +-- False +-- >>> y `concur` x +-- False +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 0 +-- >>> y = bi 3 3 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- --- <- [y] +-- ====== +-- +-- Examples: +-- +-- >>> x `notDisjoint` y +-- True +-- >>> y `concur` x +-- True +notDisjoint, + concur :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +notDisjoint = predicate (complement disjointRelations) +concur = notDisjoint + +-- | Is x `within` (`enclosedBy`) y? That is, 'during', 'starts', 'finishes', or +-- 'equals'? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `within` y +-- True +-- +-- >>> y `enclosedBy` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 5 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ----- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `within` y +-- False +-- +-- >>> y `enclosedBy` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 4 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ---- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `within` y +-- False +-- >>> y `enclosedBy` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 2 7 +-- >>> y = bi 1 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- -- <- [x] +-- - <- [y] +-- ========= +-- +-- Examples: +-- +-- >>> x `within` y +-- False +-- +-- >>> y `enclosedBy` x +-- False +within, + enclosedBy :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +within = predicate withinRelations +enclosedBy = within + +-- | Does x `encloses` y? That is, is y 'within' x? +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 6 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ------ <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `encloses` y +-- True +-- +-- >>> y `encloses` x +-- True +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 5 4 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ----- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `encloses` y +-- True +-- +-- >>> y `encloses` x +-- False +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 6 4 +-- >>> y = bi 4 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- ------ <- [x] +-- ---- <- [y] +-- ========== +-- +-- Examples: +-- +-- >>> x `encloses` y +-- True +-- +-- >>> y `encloses` x +-- False +-- +-- Example data with corresponding diagram: +-- +-- >>> x = bi 2 7 +-- >>> y = bi 1 5 +-- >>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +-- -- <- [x] +-- - <- [y] +-- ========= +-- +-- Examples: +-- +-- >>> x `encloses` y +-- False +-- +-- >>> y `encloses` x +-- False +encloses :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + ComparativePredicateOf2 (i0 a) (i1 a) +encloses = 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 -> 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 :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + 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 :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + 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 :: + (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => + Data.Set.Set IntervalRelation -> + ComparativePredicateOf2 (i0 a) (i1 a) +predicate = unionPredicates . predicates + +-- | The lookup table for the compositions of interval relations. +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], + [p, p, pmo, pmo, pmofd, o, o, ofd, osd, osd, cncr, dso, dsomp], + [p, m, o, f', d', o, f', d', osd, fef, dso, dso, dsomp], + [pmofd, ofd, ofd, d', d', ofd, d', d', cncr, dso, dso, dso, dsomp], + [p, p, pmo, pmo, pmofd, s, s, ses, d, d, dfo, m', p'], + [p, m, o, f', d', s, e, s', d, f, o', m', p'], + [pmofd, ofd, ofd, d', d', ses, s', s', dfo, o', o', m', p'], + [p, p, pmosd, pmosd, full, d, d, dfomp, d, d, dfomp, p', p'], + [p, m, osd, fef, dsomp, d, f, omp, d, f, omp, p', p'], + [pmofd, ofd, cncr, dso, dsomp, dfo, o', omp, dfo, o', omp, p', p'], + [pmofd, ses, dfo, m', p', dfo, m', p', dfo, m', p', p', p'], + [full, dfomp, dfomp, p', p', dfomp, p', p', dfomp, p', p', p', p'] + ] + where + p = [Before] + m = [Meets] + o = [Overlaps] + f' = [FinishedBy] + d' = [Contains] + s = [Starts] + e = [Equals] + s' = [StartedBy] + d = [During] + f = [Finishes] + o' = [OverlappedBy] + m' = [MetBy] + p' = [After] + ses = s ++ e ++ s' + fef = f' ++ e ++ f + pmo = p ++ m ++ o + pmofd = pmo ++ f' ++ d' + osd = o ++ s ++ d + ofd = o ++ f' ++ d' + omp = o' ++ m' ++ p' + dfo = d ++ f ++ o' + dfomp = dfo ++ m' ++ p' + dso = d' ++ s' ++ o' + dsomp = dso ++ m' ++ p' + pmosd = p ++ m ++ osd + cncr = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o' + full = p ++ m ++ cncr ++ m' ++ p' + +-- | 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 :: + (Iv (Interval a), Intervallic i0, Intervallic i1) => i0 a -> i1 a -> IntervalRelation +relate x y = ivRelate (getInterval x) (getInterval y) + +-- | 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) + +-- | Finds the complement of a @'Data.Set.Set' 'IntervalRelation'@. +complement :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation +complement = Data.Set.difference intervalRelations + +-- | 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 + +-- | 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 + +-- | Find the converse of a @'Data.Set.Set' 'IntervalRelation'@. +converse :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation +converse = Data.Set.map converseRelation + +{- Generic interval interfaces -} + +-- | Generic interface for defining relations between abstract representations +-- of intervals, for the purpose of [Allen's interval algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra). +-- +-- In general, these "intervals" need not be representable as temporal intervals with a fixed +-- beginning and ending. Specifically, the relations can be defined to provide temporal reasoning +-- in a qualitative setting, examples of which are in Allen 1983. +-- +-- For intervals that can be cast in canonical form as 'Interval' s with begin and end points, +-- see 'PointedIv' and 'SizedIv'. +-- +-- Instances of 'Iv' must ensure any pair of intervals satisfies exactly one +-- of the thirteen possible 'IntervalRelation' s. +-- +-- When 'iv' is also an instance of 'PointedIv', with @Ord (Point iv)@, +-- the requirement implies +-- +-- @ +-- ivBegin i < ivEnd i +-- @ +-- +-- [Allen 1983](https://dl.acm.org/doi/10.1145/182.358434) +-- defines the 'IntervalRelation' s for such cases, which is provided in this module +-- for the canonical representation @'Interval' a@. +-- +-- ==== __Examples__ +-- +-- The following example is modified from Allen 1983 to demonstrate the algebra used for temporal +-- reasoning in a qualitative setting, for a case where 'iv' does not have points. +-- +-- It represents the temporal logic of the statement +-- +-- > We found the letter during dinner, after we made the decision. +-- +-- >>> :{ +--data GoingsOn = Dinner | FoundLetter | MadeDecision +-- deriving (Show, Eq) +--instance Iv GoingsOn where +-- ivRelate MadeDecision Dinner = Before +-- ivRelate MadeDecision FoundLetter = Before +-- ivRelate FoundLetter Dinner = During +-- ivRelate x y +-- | x == y = Equals +-- | otherwise = converseRelation (ivRelate y x) +-- :} +class Iv iv where + {-# MINIMAL ivRelate | ivBefore, ivMeets, ivOverlaps, ivStarts, ivFinishes, ivDuring, ivEquals #-} + + -- | The 'IntervalRelation' between two intervals. + ivRelate :: iv -> iv -> IntervalRelation + ivRelate x y + | x `ivBefore` y = Before + | x `ivAfter` y = After + | x `ivMeets` y = Meets + | x `ivMetBy` y = MetBy + | x `ivOverlaps` y = Overlaps + | x `ivOverlappedBy` y = OverlappedBy + | x `ivStarts` y = Starts + | x `ivStartedBy` y = StartedBy + | x `ivFinishes` y = Finishes + | x `ivFinishedBy` y = FinishedBy + | x `ivDuring` y = During + | x `ivContains` y = Contains + | otherwise = Equals + + -- \| Is @'ivRelate' x y == Before@? @'ivAfter' = flip 'ivBefore'@. + ivBefore, + ivAfter :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivBefore x = (== Before) . ivRelate x + ivAfter = flip ivBefore + + -- | Is @'ivRelate' x y == Meets@? @'ivMetBy' = flip 'ivMeets'@. + ivMeets, + ivMetBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivMeets x = (== Meets) . ivRelate x + ivMetBy = flip ivMeets + + -- | Is @'ivRelate' x y == Overlaps@? @'ivOverlappedBy' = flip 'ivOverlaps'@. + ivOverlaps, + ivOverlappedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivOverlaps x = (== Overlaps) . ivRelate x + ivOverlappedBy = flip ivOverlaps + + -- | Is @'ivRelate' x y == Starts@? @'ivStartedBy' = flip 'ivStarts'@. + ivStarts, + ivStartedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivStarts x = (== Starts) . ivRelate x + ivStartedBy = flip ivStarts + + -- | Is @'ivRelate' x y == Finishes@? @'ivFinishedBy' = flip 'ivFinishes'@. + ivFinishes, + ivFinishedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivFinishes x = (== Finishes) . ivRelate x + ivFinishedBy = flip ivFinishes + + -- | Is @'ivRelate' x y == During@? @'ivContains' = flip 'ivDuring'@. + ivDuring, + ivContains :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivDuring x = (== During) . ivRelate x + ivContains = flip ivDuring + + -- | Is @'ivRelate' x y == Equals@? + ivEquals :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivEquals x = (== Equals) . ivRelate x + +-- | Class representing intervals that can be cast to and from the canonical +-- representation @'Interval' a@. +-- +-- When 'iv' is also an instance of 'PointedIv', with @Ord (Point iv)@, it should +-- adhere to Allen's construction of the interval algebra for intervals represented +-- by left and right endpoints. See [sections 3 and 4](https://cse.unl.edu/~choueiry/Documents/Allen-CACM1983.pdf) +-- of Allen 1983. +-- +-- Specifically, the requirements for interval relations imply +-- +-- @ +-- ivBegin i < ivEnd i +-- @ +-- +-- This module provides default implementations for methods of 'Iv' in that case. +-- +-- Note @iv@ should not be an instance of @Intervallic@ unless @iv ~ Interval +-- a@, since @Intervallic@ is a class for getting and setting intervals as +-- @Interval a@ in particular. +-- +-- A @Vector@ whose elements are provided in strict ascending order is an example of +-- a type that could implement 'PointedIv' without being equivalent to 'Interval', +-- with @ivBegin = head@ and @ivEnd = last@. +class PointedIv iv where + type Point iv + + -- | Access the left ("begin") and right ("end") endpoints of an interval. + ivBegin, ivEnd :: iv -> Point iv + +-- | The 'SizedIv' typeclass is a generic interface for constructing and +-- manipulating intervals. The class imposes strong requirements on its +-- methods, in large part to ensure the constructors 'ivExpandr' and 'ivExpandl' +-- return "valid" intervals, particularly in the typical case where 'iv' also +-- implements the interval algebra. +-- +-- In all cases, 'ivExpandr' and 'ivExpandl' should preserve the value of the +-- point *not* shifted. That is, +-- +-- @ +-- ivBegin (ivExpandr d i) == ivBegin i +-- ivEnd (ivExpandl d i) == ivEnd i +-- @ +-- +-- In addition, using 'Interval' as example, the following must hold: +-- +-- When @iv@ is @Ord@, for all @i == Interval (b, e)@, +-- +-- @ +-- ivExpandr d i >= i +-- ivExpandl d i <= i +-- @ +-- +-- When @Moment iv@ is @Ord@, +-- +-- @ +-- duration (ivExpandr d i) >= max moment (duration i) +-- duration (ivExpandl d i) >= max moment (duration i) +-- @ +-- +-- In particular, if the duration 'd' by which to expand is less than 'moment', +-- and @'duration' i >= moment@ then these constructors should return the input. +-- +-- @ +-- ivExpandr d i == i +-- ivExpandl d i == i +-- @ +-- +-- When @Moment iv@ also is @Num@, the default 'moment' value is @1@ and in all +-- cases should be positive. +-- +-- @ +-- moment @iv > 0 +-- @ +-- +-- When in addition @Point iv ~ Moment iv@, the class provides a default 'duration' as +-- @duration i = ivEnd i - ivBegin i@. +-- +-- This module enforces @'Point' (Interval a) = a@. However, it need not be +-- that @a ~ Moment iv@. For example @Moment (Interval UTCTime) ~ +-- NominalDiffTime@. +-- +-- ==== SizedIv and the interval algebra +-- +-- When 'iv' is an instance of 'Iv', the methods of this class should ensure +-- the validity of the resulting interval with respect to the interval algebra. +-- For example, when @'Point' iv@ is 'Ord', they must always produce a valid +-- interval 'i' such that @'ivBegin' i < 'ivEnd' i@. +-- +-- In addition, the requirements of 'SizedIv' implementations in the common case +-- where @'Moment' iv@ is 'Num' and 'Ord' require the constructors to produce intervals +-- with 'duration' of at least 'moment'. +-- +-- In order to preserve the properties above, @ivExpandr, ivExpandl@ will not want to assume +-- validity of the input interval. In other words, @'ivExpandr' d i@ need not be the +-- identity when @d < 'moment'@ since it will need to ensure the result is a valid interval +-- even if 'i' is not. +-- +-- These two methods can therefore be used as constructors for valid intervals. +class (PointedIv iv) => SizedIv iv where + -- | Type of 'moment'. + type Moment iv + + -- | The smallest duration for an 'iv'. When 'Moment iv' is an instance of + -- 'Num', the default is 1. If @'Moment' iv@ is @Ord@ and @Num@, @'moment' > 0@ + -- is required. + moment :: Moment iv + + -- | The duration of an 'iv'. When @Moment iv ~ Point iv@ and @Point iv@ is + -- @Num@ this defaults to @ivEnd i - ivBegin i@. + duration :: iv -> Moment iv + + -- | Resize @iv@ by expanding to the "left" or to the "right" by some + -- duration. If @iv@ implements the interval algebra via @Iv@, these + -- methods must produce valid intervals regardless of the validity of the input + -- and thus serve as constructors for intervals. See also 'beginerval', + -- 'endverval', 'safeInterval' and related. + -- + -- See the class documentation for details requirements. + -- + -- >>> ivExpandr 1 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 2) + -- True + -- >>> ivExpandr 0 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 1) + -- True + -- >>> ivExpandl 1 (safeInterval (0, 1) :: Interval Int) == safeInterval (-1, 1) + -- True + -- >>> ivExpandl 0 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 1) + -- True + ivExpandr, ivExpandl :: Moment iv -> iv -> iv + + default moment :: (Num (Moment iv)) => Moment iv + moment = 1 + + default duration :: (Point iv ~ Moment iv, Num (Point iv)) => iv -> Moment iv + duration i = ivEnd i - ivBegin i + +-- | 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. +-- +-- >>> iv2to4 = safeInterval (2::Int, 4) +-- >>> iv2to4' = expand 0 0 iv2to4 +-- >>> iv1to5 = expand 1 1 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv2to4' +-- (2, 4) +-- +-- >>> iv1to5 +-- (1, 5) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv1to5, "iv1to5")] [] +-- -- <- [iv2to4] +-- ---- <- [iv1to5] +-- ===== +expand :: + (SizedIv (Interval a), Intervallic i) => + -- | duration to subtract from the 'begin' + Moment (Interval a) -> + -- | duration to add to the 'end' + Moment (Interval a) -> + i a -> + i a +expand l r = expandl l . expandr r + +-- | Expands an @i a@ to the "left". +-- +-- >>> iv2to4 = (safeInterval (2::Int, 4::Int)) +-- >>> iv0to4 = expandl 2 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv0to4 +-- (0, 4) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv0to4, "iv0to4")] [] +-- -- <- [iv2to4] +-- ---- <- [iv0to4] +-- ==== +expandl :: (SizedIv (Interval a), Intervallic i) => Moment (Interval a) -> i a -> i a +expandl l i = setInterval i $ ivExpandl l $ getInterval i + +-- | Expands an @i a@ to the "right". +-- +-- >>> iv2to4 = (safeInterval (2::Int, 4::Int)) +-- >>> iv2to6 = expandr 2 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv2to6 +-- (2, 6) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv2to6, "iv2to6")] [] +-- -- <- [iv2to4] +-- ---- <- [iv2to6] +-- ====== +expandr :: (SizedIv (Interval a), Intervallic i) => Moment (Interval a) -> i a -> i a +expandr r i = setInterval i $ ivExpandr r $ getInterval i + +-- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding @max +-- 'moment' dur@ to @x@ as the 'end'. For the 'SizedIv' instances this +-- module exports, 'beginerval' is the same as 'interval'. However, it is defined +-- separately since 'beginerval' will /always/ have this behavior whereas +-- 'interval' behavior might differ by implementation. +-- +-- >>> beginerval (0::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (1::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (2::Int) (0::Int) +-- (0, 2) +beginerval :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to add to the 'begin' + Moment (Interval a) -> + -- | the 'begin' point of the 'Interval' + a -> + Interval a +beginerval dur x = ivExpandr dur $ Interval (x, x) + +-- | A synonym for `beginerval` +bi :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to add to the 'begin' + Moment (Interval a) -> + -- | the 'begin' point of the 'Interval' + a -> + Interval a +bi = beginerval + +-- | Safely creates an 'Interval a' using @x@ as the 'end' and adding @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 :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to subtract from the 'end' + Moment (Interval a) -> + -- | the 'end' point of the 'Interval' + a -> + Interval a +enderval dur x = ivExpandl dur $ Interval (x, x) + +-- | A synonym for `enderval` +ei :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to subtract from the 'end' + Moment (Interval a) -> + -- | the 'end' point of the 'Interval' + a -> + Interval a +ei = enderval + +-- | Safely creates an @'Interval'@ from a pair of endpoints, +-- expanding from the left endpoint if necessary to create a valid interval +-- according to the rules of 'SizedIv'. This function simply wraps +-- 'ivExpandr'. +-- +-- >>> safeInterval (4, 5 ::Int) +-- (4, 5) +-- >>> safeInterval (4, 3 :: Int) +-- (4, 5) +safeInterval :: + forall a. + (SizedIv (Interval a), Ord (Moment (Interval a))) => + (a, a) -> + Interval a +safeInterval (b, e) + | duration i < m = ivExpandr m $ Interval (b, b) + | otherwise = i + where + i = Interval (b, e) + m = moment @(Interval a) + +-- | A synonym for `safeInterval` +si :: + (SizedIv (Interval a), Ord (Moment (Interval a))) => + (a, a) -> + Interval a +si = safeInterval + +-- | Creates a new 'Interval' from the 'end' of another. +beginervalFromEnd :: + (SizedIv (Interval a), Intervallic i) => + -- | @dur@ation to add to the 'end' + Moment (Interval a) -> + -- | the @i a@ from which to get the 'end' + i a -> + Interval a +beginervalFromEnd d i = beginerval d (end i) + +-- | Creates a new 'Interval' from the 'begin' of another. +endervalFromBegin :: + (SizedIv (Interval a), Intervallic i) => + -- | @dur@ation to subtract from the 'begin' + Moment (Interval a) -> + -- | the @i a@ from which to get the 'begin' + i a -> + Interval a +endervalFromBegin d i = enderval d (begin i) + +-- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@ +-- +-- >>> beginervalMoment (10 :: Int) +-- (10, 11) +beginervalMoment :: forall a. (SizedIv (Interval a)) => a -> Interval a +beginervalMoment = beginerval (moment @(Interval a)) + +-- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ +-- +-- >>> endervalMoment (10 :: Int) +-- (9, 10) +endervalMoment :: forall a. (SizedIv (Interval a)) => a -> Interval a +endervalMoment = enderval (moment @(Interval a)) + +-- | Creates a new @Interval@ spanning the extent x and y. +-- +-- >>> extenterval (Interval (0, 1)) (Interval (9, 10)) +-- (0, 10) +extenterval :: (SizedIv (Interval a), Ord a, Intervallic i) => 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) + +-- | Modifies the endpoints of second argument's interval by taking the difference +-- from the first's input's 'begin'. +-- +-- Example data with corresponding diagram: +-- +-- >>> a = bi 3 2 :: Interval Int +-- >>> a +-- (2, 5) +-- >>> x = bi 3 7 :: Interval Int +-- >>> x +-- (7, 10) +-- >>> y = bi 4 9 :: Interval Int +-- >>> y +-- (9, 13) +-- >>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] +-- --- <- [a] +-- --- <- [x] +-- ---- <- [y] +-- ============= +-- +-- Examples: +-- +-- >>> x' = shiftFromBegin a x +-- >>> x' +-- (5, 8) +-- >>> y' = shiftFromBegin a y +-- >>> y' +-- (7, 11) +-- >>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] +-- --- <- [x'] +-- ---- <- [y'] +-- =========== +shiftFromBegin :: + (Num a, SizedIv (Interval a), Intervallic i1, Intervallic i0) => + i0 a -> + i1 a -> + i1 a +shiftFromBegin i = imapStrictMonotone (\x -> x - begin i) + +-- | Modifies the endpoints of second argument's interval by taking the difference +-- from the first's input's 'end'. +-- +-- Example data with corresponding diagram: +-- +-- >>> a = bi 3 2 :: Interval Int +-- >>> a +-- (2, 5) +-- >>> x = bi 3 7 :: Interval Int +-- >>> x +-- (7, 10) +-- >>> y = bi 4 9 :: Interval Int +-- >>> y +-- (9, 13) +-- >>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] +-- --- <- [a] +-- --- <- [x] +-- ---- <- [y] +-- ============= +-- +-- Examples: +-- +-- >>> x' = shiftFromEnd a x +-- >>> x' +-- (2, 5) +-- >>> y' = shiftFromEnd a y +-- >>> y' +-- (4, 8) +-- >>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] +-- --- <- [x'] +-- ---- <- [y'] +-- ======== + +shiftFromEnd :: + (Num a, SizedIv (Interval a), Intervallic i1, Intervallic i0) => + i0 a -> + i1 a -> + i1 a +shiftFromEnd i = imapStrictMonotone (\x -> x - end i) + +-- | Converts an @i a@ to an @i Int@ via @fromEnum@. This assumes the provided +-- @fromEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@ with values @x, y@, then @x < y@ implies @fromEnum x < fromEnum y@, so +-- long as the latter is well-defined. +fromEnumInterval :: (Enum a, Intervallic i) => i a -> i Int +fromEnumInterval = imapStrictMonotone fromEnum + +-- | Converts an @i Int@ to an @i a@ via @toEnum@. This assumes the provided +-- @toEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@, then for @Int@ values @x, y@ it holds that @x < y@ implies @toEnum x +-- < toEnum y@. +toEnumInterval :: (Enum a, Intervallic i) => i Int -> i a +toEnumInterval = imapStrictMonotone toEnum + +-- | Changes the duration of an 'Intervallic' value to a moment starting at the +-- 'begin' of the interval. Uses 'beginervalMoment'. +-- +-- >>> momentize (Interval (6, 10)) +-- (6, 7) +momentize :: + forall i a. (SizedIv (Interval a), Intervallic i) => i a -> i a +momentize i = setInterval i $ beginervalMoment $ begin i + +{- +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) + +{- Common instance helpers -} + +-- | Internal. Helper for SizedIv constructor implementations +-- defined in this module, so as to ensure the class properties. +ivExpandrI :: + (Ord b) => + -- | 'moment' value to be passed here. + b -> + -- | 'duration' + (a -> a -> b) -> + -- | function for adding an amount of moments to a point. + -- It must always satisfy addFun (dFun x y) y == x + (b -> a -> a) -> + -- | duration by which to expand. + b -> + Interval a -> + Interval a +ivExpandrI mom dFun addFun d (Interval (b, e)) + | d < mom = Interval (b, addFun (max (dFun e b) mom) b) + | otherwise = Interval (b, addFun d e) + +ivExpandlI :: + (Ord b) => + -- | 'moment' value to be passed here. + b -> + -- | 'duration' + (a -> a -> b) -> + -- | function for subtracting a amount of moments to a point. + -- It must always satisfy subFun (dFun x y) x == y + (b -> a -> a) -> + -- | duration by which to expand. + b -> + Interval a -> + Interval a +ivExpandlI mom dFun subFun d (Interval (b, e)) + | d < mom = Interval (subFun (max (dFun e b) mom) e, e) + | otherwise = Interval (subFun d b, e) + +{- Instances -} + +-- | Imposes a total ordering on @'Interval' a@ based on first ordering the +-- 'begin's then the 'end's. +instance (Ord a) => Ord (Interval a) where + (Interval pts1) <= (Interval pts2) = pts1 <= pts2 + (Interval pts1) < (Interval pts2) = pts1 < pts2 + +instance Intervallic Interval where + getInterval = id + setInterval _ x = x + +instance PointedIv (Interval a) where + type Point (Interval a) = a + + ivBegin (Interval (b, _)) = b + ivEnd (Interval (_, e)) = e + +-- | Implements the interval algebra for intervals represented as left and right endpoints, +-- with points in a totally ordered set, as prescribed in +-- [Allen 1983](https://dl.acm.org/doi/10.1145/182.358434). +instance (Ord a) => Iv (Interval a) where + ivBefore x y = ivEnd x < ivBegin y + ivMeets x y = ivEnd x == ivBegin y + ivOverlaps x y = ivBegin x < ivBegin y && ivEnd x < ivEnd y && ivEnd x > ivBegin y + ivStarts x y = ivBegin x == ivBegin y && ivEnd x < ivEnd y + ivFinishes x y = ivBegin x > ivBegin y && ivEnd x == ivEnd y + ivDuring x y = ivBegin x > ivBegin y && ivEnd x < ivEnd y + ivEquals x y = ivBegin x == ivBegin y && ivEnd x == ivEnd y + +-- TODO: Consider whether blanket instance for +-- Num a => SizedIv (Interval a) is good. + +instance SizedIv (Interval Int) where + type Moment (Interval Int) = Int + ivExpandr = ivExpandrI (moment @(Interval Int)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Int)) (-) (flip (-)) + +instance SizedIv (Interval Integer) where + type Moment (Interval Integer) = Integer + ivExpandr = ivExpandrI (moment @(Interval Integer)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Integer)) (-) (flip (-)) + +instance SizedIv (Interval Double) where + type Moment (Interval Double) = Double + ivExpandr = ivExpandrI (moment @(Interval Double)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Double)) (-) (flip (-)) + +instance SizedIv (Interval DT.Day) where + type Moment (Interval DT.Day) = Integer + duration (Interval (b, e)) = diffDays e b + moment = 1 + ivExpandr = ivExpandrI (moment @(Interval DT.Day)) diffDays addDays + ivExpandl = ivExpandlI (moment @(Interval DT.Day)) diffDays (\d -> addDays (-d)) + +-- | Note this instance changes the @moment@ to 1 'Pico' second, not 1 second +-- as would be the case if the default were used. +instance SizedIv (Interval DT.UTCTime) where + type Moment (Interval DT.UTCTime) = NominalDiffTime + moment = toEnum 1 + duration (Interval (b, e)) = diffUTCTime e b + ivExpandr = ivExpandrI (moment @(Interval DT.UTCTime)) diffUTCTime addUTCTime + ivExpandl = ivExpandlI (moment @(Interval DT.UTCTime)) diffUTCTime (\d -> addUTCTime (-d)) diff --git a/src/IntervalAlgebra/IntervalDiagram.hs b/src/IntervalAlgebra/IntervalDiagram.hs --- a/src/IntervalAlgebra/IntervalDiagram.hs +++ b/src/IntervalAlgebra/IntervalDiagram.hs @@ -1,4 +1,10 @@ {-| +Module : IntervalAlgebra.IntervalDiagram +Description : Tools for visualizing intervals +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 +License : BSD3 +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 This module provides functions for creating diagrams of intervals as text. For example, @@ -11,13 +17,6 @@ ------ ============================== ->>> let ref = bi 30 (fromGregorian 2022 5 6) ->>> let ivs = [ bi 2 (fromGregorian 2022 5 6), bi 5 (fromGregorian 2022 5 10)] ->>> pretty $ simpleIntervalDiagram ref ivs --- - ----- -============================== - Such diagrams are useful for documentation, examples, and learning to reason with the interval algebra. @@ -81,7 +80,7 @@ -- $setup -- >>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings --- >>> import IntervalAlgebra.IntervalUtilities (gapsWithin) +-- >>> import IntervalAlgebra.IntervalUtilities -- >>> import Data.Time {- @@ -118,7 +117,7 @@ getInterval (MkIntervalText x) = getInterval x setInterval (MkIntervalText x) i = MkIntervalText $ setInterval x i -instance (Enum b, IntervalSizeable a b) => Pretty (IntervalText a) where +instance (Enum (Moment (Interval a)), SizedIv (Interval a)) => Pretty (IntervalText a) where pretty (MkIntervalText x) = pretty $ replicate (fromEnum (duration i)) c where c = getPairData x @@ -507,7 +506,7 @@ | IntervalLineError IntervalTextLineParseError deriving (Eq, Show) -instance (IntervalSizeable a b) => Pretty (IntervalDiagram a) where +instance (SizedIv (Interval a)) => Pretty (IntervalDiagram a) where pretty (MkIntervalDiagram _ axis ivs opts) = do -- Create a list of pretty IntervalLines @@ -527,7 +526,7 @@ -- See use of makeIntervalLine in parseIntervalTextLine. -- This why the intervalLineEnd function is used to determine -- the end of the intervals in a line. - let labelIndents = fmap (diff refDur . intervalLineEnd) ivs + let labelIndents = fmap ((-) refDur . intervalLineEnd) ivs -- Create a list of the line label docs let labelLines = @@ -555,7 +554,7 @@ then emptyDoc else space <> pretty ("<-" :: Text) <> space <> pretty t -instance (IntervalSizeable a b) => +instance (SizedIv (Interval a)) => Pretty (Either IntervalDiagramParseError (IntervalDiagram a)) where pretty (Left e) = pretty $ show e pretty (Right d) = pretty d @@ -623,7 +622,7 @@ -} parseIntervalDiagram - :: (Ord a, IntervalSizeable a b, Enum b) + :: (Ord a, SizedIv (Interval a), Enum a, Num a, Enum (Moment (Interval a))) => IntervalDiagramOptions -- ^ Document options (see 'IntervalDiagramOptions') -> [(Int, Char)] @@ -670,7 +669,7 @@ where extendsBeyond = before <|> meets <|> overlaps <|> overlappedBy <|> metBy <|> after - checkAvailableChar (AvailablePerLine i _) = fromEnum (duration ref) > i + checkAvailableChar (AvailablePerLine i _) = fromEnum (duration $ getInterval ref) > i checkAvailableChar Unbounded = True {- Shifts the endpoints of an interval to be referenced from another interval, @@ -704,16 +703,9 @@ ----- ------ ============================== - ->>> pretty $ simpleIntervalDiagram ref (fromMaybe [] (gapsWithin ref ivs)) - -------- - - - -------- -============================== - -} simpleIntervalDiagram - :: (Ord a, IntervalSizeable a b, Intervallic i, Enum b) + :: (Ord a, SizedIv (Interval a), Intervallic i, Enum a, Num a, Enum (Moment (Interval a))) => i a -- ^ The axis interval -> [i a] -- ^ List of intervals to be printed one per line -> Either IntervalDiagramParseError (IntervalDiagram a) @@ -734,11 +726,11 @@ and such that each row displays each interval provided in the intervals list and label pair. ->>> x1 = si (1, 5) ->>> x2 = si (7, 10) ->>> x3 = si (13, 15) +>>> x1 = beginerval 4 1 +>>> x2 = beginerval 3 7 +>>> x3 = beginerval 2 13 >>> ivs = [x1, x2, x3] ->>> gaps = [si (5, 7), si (10, 13)] +>>> gaps = [beginerval 2 5, beginerval 3 10] >>> :{ pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gaps, "gaps")] :} @@ -764,7 +756,7 @@ IntervalsExtendBeyondAxis -} standardExampleDiagram - :: (Num a, Ord a, Enum b, IntervalSizeable a b) + :: (Num a, Enum a, Ord a, Enum (Moment (Interval a)), Ord (Moment (Interval a)), SizedIv (Interval a)) => [(Interval a, String)] -> [([Interval a], String)] -> Either IntervalDiagramParseError (IntervalDiagram a) diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -1,132 +1,71 @@ {-| Module : Interval Algebra Utilities Description : Functions for operating on containers of Intervals. -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 Stability : experimental -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module IntervalAlgebra.IntervalUtilities ( -- * Fold over sequential intervals combineIntervals - , combineIntervalsL , combineIntervalsFromSorted - , combineIntervalsFromSortedL , rangeInterval - , gaps - , gapsL - , gapsWithin - -- * Operations on Meeting sequences of paired intervals - , foldMeetingSafe - , formMeetingSequence - - -- * Withering functions - - -- ** Clear containers based on predicate - , nothingIf - , nothingIfNone - , nothingIfAny - , nothingIfAll - - -- ** Filter containers based on predicate - , filterBefore - , filterMeets - , filterOverlaps - , filterFinishedBy - , filterContains - , filterStarts - , filterEquals - , filterStartedBy - , filterDuring - , filterFinishes - , filterOverlappedBy - , filterMetBy - , filterAfter - , filterDisjoint - , filterNotDisjoint - , filterConcur - , filterWithin - , filterEncloses - , filterEnclosedBy + -- * Combining intervals + , (><) + , (.+.) -- * Functions for manipulating intervals , lookback , lookahead -- * Gaps - , makeGapsWithinPredicate + , gaps , pairGaps - , anyGapsWithinAtLeastDuration - , allGapsWithinLessThanDuration -- * Misc utilities , relations - , relationsL , intersect , clip , durations ) where -import safe Control.Applicative (Applicative (pure), - liftA2, (<$>), (<*>)) +import Control.Applicative (Applicative (pure), liftA2, + (<$>), (<*>)) import qualified Control.Foldl as L -import safe Control.Monad (Functor (fmap)) -import safe Data.Bool (Bool (..), not, otherwise, - (&&), (||)) -import safe Data.Eq (Eq ((==))) -import safe Data.Foldable (Foldable (foldl', foldr, null, toList), - all, any, or) -import safe Data.Function (flip, ($), (.)) -import safe Data.List (map, reverse, sortOn) -import safe Data.Maybe (Maybe (..), maybe, - maybeToList) -import safe Data.Monoid (Monoid (mempty)) -import safe Data.Ord (Ord (max, min), (<), (>=)) -import safe Data.Semigroup (Semigroup ((<>))) -import safe Data.Traversable (Traversable (sequenceA)) -import safe Data.Tuple (fst, uncurry) -import safe GHC.Int (Int) -import safe GHC.Show (Show) -import safe IntervalAlgebra.Core (ComparativePredicateOf1, - ComparativePredicateOf2, - Interval, - IntervalCombinable ((><)), - IntervalRelation (..), - IntervalSizeable (diff, duration), - Intervallic (..), after, - before, begin, beginerval, - beginervalFromEnd, bi, - concur, contains, - disjoint, during, - enclosedBy, encloses, end, - enderval, - endervalFromBegin, equals, - extenterval, finishedBy, - finishes, meets, metBy, - notDisjoint, overlappedBy, - overlaps, relate, - startedBy, starts, within, - (<|>)) -import safe IntervalAlgebra.PairedInterval (PairedInterval, - equalPairData, - getPairData, - makePairedInterval) -import safe Safe (headMay, initSafe, - lastMay, tailSafe) -import safe Witherable (Filterable (filter), - Witherable (..), - catMaybes, mapMaybe) +import Control.Monad (Functor (fmap)) +import Data.Bool (Bool (..), not, otherwise, + (&&), (||)) +import Data.Eq (Eq ((==))) +import Data.Foldable (Foldable (foldl', foldr, null, toList), + all, any, or) +import Data.Function (flip, ($), (.)) +import Data.List (map, reverse, sortOn) +import Data.Maybe (Maybe (..), mapMaybe, maybe, + maybeToList) +import Data.Monoid (Monoid (mempty)) +import Data.Ord (Ord (max, min), (<), (>=)) +import Data.Semigroup (Semigroup ((<>))) +import Data.Traversable (Traversable (sequenceA)) +import Data.Tuple (fst, uncurry) +import GHC.Int (Int) +import GHC.Show (Show) +import IntervalAlgebra.Core +import IntervalAlgebra.PairedInterval (PairedInterval, equalPairData, + getPairData, + makePairedInterval) {- $setup >>> import GHC.List ( (++), zip ) @@ -138,40 +77,12 @@ -- Unexported utilties used in functions below -- ------------------------------------------------- --- An internal utility function for creating a @Fold@ that maps over a structure --- by consecutive pairs into a new structure. -makeFolder :: (Monoid (m b), Applicative m) => (a -> a -> b) -> L.Fold a (m b) -makeFolder f = L.Fold step begin done - where - begin = (mempty, Nothing) - step (fs, Nothing) y = (fs, Just y) - step (fs, Just x ) y = (fs <> pure (f x y), Just y) - done (fs, _) = fs --- | Create a predicate function that checks whether within a provided spanning --- interval, are there (e.g. any, all) gaps of (e.g. <, <=, >=, >) a specified --- duration among the input intervals? -makeGapsWithinPredicate - :: ( Monoid (t (Interval a)) - , Monoid (t (Maybe (Interval a))) - , Applicative t - , Witherable.Witherable t - , IntervalSizeable a b - , Intervallic i0 - , IntervalCombinable i1 a - ) - => ((b -> Bool) -> t b -> Bool) - -> (b -> b -> Bool) - -> (b -> i0 a -> t (i1 a) -> Bool) -makeGapsWithinPredicate f op gapDuration interval l = - maybe False (f (`op` gapDuration) . durations) (gapsWithin interval l) - --- | Gets the durations of gaps (via 'IntervalAlgebra.(><)') between all pairs --- of the input. +-- | Gets the durations of gaps (via '(><)') between all pairs of the input. pairGaps - :: (Intervallic i, IntervalSizeable a b, IntervalCombinable i a) + :: (Intervallic i, SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => [i a] - -> [Maybe b] + -> [Maybe (Moment (Interval a))] pairGaps es = fmap (fmap duration . uncurry (><)) (pairs es) -- Generate all pair-wise combinations of a single list. -- pairs :: [a] -> [(a, a)] @@ -189,8 +100,8 @@ -- >>> lookback 4 (beginerval 10 (1 :: Int)) -- (-3, 1) lookback - :: (Intervallic i, IntervalSizeable a b) - => b -- ^ lookback duration + :: (Intervallic i, SizedIv (Interval a), Ord (Moment (Interval a))) + => Moment (Interval a) -- ^ lookback duration -> i a -> Interval a lookback d x = enderval d (begin x) @@ -201,121 +112,47 @@ -- >>> lookahead 4 (beginerval 1 (1 :: Int)) -- (2, 6) lookahead - :: (Intervallic i, IntervalSizeable a b) - => b -- ^ lookahead duration + :: (Intervallic i, SizedIv (Interval a), Ord (Moment (Interval a))) + => Moment (Interval a) -- ^ lookahead duration -> i a -> Interval a lookahead d x = beginerval d (end x) --- | Within a provided spanning interval, are there any gaps of at least the --- specified duration among the input intervals? -anyGapsWithinAtLeastDuration - :: ( IntervalSizeable a b - , Intervallic i0 - , IntervalCombinable i1 a - , Monoid (t (Interval a)) - , Monoid (t (Maybe (Interval a))) - , Applicative t - , Witherable.Witherable t - ) - => b -- ^ duration of gap - -> i0 a -- ^ within this interval - -> t (i1 a) - -> Bool -anyGapsWithinAtLeastDuration = makeGapsWithinPredicate any (>=) - --- | Within a provided spanning interval, are all gaps less than the specified --- duration among the input intervals? --- --- >>> allGapsWithinLessThanDuration 30 (beginerval 100 (0::Int)) [beginerval 5 (-1), beginerval 99 10] --- True -allGapsWithinLessThanDuration - :: ( IntervalSizeable a b - , Intervallic i0 - , IntervalCombinable i1 a - , Monoid (t (Interval a)) - , Monoid (t (Maybe (Interval a))) - , Applicative t - , Witherable.Witherable t - ) - => b -- ^ duration of gap - -> i0 a -- ^ within this interval - -> t (i1 a) - -> Bool -allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<) - - --- Used to combine two lists by combining the last element of @x@ and the first --- element of @y@ by @f@. The combining function @f@ will generally return a --- singleton list in the case that the last of x and head of y can be combined --- or a two element list in the case they cannot. -listCombiner - :: (Maybe a -> Maybe a -> [a]) -- ^ f - -> [a] -- ^ x - -> [a] -- ^ y - -> [a] -listCombiner f x y = initSafe x <> f (lastMay x) (headMay y) <> tailSafe y -{-# INLINABLE listCombiner #-} - --- | Returns a list of the 'IntervalRelation' between each consecutive pair --- of intervals. This is just a specialized 'relations' which returns a list. --- --- >>> relationsL [bi 1 0, bi 1 1] --- [Meets] --- -relationsL - :: (Foldable f, Ord a, Intervallic i) => f (i a) -> [IntervalRelation] -relationsL = relations - --- | A generic form of 'relations' which can output any 'Applicative' and --- 'Monoid' structure. +-- | Returns a list of the 'IntervalRelation' between each consecutive pair of @i a@. -- --- >>> (relations [bi 1 0,bi 1 1]) :: [IntervalRelation] +-- >>> relations [beginerval 1 0, beginerval 1 1] -- [Meets] --- --- +-- >>> relations [beginerval 1 0, beginerval 1 1, beginerval 2 1] +-- [Meets,Starts] +-- >>> relations [beginerval 1 0] +-- [] relations - :: ( Foldable f - , Applicative m - , Ord a - , Intervallic i - , Monoid (m IntervalRelation) + :: ( Intervallic i + , Iv (Interval a) ) - => f (i a) - -> m IntervalRelation -relations = L.fold (makeFolder relate) -{-# INLINABLE relations #-} + => [i a] + -> [IntervalRelation] +relations [] = [] +relations [x] = [] +relations (x : y : xs) = relate x y : relations (y : xs) --- | Forms a 'Just' new interval from the intersection of two intervals, --- provided the intervals are not disjoint. +-- | Forms 'Just' a new interval from the intersection of two intervals, +-- provided the intervals are not 'disjoint'. -- -- >>> intersect (bi 5 0) (bi 2 3) -- Just (3, 5) -- intersect - :: (Intervallic i, IntervalSizeable a b) => i a -> i a -> Maybe (Interval a) + :: (Intervallic i, SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => i a -> i a -> Maybe (Interval a) intersect x y | disjoint x y = Nothing - | otherwise = Just $ beginerval (diff e b) b + | otherwise = Just $ safeInterval (b, e) where b = max (begin x) (begin y) e = min (end x) (end y) --- Internal function which folds over a structure by consecutive pairs, returing --- gaps between each pair (@Nothing@ if no such gap exists). -gapsM - :: ( IntervalCombinable i a - , Traversable f - , Monoid (f (Maybe (Interval a))) - , Applicative f - ) - => f (i a) - -> f (Maybe (Interval a)) -gapsM = L.fold (makeFolder (\i j -> getInterval i >< getInterval j)) -{-# INLINABLE gapsM #-} - -{- | Returns a @Maybe@ container of intervals consisting of the gaps between -intervals in the input. __To work properly, the input should be sorted.__ See -'gapsL' for a version that always returns a list. +{- | Returns a list of intervals consisting of the gaps between +consecutive intervals in the input, after they have been sorted by +interval ordering. >>> x1 = bi 4 1 >>> x2 = bi 4 8 @@ -324,7 +161,7 @@ >>> ivs [(1, 5),(8, 12),(11, 14)] >>> gaps ivs -Nothing +[(5, 8)] >>> pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [] ---- <- [x1] ---- <- [x2] @@ -339,64 +176,10 @@ [(1, 5),(7, 10),(13, 15)] >>> gapIvs = gaps ivs >>> gapIvs -Just [(5, 7),(10, 13)] ->>> :{ -case gapIvs of - Nothing -> pretty "" - (Just x) -> pretty $ - standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(x, "gapIvs")] -:} - ---- <- [x1] - --- <- [x2] - -- <- [x3] - -- --- <- [gapIvs] -=============== --} -gaps - :: ( IntervalCombinable i a - , Traversable f - , Monoid (f (Maybe (Interval a))) - , Applicative f - ) - => f (i a) - -> Maybe (f (Interval a)) -gaps = sequenceA . gapsM -{-# INLINABLE gaps #-} - -{- | Returns a (possibly empty) list of intervals consisting of the gaps between -intervals in the input container. -__To work properly, the input should be sorted.__ This version outputs a list. -See 'gaps' for a version that lifts the result to same input structure @f@. - ->>> x1 = bi 4 1 ->>> x2 = bi 4 8 ->>> x3 = bi 3 11 ->>> ivs = [x1, x2, x3] ->>> ivs -[(1, 5),(8, 12),(11, 14)] ->>> gapIvs = gapsL ivs ->>> gapIvs -[] ->>> :{ -pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [] -:} - ---- <- [x1] - ---- <- [x2] - --- <- [x3] -============== - ->>> x1 = bi 4 1 ->>> x2 = bi 3 7 ->>> x3 = bi 2 13 ->>> ivs = [x1, x2, x3] ->>> ivs -[(1, 5),(7, 10),(13, 15)] ->>> gapIvs = gapsL ivs ->>> gapIvs [(5, 7),(10, 13)] >>> :{ -pretty $ - standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gapIvs, "gapIvs")] + pretty $ + standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gapIvs, "gapIvs")] :} ---- <- [x1] --- <- [x2] @@ -404,24 +187,26 @@ -- --- <- [gapIvs] =============== -} -gapsL - :: ( IntervalCombinable i a - , Applicative f - , Monoid (f (Maybe (Interval a))) - , Traversable f - ) - => f (i a) - -> [Interval a] -gapsL x = maybe [] toList (gaps x) -{-# INLINABLE gapsL #-} +gaps :: ( + SizedIv (Interval a), + Intervallic i, + Ord a, + Ord (Moment (Interval a)) + ) => + [i a] -> + [Interval a] +gaps xs = mapMaybe (uncurry (><)) $ pair $ sortOn getInterval xs + where pair [] = [] + pair [x] = [] + pair (x : y : ys) = (x, y) : pair (y : ys) -- | Returns the 'duration' of each 'Intervallic i a' in the 'Functor' @f@. -- -- >>> durations [bi 9 1, bi 10 2, bi 1 5 :: Interval Int] -- [9,10,1] -- -durations :: (Functor f, Intervallic i, IntervalSizeable a b) => f (i a) -> f b -durations = fmap duration +durations :: (Functor f, Intervallic i, SizedIv (Interval a)) => f (i a) -> f (Moment (Interval a)) +durations = fmap (duration . getInterval) -- | In the case that x y are not disjoint, clips y to the extent of x. -- @@ -432,13 +217,13 @@ -- Nothing -- clip - :: (Intervallic i0, Intervallic i1, IntervalSizeable a b) + :: (Intervallic i0, Intervallic i1, SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => i0 a -> i1 a -> Maybe (Interval a) clip x y - | overlaps x y = Just $ enderval (diff (end x) (begin y)) (end x) - | overlappedBy x y = Just $ beginerval (diff (end y) (begin x)) (begin x) + | overlaps x y = Just $ safeInterval (begin y, end x) + | overlappedBy x y = Just $ safeInterval (begin x, end y) | jx x y = Just (getInterval x) | jy x y = Just (getInterval y) | otherwise = Nothing {- disjoint x y case -} @@ -447,94 +232,6 @@ jx = starts <|> during <|> finishes {-# INLINABLE clip #-} --- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are /not/ disjoint --- from @i@. Intervals that 'overlaps' or are 'overlappedBy' @i@ are 'clip'ped --- to @i@, so that all the intervals are 'within' @i@. If all of the input intervals --- are disjoint from the focal interval or if the input is empty, then 'Nothing' --- is returned. When there are no gaps among the concurring intervals, then --- @Just mempty@ (e.g. @Just []@) is returned. --- --- >>> gapsWithin (bi 9 1) [bi 5 0, bi 2 7, bi 3 12] --- Just [(5, 7),(9, 10)] --- -gapsWithin - :: ( Applicative f - , Witherable f - , Monoid (f (Interval a)) - , Monoid (f (Maybe (Interval a))) - , IntervalSizeable a b - , Intervallic i0 - , IntervalCombinable i1 a - ) - => i0 a -- ^ i - -> f (i1 a) -- ^ x - -> Maybe (f (Interval a)) -gapsWithin i x | null ivs = Nothing - | otherwise = Just res - where - s = pure (endervalFromBegin 0 i) - e = pure (beginervalFromEnd 0 i) - ivs = mapMaybe (clip i) (filterNotDisjoint i x) - res = catMaybes $ gapsM (s <> ivs <> e) -{-# INLINABLE gapsWithin #-} - -{- | Returns a container of intervals where any intervals that meet or share -support are combined into one interval. This functions sorts the input intervals -first. See @combineIntervalsL@ for a version that works only on lists. If you -know the input intervals are sorted, use @combineIntervalsFromSorted@ instead. - ->>> x1 = bi 10 0 ->>> x2 = bi 5 2 ->>> x3 = bi 2 10 ->>> x4 = bi 2 13 ->>> ivs = [x1, x2, x3, x4] ->>> ivs -[(0, 10),(2, 7),(10, 12),(13, 15)] ->>> xComb = combineIntervals ivs ->>> xComb -[(0, 12),(13, 15)] ->>> :{ -pretty $ - standardExampleDiagram - (zip ivs ["x1", "x2", "x3", "x4"]) - [(xComb, "xComb")] -:} ----------- <- [x1] - ----- <- [x2] - -- <- [x3] - -- <- [x4] ------------- -- <- [xComb] -=============== --} -combineIntervals - :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) - => f (i a) - -> f (Interval a) -combineIntervals = combineIntervalsWith combineIntervalsL - -{- | Returns a container of intervals where any intervals that meet or share -support are combined into one interval. The condition is applied cumulatively, -from left to right, so -__to work properly, the input list should be sorted in increasing order__. See -@combineIntervalsLFromSorted@ for a version that works only on lists. - ->>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 2 10, bi 2 13] -[(0, 12),(13, 15)] --} -combineIntervalsFromSorted - :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) - => f (i a) - -> f (Interval a) -combineIntervalsFromSorted = combineIntervalsWith combineIntervalsFromSortedL - --- | Unexported helper -combineIntervalsWith - :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) - => ([i a] -> [Interval a]) - -> f (i a) - -> f (Interval a) -combineIntervalsWith f x = foldl' (\x y -> x <> pure y) mempty (f $ toList x) - {- | Returns a list of intervals where any intervals that meet or share support are combined into one interval. This function sorts the input. If you know the input intervals are sorted, use @combineIntervalsLFromSorted@. @@ -546,7 +243,7 @@ >>> ivs = [x1, x2, x3, x4] >>> ivs [(0, 10),(2, 7),(10, 12),(13, 15)] ->>> xComb = combineIntervalsL ivs +>>> xComb = combineIntervals ivs >>> xComb [(0, 12),(13, 15)] >>> :{ @@ -562,23 +259,23 @@ ------------ -- <- [xComb] =============== -} -combineIntervalsL :: (Intervallic i, Ord a) => [i a] -> [Interval a] -combineIntervalsL = combineIntervalsFromSortedL . sortOn getInterval +combineIntervals :: (SizedIv (Interval a), Intervallic i, Ord a) => [i a] -> [Interval a] +combineIntervals = combineIntervalsFromSorted . sortOn getInterval {- | Returns a list of intervals where any intervals that meet or share support are combined into one interval. The operation is applied cumulatively, from left to right, so __to work properly, the input list should be sorted in increasing order__. ->>> combineIntervalsFromSortedL [bi 10 0, bi 5 2, bi 2 10, bi 2 13] +>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 2 10, bi 2 13] [(0, 12),(13, 15)] ->>> combineIntervalsFromSortedL [bi 10 0, bi 5 2, bi 0 8] +>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 0 8] [(0, 10)] -} -combineIntervalsFromSortedL - :: forall a i . (Ord a, Intervallic i) => [i a] -> [Interval a] -combineIntervalsFromSortedL = reverse . foldl' op [] +combineIntervalsFromSorted + :: forall a i . (Ord a, Intervallic i, SizedIv (Interval a)) => [i a] -> [Interval a] +combineIntervalsFromSorted = reverse . foldl' op [] where op [] y = [getInterval y] op (x : xs) y = if x `before` y @@ -617,286 +314,26 @@ --------- <- [spanIv] =========== ->>> rangeInterval Nothing +>>> rangeInterval (Nothing :: Maybe (Interval Int)) Nothing >>> rangeInterval (Just (bi 1 0)) Just (0, 1) -} -rangeInterval :: (Ord a, L.Foldable t) => t (Interval a) -> Maybe (Interval a) +rangeInterval :: (L.Foldable t, Ord a, SizedIv (Interval a)) => t (Interval a) -> Maybe (Interval a) rangeInterval = L.fold (liftA2 extenterval <$> L.minimum <*> L.maximum) --- | 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) - => ((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) - -> Maybe (f (i a)) -nothingIf quantifier predicate x = - if quantifier predicate x then Nothing else Just x - --- | Returns the 'Nothing' if *none* of the element of input satisfy --- the predicate condition. --- --- For example, the following returns 'Nothing' because none of the intervals --- in the input list 'starts' (3, 5). --- --- >>> nothingIfNone (starts (bi 2 3)) [bi 1 3, bi 1 5] --- Nothing --- --- In the following, (3, 5) 'starts' (3, 6), so 'Just' the input is returned. --- --- >>> nothingIfNone (starts (bi 2 3)) [bi 3 3, bi 1 5] --- Just [(3, 6),(5, 6)] --- -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 (startedBy (bi 2 3)) [bi 3 3, bi 1 5] --- Just [(3, 6),(5, 6)] --- --- >>> nothingIfAny (starts (bi 2 3)) [bi 3 3, bi 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 (starts (bi 2 3)) [bi 3 3, bi 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 - --- | Creates a function for filtering a 'Witherable.Filterable' of @i1 a@s --- by comparing the @Interval a@s that of an @i0 a@. -makeFilter - :: (Filterable f, Intervallic i0, Intervallic i1) - => ComparativePredicateOf2 (i0 a) (i1 a) - -> i0 a - -> (f (i1 a) -> f (i1 a)) -makeFilter f p = Witherable.filter (f p) - -{- | -Filter 'Witherable.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, filterEncloses, filterEnclosedBy - :: (Filterable f, Ord a, Intervallic i0, Intervallic i1) - => 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 -filterEncloses = makeFilter encloses -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 - :: (Eq b, Ord a, Show a) - => [PairedInterval b a] -- ^ Be sure this only contains intervals - -- that sequentially 'meets'. - -> [PairedInterval b a] -foldMeetingSafe l = maybe [] (getMeeting . foldMeeting) (parseMeeting l) - --- | 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 - :: (Eq b, Ord a, Show a) - => Meeting [PairedInterval b a] - -> Meeting [PairedInterval b a] -foldMeeting (Meeting l) = - foldl' joinMeetingPairedInterval (Meeting []) (packMeeting l) - --- This type identifies that @a@ contains intervals that sequentially meet one --- another. -newtype Meeting a = Meeting { getMeeting :: a } deriving (Eq, Show) - --- Box up Meeting. -packMeeting :: [a] -> [Meeting [a]] -packMeeting = fmap (\z -> Meeting [z]) - --- Test a list of intervals to be sure they all meet; if not return Nothing. -parseMeeting :: (Ord a, Intervallic i) => [i a] -> Maybe (Meeting [i a]) -parseMeeting x | all (== Meets) (relationsL x) = Just $ Meeting x - | otherwise = Nothing - --- A specific case of 'joinMeeting' for @PairedIntervals@. -joinMeetingPairedInterval - :: (Eq b, Ord a, Show a) - => Meeting [PairedInterval b a] - -> Meeting [PairedInterval b a] - -> Meeting [PairedInterval b a] -joinMeetingPairedInterval = joinMeeting equalPairData - --- A general function for combining any two @Meeting [i a]@ by 'listCombiner'. -joinMeeting - :: (Ord a, Intervallic i) - => ComparativePredicateOf1 (i a) - -> Meeting [i a] - -> Meeting [i a] - -> Meeting [i a] -joinMeeting f (Meeting x) (Meeting y) = - Meeting $ listCombiner (join2MeetingWhen f) x y - --- The intervals @x@ and @y@ should meet! The predicate function @p@ determines --- when the two intervals that meet should be combined. -join2MeetingWhen - :: (Ord a, Intervallic i) - => ComparativePredicateOf1 (i a) - -> Maybe (i a) - -> Maybe (i a) - -> [i a] -join2MeetingWhen p Nothing Nothing = [] -join2MeetingWhen p Nothing (Just y) = [y] -join2MeetingWhen p (Just x) Nothing = [x] -join2MeetingWhen p (Just x) (Just y) | p x y = [setInterval y (extenterval x y)] - | otherwise = pure x <> pure y - -{- | -Takes two *ordered* events, x <= y, and "disjoins" them in the case that the -two events have different states, creating a sequence (list) of new events that -sequentially meet one another. Since x <= y, there are 7 possible interval -relations between x and y. If the states of x and y are equal and x is not -before y, then x and y are combined into a single event. --} -disjoinPaired - :: (Eq b, Monoid b, Show a, IntervalSizeable a c) - => (PairedInterval b) a - -> (PairedInterval b) a - -> Meeting [(PairedInterval b) a] -disjoinPaired o e = case relate x y of - Before -> Meeting [x, evp e1 b2 mempty, y] - Meets -> foldMeeting $ Meeting [x, y] - Overlaps -> foldMeeting $ Meeting [evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2] - FinishedBy -> foldMeeting $ Meeting [evp b1 b2 s1, ev i2 sc] - Contains -> foldMeeting $ Meeting [evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1] - Starts -> foldMeeting $ Meeting [ev i1 sc, evp e1 e2 s2] - _ -> Meeting [ev i1 sc] {- Equals case -} - where - x = min o e - y = max o e - i1 = getInterval x - i2 = getInterval y - s1 = getPairData x - s2 = getPairData y - sc = s1 <> s2 - b1 = begin x - b2 = begin y - e1 = end x - e2 = end y - ev = flip makePairedInterval - evp b e = ev (beginerval (diff e b) b) -{-# INLINABLE disjoinPaired #-} - -{- | -The internal function for converting a non-disjoint, ordered sequence of -events into a disjoint, ordered sequence of events. The function operates -by recursion on a pair of events and the input events. The first of the -is the accumulator set -- the disjoint events that need no longer be -compared to input events. The second of the pair are disjoint events that -still need to be compared to be input events. --} -recurseDisjoin - :: (Monoid b, Eq b, IntervalSizeable a c, Show a) - => ([(PairedInterval b) a], [(PairedInterval b) a]) - -> [(PairedInterval b) a] - -> [(PairedInterval b) a] -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 = recurseDisjoin (acc, o : os) es - | - - {- If o is either before or meets e, then - the first of the combined events can be put into the accumulator. - That is, since the inputs events are ordered, once the beginning of o - 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 = recurseDisjoin - (acc <> nh, recurseDisjoin ([], nt) os) - es - | - - --The standard recursive operation. - otherwise = recurseDisjoin (acc, recurseDisjoin ([], n) os) es - where - n = getMeeting $ disjoinPaired o e - nh = maybeToList (headMay n) - nt = tailSafe n -{-# INLINABLE recurseDisjoin #-} - -{- | -Convert an ordered sequence of @PairedInterval b a@. that may have any interval relation -('before', 'starts', etc) into a sequence of sequentially meeting @PairedInterval b a@. -That is, a sequence where one the end of one interval meets the beginning of -the subsequent event. The 'getPairData' of the input @PairedIntervals@ are -combined using the Monoid '<>' function, hence the pair data must be a -'Monoid' instance. --} -formMeetingSequence - :: (Eq b, Show a, Monoid b, IntervalSizeable a c) - => [PairedInterval b a] - -> [PairedInterval b a] -formMeetingSequence x - | null x = [] - | allMeet x && not (hasEqData x) = x - | otherwise = formMeetingSequence (recurseDisjoin ([], []) x) - -- recurseDisjoin ([], []) (recurseDisjoin ([], []) (recurseDisjoin ([], []) x)) - - -- the multiple passes of recurseDisjoin is to handle the situation where the - -- initial passes almost 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 recursive passes merges any sequential - -- intervals that have the same data. - -- - -- There is probably a more efficient way to do this -{-# INLINABLE formMeetingSequence #-} + {- Combining intervals -} -allMeet :: (Ord a) => [PairedInterval b a] -> Bool -allMeet x = all (== Meets) (relationsL x) +-- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the +-- interval in the "gap" between @x@ and @y@ from the 'end' of @x@ to the +-- 'begin' of @y@. Otherwise, 'Nothing'. +(><) :: (Iv (Interval a), Ord (Moment (Interval a)), SizedIv (Interval a), Intervallic i) => i a -> i a -> Maybe (Interval a) +(><) x y + | x `before` y = Just $ safeInterval (end x, begin y) + | otherwise = Nothing -hasEqData :: (Eq b) => [PairedInterval b a] -> Bool -hasEqData x = or (L.fold (makeFolder (==)) (fmap getPairData x) :: [Bool]) +-- | Maybe form a new @Interval a@ by the union of two @Interval a@s that 'meets'. +(.+.) :: (Iv (Interval a), Ord (Moment (Interval a)), SizedIv (Interval a), Intervallic i) => i a -> i a -> Maybe (Interval a) +(.+.) x y + | x `meets` y = Just $ safeInterval (begin x, end y) + | otherwise = Nothing diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -1,16 +1,17 @@ {-| Module : Paired interval Description : Extends the Interval Algebra to an interval paired with some data. -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 Stability : experimental -} {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Safe #-} module IntervalAlgebra.PairedInterval ( PairedInterval @@ -23,20 +24,19 @@ , trivialize ) where -import safe Control.Applicative (liftA2) -import safe Control.DeepSeq (NFData) -import safe Data.Binary (Binary) -import safe GHC.Generics (Generic) -import safe IntervalAlgebra.Core (ComparativePredicateOf1, Interval, - IntervalCombinable (..), - IntervalSizeable, Intervallic (..), - before, extenterval) -import safe Test.QuickCheck (Arbitrary (..)) -import safe Witherable (Filterable (filter)) +import Control.Applicative (liftA2) +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import GHC.Generics (Generic) +import IntervalAlgebra.Core (ComparativePredicateOf1, Interval, + Intervallic (..), SizedIv (..), before, + extenterval) +import Test.QuickCheck (Arbitrary (..)) -- | An @Interval a@ paired with some other data of type @b@. -newtype PairedInterval b a = PairedInterval (Interval a, b) - deriving (Eq, Generic) +newtype PairedInterval b a + = PairedInterval (Interval a, b) + deriving (Eq, Generic) instance Intervallic (PairedInterval b) where getInterval (PairedInterval x) = fst x @@ -54,15 +54,6 @@ instance (Show b, Show a, Ord a) => Show (PairedInterval b a) where show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}" -instance (Ord a, Eq b, Monoid b) => - IntervalCombinable (PairedInterval b) a where - (><) x y = fmap (makePairedInterval mempty) (getInterval x >< getInterval y) - - (<+>) x y - | x `before` y = pure x <> pure y - | otherwise = pure - $ makePairedInterval (getPairData x <> getPairData y) (extenterval x y) - -- | Make a paired interval. makePairedInterval :: b -> Interval a -> PairedInterval b a makePairedInterval d i = PairedInterval (i, d) @@ -80,8 +71,7 @@ intervals = fmap getInterval -- | Empty is used to trivially lift an @Interval a@ into a @PairedInterval@. -data Empty = Empty - deriving (Eq, Ord, Show) +data Empty = Empty deriving (Eq, Ord, Show) instance Semigroup Empty where x <> y = Empty instance Monoid Empty where @@ -98,6 +88,7 @@ trivialize = fmap toTrivialPair +-- TODO REFACTOR need to revisit this -- Arbitrary instance -instance (Arbitrary b, Ord a, Arbitrary a) => Arbitrary (PairedInterval b a) where - arbitrary = liftA2 makePairedInterval arbitrary arbitrary +--instance (Arbitrary b, Arbitrary (Interval a)) => Arbitrary (PairedInterval b a) where +-- arbitrary = liftA2 makePairedInterval arbitrary arbitrary diff --git a/src/IntervalAlgebra/RelationProperties.hs b/src/IntervalAlgebra/RelationProperties.hs --- a/src/IntervalAlgebra/RelationProperties.hs +++ b/src/IntervalAlgebra/RelationProperties.hs @@ -1,35 +1,41 @@ {-| Module : Interval Algebra Axioms Description : Properties of Intervals -Copyright : (c) NoviSci, Inc 2020 +Copyright : (c) NoviSci, Inc 2020-2022 + TargetRWE, 2023 License : BSD3 -Maintainer : bsaul@novisci.com +Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023 -This module exports a single typeclass @IntervalAxioms@ which contains -property-based tests for the axioms in section 1 of [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). -The notation below is that of the original paper. +This module exports property-based tests for the axioms in section 1 of [Allen +and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). The +notation below is that of the original paper. -This module is useful if creating a new instance of interval types that you want to test. +This module is useful if creating a new instance of interval types that you +want to test. -} {- HLINT ignore -} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -module IntervalAlgebra.RelationProperties - ( IntervalRelationProperties(..) - ) where +module IntervalAlgebra.RelationProperties where -import Data.Maybe (fromJust, isJust, isNothing) -import Data.Set (Set, disjointUnion, fromList, - member) -import Data.Time as DT (Day, NominalDiffTime, UTCTime) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Set (Set, disjointUnion, + fromList, member) +import Data.Time as DT (Day, NominalDiffTime, + UTCTime) import IntervalAlgebra.Arbitrary import IntervalAlgebra.Core -import Test.QuickCheck (Arbitrary (arbitrary), Property, - (===), (==>)) +import IntervalAlgebra.IntervalUtilities ((.+.)) +import Test.QuickCheck (Arbitrary (arbitrary), + Property, (===), (==>)) -allIArelations :: (Ord a) => [ComparativePredicateOf1 (Interval a)] +allIArelations :: (SizedIv (Interval a), Ord a) => [ComparativePredicateOf1 (Interval a)] allIArelations = [ equals , meets @@ -46,98 +52,94 @@ , contains ] --- | A collection of properties for the interval algebra. Some of these come from --- figure 2 in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). -class ( IntervalSizeable a b ) => IntervalRelationProperties a b where - - -- | For any two pair of intervals exactly one 'IntervalRelation' should hold - prop_exclusiveRelations:: Interval a -> Interval a -> Property - prop_exclusiveRelations x y = - ( 1 == length (filter id $ map (\r -> r x y) allIArelations)) === True +-- A collection of properties for the interval algebra. Some of these come from +-- figure 2 in [Allen and Hayes +-- (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). - -- | Given a set of interval relations and predicate function, test that the - -- predicate between two interval is equivalent to the relation of two intervals - -- being in the set of relations. - prop_predicate_unions :: Ord a => - Set IntervalRelation - -> ComparativePredicateOf2 (Interval a) (Interval a) - -> Interval a - -> Interval a - -> Property - prop_predicate_unions s pred i0 i1 = - pred i0 i1 === (relate i0 i1 `elem` s) +-- | For any two pair of intervals exactly one 'IntervalRelation' should hold +prop_exclusiveRelations:: (SizedIv (Interval a), Ord a) => Interval a -> Interval a -> Property +prop_exclusiveRelations x y = + ( 1 == length (filter id $ map (\r -> r x y) allIArelations)) === True - prop_IAbefore :: Interval a -> Interval a -> Property - prop_IAbefore i j = - before i j ==> (i `meets` k) && (k `meets` j) - where k = beginerval (diff (begin j) (end i)) (end i) +-- | Given a set of interval relations and predicate function, test that the +-- predicate between two interval is equivalent to the relation of two intervals +-- being in the set of relations. +prop_predicate_unions :: (SizedIv (Interval a), Ord a) => + Set IntervalRelation + -> ComparativePredicateOf2 (Interval a) (Interval a) + -> Interval a + -> Interval a + -> Property +prop_predicate_unions s pred i0 i1 = + pred i0 i1 === (relate i0 i1 `elem` s) - prop_IAstarts:: Interval a -> Interval a -> Property - prop_IAstarts i j - | starts i j = (j == fromJust (i .+. k)) === True - | otherwise = starts i j === False - where k = beginerval (diff (end j) (end i)) (end i) +prop_IAbefore :: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => Interval a -> Interval a -> Property +prop_IAbefore i j = + before i j ==> (i `meets` k) && (k `meets` j) + where k = safeInterval (end i, begin j) - prop_IAfinishes:: Interval a -> Interval a -> Property - prop_IAfinishes i j - | finishes i j = (j == fromJust ( k .+. i)) === True - | otherwise = finishes i j === False - where k = beginerval (diff (begin i) (begin j)) (begin j) +prop_IAstarts:: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => Interval a -> Interval a -> Property +prop_IAstarts i j + | starts i j = (j == fromJust (i .+. k)) === True + | otherwise = starts i j === False + where k = safeInterval (end i, end j) - prop_IAoverlaps:: Interval a -> Interval a -> Property - prop_IAoverlaps i j - | overlaps i j = ((i == fromJust ( k .+. l )) && - (j == fromJust ( l .+. m ))) === True - | otherwise = overlaps i j === False - where k = beginerval (diff (begin j) (begin i)) (begin i) - l = beginerval (diff (end i) (begin j)) (begin j) - m = beginerval (diff (end j) (end i)) (end i) +prop_IAfinishes:: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => Interval a -> Interval a -> Property +prop_IAfinishes i j + | finishes i j = (j == fromJust ( k .+. i)) === True + | otherwise = finishes i j === False + where k = safeInterval (begin j, begin i) - prop_IAduring:: Interval a -> Interval a-> Property - prop_IAduring i j - | during i j = (j == fromJust ( fromJust (k .+. i) .+. l)) === True - | otherwise = during i j === False - where k = beginerval (diff (begin i) (begin j)) (begin j) - l = beginerval (diff (end j) (end i)) (end i) +prop_IAoverlaps:: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => Interval a -> Interval a -> Property +prop_IAoverlaps i j + | overlaps i j = ((i == fromJust ( k .+. l )) && + (j == fromJust ( l .+. m ))) === True + | otherwise = overlaps i j === False + where k = safeInterval (begin i, begin j) + l = safeInterval (begin j, end i) + m = safeInterval (end i, end j) - prop_disjoint_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint +prop_IAduring:: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => Interval a -> Interval a-> Property +prop_IAduring i j + | during i j = (j == fromJust ( fromJust (k .+. i) .+. l)) === True + | otherwise = during i j === False + where k = safeInterval (begin j, begin i) + l = safeInterval (end i, end j) - prop_notdisjoint_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_notdisjoint_predicate = - prop_predicate_unions (complement disjointRelations) notDisjoint +prop_disjoint_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint - prop_concur_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_concur_predicate = - prop_predicate_unions (complement disjointRelations) concur +prop_notdisjoint_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_notdisjoint_predicate = + prop_predicate_unions (complement disjointRelations) notDisjoint - prop_within_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_within_predicate = prop_predicate_unions withinRelations within +prop_concur_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_concur_predicate = + prop_predicate_unions (complement disjointRelations) concur - prop_enclosedBy_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy +prop_within_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_within_predicate = prop_predicate_unions withinRelations within - prop_encloses_predicate :: (Ord a) => - Interval a - -> Interval a - -> Property - prop_encloses_predicate = prop_predicate_unions (converse withinRelations) encloses +prop_enclosedBy_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy -instance IntervalRelationProperties Int Int -instance IntervalRelationProperties Day Integer -instance IntervalRelationProperties UTCTime NominalDiffTime +prop_encloses_predicate :: (SizedIv (Interval a), Ord a) => + Interval a + -> Interval a + -> Property +prop_encloses_predicate = prop_predicate_unions (converse withinRelations) encloses diff --git a/test-axioms/AxiomsSpec.hs b/test-axioms/AxiomsSpec.hs --- a/test-axioms/AxiomsSpec.hs +++ b/test-axioms/AxiomsSpec.hs @@ -6,13 +6,14 @@ ( spec ) where -import Data.Time (Day, UTCTime) -import IntervalAlgebra.Axioms (IntervalAxioms (..)) -import Test.Hspec (Spec, describe, hspec, it) -import Test.Hspec.QuickCheck (modifyMaxSuccess) -import Test.QuickCheck (Arbitrary (arbitrary), Gen (..), - Property, Testable (property), - generate, quickCheck) +import Data.Time (Day, UTCTime) +import IntervalAlgebra.Arbitrary +import IntervalAlgebra.Axioms +import Test.Hspec (Spec, describe, hspec, it) +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck (Arbitrary (arbitrary), Gen (..), + Property, Testable (property), + forAll, generate, quickCheck) testScale :: Int @@ -42,11 +43,11 @@ it "M3" $ property (prop_IAaxiomM3 @Int) it "M3" $ property (prop_IAaxiomM3 @Day) - it "M3" $ property (prop_IAaxiomM3 @UTCTime) + it "M3" $ forAll genNominalDiffTime (prop_IAaxiomM3 @UTCTime) it "M4" $ property (prop_IAaxiomM4 @Int) it "M4" $ property (prop_IAaxiomM4 @Day) - it "M4" $ property (prop_IAaxiomM4 @UTCTime) + it "M4" $ forAll genNominalDiffTime (prop_IAaxiomM4 @UTCTime) it "M5" $ property (prop_IAaxiomM5 @Int) it "M5" $ property (prop_IAaxiomM5 @Day) @@ -54,5 +55,5 @@ it "M4.1" $ property (prop_IAaxiomM4_1 @Int) it "M4.1" $ property (prop_IAaxiomM4_1 @Day) - it "M4.1" $ property (prop_IAaxiomM4_1 @UTCTime) + it "M4.1" $ forAll genNominalDiffTime (prop_IAaxiomM4_1 @UTCTime) diff --git a/test-relation-properties/RelationPropertiesSpec.hs b/test-relation-properties/RelationPropertiesSpec.hs --- a/test-relation-properties/RelationPropertiesSpec.hs +++ b/test-relation-properties/RelationPropertiesSpec.hs @@ -7,7 +7,7 @@ ) where import Data.Time -import IntervalAlgebra.RelationProperties (IntervalRelationProperties (..)) +import IntervalAlgebra.RelationProperties import Test.Hspec (Spec, describe, hspec, it) import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -14,43 +14,22 @@ import qualified Data.Set (null) import Data.Time (Day, UTCTime) import IntervalAlgebra (Interval, - IntervalCombinable (..), IntervalRelation (..), - IntervalSizeable, Intervallic (..), - beginerval, complement, - converse, disjointRelations, - duration, intervalRelations, - moment, predicate, - rangeInterval, safeInterval, - starts, + SizedIv (..), beginerval, + complement, converse, + disjointRelations, duration, + intervalRelations, moment, + predicate, rangeInterval, + safeInterval, starts, strictWithinRelations, - withinRelations) + withinRelations, (.+.), + (><)) import IntervalAlgebra.Arbitrary (arbitraryWithRelation) import IntervalAlgebra.IntervalUtilities (clip, combineIntervals, combineIntervalsFromSorted, - durations, filterAfter, - filterBefore, filterConcur, - filterContains, - filterDisjoint, - filterDuring, - filterEnclosedBy, - filterEncloses, - filterEquals, - filterFinishedBy, - filterFinishes, filterMeets, - filterMetBy, - filterNotDisjoint, - filterOverlappedBy, - filterOverlaps, - filterStartedBy, - filterStarts, filterWithin, - foldMeetingSafe, - formMeetingSequence, gaps, - gapsL, gapsWithin, - intersect, nothingIfAll, - nothingIfAny, nothingIfNone, - relationsL) + durations, gaps, intersect, + relations) import IntervalAlgebra.PairedInterval (PairedInterval, getPairData, makePairedInterval, trivialize) @@ -66,7 +45,6 @@ orderedList, resize, sublistOf, suchThat, (===), (==>)) -import Witherable (Filterable) -- Types for testing @@ -111,7 +89,7 @@ deriving (Eq, Show) -mkEv :: IntervalSizeable a a => (a, a) -> b -> PairedInterval b a +mkEv :: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => (a, a) -> b -> PairedInterval b a mkEv i s = makePairedInterval s (safeInterval i) instance Arbitrary State where @@ -137,7 +115,7 @@ -- Testing functions checkSeqStates :: (Intervallic i) => [i Int] -> Bool -checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x) +checkSeqStates x = (length x > 1) || all (== Meets) (relations x) -- Creation functions iv :: Int -> Int -> Interval Int @@ -255,193 +233,49 @@ rels = refRelations ir isEnclose = Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations) - isMom = duration refIv == moment @Int + isMom = duration refIv == moment @(Interval Int) -- Check that the only relation remaining after applying a function is Before prop_before - :: (Ord a) => ([Interval a] -> [Interval a]) -> [Interval a] -> Property -prop_before f x = relationsL ci === replicate (length ci - 1) Before + :: (SizedIv (Interval a), Ord a) => ([Interval a] -> [Interval a]) -> [Interval a] -> Property +prop_before f x = relations ci === replicate (length ci - 1) Before where ci = f (sort x) -prop_combineIntervals1 :: (Ord a, Show a, Eq a) => [Interval a] -> Property +prop_combineIntervals1 :: (SizedIv (Interval a), Ord a, Show a, Eq a) => [Interval a] -> Property prop_combineIntervals1 = prop_before combineIntervals -prop_gaps1 :: (Ord a) => [Interval a] -> Property -prop_gaps1 = prop_before gapsL - --- In the case that that the input is not null, then --- * all relationsL should be `Meets` after formMeetingSequence -prop_formMeetingSequence0 :: Events Int -> Property -prop_formMeetingSequence0 x = - not (null es) - ==> all (== Meets) (relationsL $ formMeetingSequence (unEvents es)) - === True - where es = getEvents x - --- In the case that the input has --- * at least one Before relation between consequent pairs --- * AND does not have any empty states --- --- THEN the number empty states in the output should smaller than or equal to --- the number before relationsL in the output -prop_formMeetingSequence1 :: Events Int -> Property -prop_formMeetingSequence1 x = - (beforeCount > 0 && not - (any (\x -> getPairData x == State [False, False, False]) - (unEvents $ getEvents x) - ) - ) - ==> beforeCount - >= emptyCount - where - res = formMeetingSequence (unEvents $ getEvents x) - beforeCount = lengthWhen (== Before) (relationsL (unEvents $ getEvents x)) - emptyCount = lengthWhen (\x -> getPairData x == mempty) res - lengthWhen f = length . filter f - --- Check that formMeetingSequence doesn't return an empty list unless input is --- empty. -prop_formMeetingSequence2 :: Events Int -> Property -prop_formMeetingSequence2 x = not (null $ getEvents x) ==> not $ null res - where res = formMeetingSequence (unEvents $ getEvents x) - -class ( Ord a ) => FiltrationProperties a where - prop_filtration :: - (Interval a -> [Interval a] -> [Interval a]) - -> Set IntervalRelation - -> Interval a - -> [Interval a] - -> Property - prop_filtration fltr s x l = - not (null res) ==> and (fmap (predicate s x) res) === True - where res = fltr x l - - prop_filterOverlaps :: Interval a - -> [Interval a] - -> Property - prop_filterOverlaps = prop_filtration filterOverlaps (fromList [Overlaps]) - - prop_filterOverlappedBy :: Interval a - -> [Interval a] - -> Property - prop_filterOverlappedBy = prop_filtration filterOverlappedBy (fromList [OverlappedBy]) - - prop_filterBefore :: Interval a - -> [Interval a] - -> Property - prop_filterBefore = prop_filtration filterBefore (fromList [Before]) - - prop_filterAfter :: Interval a - -> [Interval a] - -> Property - prop_filterAfter = prop_filtration filterAfter (fromList [After]) - - prop_filterStarts :: Interval a - -> [Interval a] - -> Property - prop_filterStarts = prop_filtration filterStarts (fromList [Starts]) - - prop_filterStartedBy :: Interval a - -> [Interval a] - -> Property - prop_filterStartedBy = prop_filtration filterStartedBy (fromList [StartedBy]) - - prop_filterFinishes :: Interval a - -> [Interval a] - -> Property - prop_filterFinishes = prop_filtration filterFinishes (fromList [Finishes]) - - prop_filterFinishedBy :: Interval a - -> [Interval a] - -> Property - prop_filterFinishedBy = prop_filtration filterFinishedBy (fromList [FinishedBy]) - - prop_filterMeets :: Interval a - -> [Interval a] - -> Property - prop_filterMeets = prop_filtration filterMeets (fromList [Meets]) - - prop_filterMetBy :: Interval a - -> [Interval a] - -> Property - prop_filterMetBy = prop_filtration filterMetBy (fromList [MetBy]) - - prop_filterDuring :: Interval a - -> [Interval a] - -> Property - prop_filterDuring = prop_filtration filterDuring (fromList [During]) - - prop_filterContains :: Interval a - -> [Interval a] - -> Property - prop_filterContains = prop_filtration filterContains (fromList [Contains]) - - prop_filterEquals :: Interval a - -> [Interval a] - -> Property - prop_filterEquals = prop_filtration filterEquals (fromList [Equals]) - - prop_filterDisjoint :: Interval a - -> [Interval a] - -> Property - prop_filterDisjoint = prop_filtration filterDisjoint disjointRelations - - prop_filterNotDisjoint :: Interval a - -> [Interval a] - -> Property - prop_filterNotDisjoint = prop_filtration filterNotDisjoint (complement disjointRelations) - - prop_filterWithin :: Interval a - -> [Interval a] - -> Property - prop_filterWithin = prop_filtration filterWithin withinRelations - - prop_filterEnclosedBy :: Interval a - -> [Interval a] - -> Property - prop_filterEnclosedBy = prop_filtration filterEnclosedBy withinRelations - - prop_filterEncloses :: Interval a - -> [Interval a] - -> Property - prop_filterEncloses = prop_filtration filterEncloses (converse withinRelations) - - prop_filterConcur :: Interval a - -> [Interval a] - -> Property - prop_filterConcur = prop_filtration filterConcur (complement disjointRelations) +prop_gaps1 :: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => [Interval a] -> Property +prop_gaps1 = prop_before gaps -instance FiltrationProperties Int +prop_filtration :: (SizedIv (Interval a), Ord a) => + (Interval a -> [Interval a] -> [Interval a]) + -> Set IntervalRelation + -> Interval a + -> [Interval a] + -> Property +prop_filtration fltr s x l = + not (null res) ==> and (fmap (predicate s x) res) === True + where res = fltr x l prop_clip_intersect - :: (Show a, Ord a, IntervalSizeable a b) + :: (Show a, Ord a, SizedIv (Interval a), Ord (Moment (Interval a))) => Interval a -> Interval a -> Property prop_clip_intersect x y = clip x y === intersect (min x y) (max x y) --- NOTE: use this instead of prop_filterEquals -prop_small_filterEquals :: SmallInterval -> [SmallInterval] -> Property -prop_small_filterEquals x l = - not (null res) ==> and (fmap (predicate s i) res) === True - where - i = unSmall x - li = map unSmall l - res = filterEquals i li - s = fromList [Equals] - -- RUNNER spec :: Spec spec = do describe "gaps tests" $ modifyMaxSuccess (* 10) $ do it "no gaps in containmentInt and noncontainmentInt" - $ gapsL [containmentInt, noncontainmentInt] + $ gaps [containmentInt, noncontainmentInt] `shouldBe` [] - it "no gaps in containmentInt" $ gapsL [containmentInt] `shouldBe` [] + it "no gaps in containmentInt" $ gaps [containmentInt] `shouldBe` [] it "single gap between containmentInt and anotherInt" - $ gapsL [containmentInt, anotherInt] + $ gaps [containmentInt, anotherInt] `shouldBe` [gapInt] it "after gaps, only relation should be Before" $ property (prop_gaps1 @Int) @@ -465,90 +299,26 @@ `shouldBe` Just (iv 6 4) it "clip x y === intersect sort x y " $ property (prop_clip_intersect @Int) - describe "relationsL tests" $ do + describe "relations tests" $ do it - "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" - $ relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt] + "relations [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" + $ relations [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe` [FinishedBy, Meets, Meets] - it "relationsL of [] shouldBe []" - $ relationsL ([] :: [Interval Int]) + it "relations of [] shouldBe []" + $ relations ([] :: [Interval Int]) `shouldBe` [] - it "relationsL of singleton shouldBe []" - $ relationsL [containmentInt] + it "relations of singleton shouldBe []" + $ relations [containmentInt] `shouldBe` [] - it "length of relationsL result should be 1 less then length of input" + it "length of relations result should be 1 less then length of input" $ property (\x -> not (null x) - ==> length (relationsL x) + ==> length (relations x) === length (x :: [Interval Int]) - 1 ) - describe "gapsWithin tests" $ do - it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]" - $ gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] - `shouldBe` Just [iv 2 5, iv 1 9] - it "gapsWithin (1, 10) [(-1, 0), (12,15)] should be [(5,7), (9,10)]" - $ gapsWithin (iv 9 1) [iv 1 (-1), iv 3 12] - `shouldBe` Nothing - it "gapsWithin (0, 455) [(0, 730), (731, 762), (763, 793)]" - $ gapsWithin (safeInterval (0 :: Int, 455)) - (fmap safeInterval [(0, 730), (731, 762), (763, 793)]) - `shouldBe` Just [] - it "gapsWithin (1, 10) [] should be []" - $ gapsWithin (iv 9 1) ([] :: [Interval a]) - `shouldBe` Nothing - - describe "emptyIf tests" $ do - it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty" - $ nothingIfNone (starts (iv 2 3)) [iv 1 3, iv 1 5] - `shouldBe` Nothing - it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input" - $ nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5] - `shouldBe` Just [iv 3 3, iv 1 5] - - describe "filtration tests" $ modifyMaxDiscardRatio (* 2) $ do - it "disjoint filter should filter out noncontainment" - $ filterDisjoint containmentInt [noncontainmentInt, anotherInt] - `shouldBe` [anotherInt] - it "notDisjoint filter should keep noncontainment" - $ filterNotDisjoint containmentInt [noncontainmentInt, anotherInt] - `shouldBe` [noncontainmentInt] - it "filterBefore property" $ property (prop_filterBefore @Int) - it "filterAfter property" $ property (prop_filterAfter @Int) - it "filterOverlaps property" $ property (prop_filterOverlaps @Int) - it "filterOverlappedBy property" $ property (prop_filterOverlappedBy @Int) - it "filterStarts property" $ property (prop_filterStarts @Int) - it "filterStartedBy property" $ property (prop_filterStartedBy @Int) - it "filterFinishes property" $ property (prop_filterFinishes @Int) - it "filterFinishedBy property" $ property (prop_filterFinishedBy @Int) - it "filterMeets property" $ property (prop_filterMeets @Int) - it "filterMetBy property" $ property (prop_filterMetBy @Int) - it "filterDuring property" $ property (prop_filterDuring @Int) - it "filterContains property" $ property (prop_filterContains @Int) - it "filterEquals property" $ property prop_small_filterEquals - it "filterDisjoint property" $ property (prop_filterDisjoint @Int) - it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int) - it "filterWithin property" $ property (prop_filterWithin @Int) - it "filterConcur property" $ property (prop_filterConcur @Int) - it "filterEncloses property" $ property (prop_filterEncloses @Int) - it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int) - - describe "nothingIf unit tests" $ do - it "nothing from nothingIfAll" - $ nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] - `shouldBe` Nothing - it "something from nothingIfAll" - $ nothingIfAll (starts (iv 2 3)) [iv 3 0, iv 4 3] - `shouldBe` Just [iv 3 0, iv 4 3] - it "nothing from nothingIfAny" - $ nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] - `shouldBe` Nothing - it "something from nothingIfAny" - $ nothingIfAny (starts (iv 2 3)) [iv 3 1, iv 1 5] - `shouldBe` Just [iv 3 1, iv 1 5] - describe "intersection tests" $ do it "intersection of (0, 2) (2, 4) should be Nothing" $ intersect (iv 2 0) (iv 2 2) @@ -637,47 +407,3 @@ $ property (prop_combineIntervals1 @Day) it "after combining, only relation should be Before" $ property (prop_combineIntervals1 @UTCTime) - - describe "foldMeets unit tests" $ do - it "foldMeetingSafe meets1" - $ foldMeetingSafe (trivialize meets1) - `shouldBe` trivialize [iv 4 0] - it "foldMeetingSafe meets2" - $ foldMeetingSafe (trivialize meets2) - `shouldBe` trivialize [iv 16 0] - it "foldMeetingSafe meets3" $ foldMeetingSafe meets3 `shouldBe` meets3eq - - describe "formMeetingSequence unit tests" $ do - it "formMeetingSequence unit test 0" - $ formMeetingSequence (unEvents c0in) - `shouldBe` unEvents c0out - it "formMeetingSequence unit test 1" - $ formMeetingSequence (unEvents c1in) - `shouldBe` unEvents c1out - it "formMeetingSequence unit test 2" - $ formMeetingSequence (unEvents c2in) - `shouldBe` unEvents c2out - it "formMeetingSequence unit test 3" - $ formMeetingSequence (unEvents c3in) - `shouldBe` unEvents c3out - it "formMeetingSequence unit test 4" - $ formMeetingSequence (unEvents c4in) - `shouldBe` unEvents c4out - it "formMeetingSequence unit test 5" - $ formMeetingSequence c5in - `shouldBe` c5out - it "formMeetingSequence unit test 6" - $ formMeetingSequence ([] :: [PairedInterval State Int]) - `shouldBe` [] - - describe "formMeetingSequence property tests" $ modifyMaxSuccess (* 2) $ do - it "prop_formMeetingSequence0" $ property prop_formMeetingSequence0 - -- 2022-05-18 - BS - -- Commmenting out this test as the execution of the test suite blows up - -- when this property check is included. - -- TODO: consider whether this check is worthwhile. - -- it "prop_formMeetingSequence1" $ property prop_formMeetingSequence1 - it "prop_formMeetingSequence2" $ property prop_formMeetingSequence2 - - -- describe "arbitraryWithRelation property tests" $ do - -- it "prop_withRelation_tautology" $ property prop_withRelation_tautology diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -5,9 +5,9 @@ import Data.Bool import Data.Time (Day (ModifiedJulianDay), fromGregorian) -import IntervalAlgebra (IntervalCombinable (..), - IntervalSizeable (duration), - before, beginerval, equals, +import IntervalAlgebra (Intervallic (..), + SizedIv (duration), before, + beginerval, equals, toEnumInterval) import IntervalAlgebra.PairedInterval (Empty (..), PairedInterval, intervals, makePairedInterval) @@ -42,20 +42,12 @@ describe "tests on paired intervals" $ do it "t1 is before t2" $ (t1 `before` t2) `shouldBe` True - it "duration of t1 is 5" $ duration t1 `shouldBe` 5 + it "duration of t1 is 5" $ duration (getInterval t1) `shouldBe` 5 it "t1 is equal to t3" $ (t1 `equals` t3) `shouldBe` True it "t1 is LT t2" $ (t1 < t2) `shouldBe` True it "getintervals [t1, t2, t3]" $ intervals [t1, t2, t3] `shouldBe` [beginerval 5 0, beginerval 4 6, beginerval 5 0] - - describe "IntervalCombinable tests" $ do - it "" $ (t1 >< t3) `shouldBe` Nothing - it "" $ (t1 >< mkTestPr "hello" 1 6) `shouldBe` Just (mkTestPr "" 1 5) - it "" - $ (t1 <+> mkTestPr "hello" 1 6) - `shouldBe` [t1, mkTestPr "hello" 1 6] - it "" $ (t1 <+> mkTestPr "hello" 5 3) `shouldBe` [mkTestPr "hihello" 8 0] describe "tests on empty" $ do it "show empty" $ show Empty `shouldBe` "Empty" diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -1,11 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module IntervalAlgebraSpec ( spec ) where +import Control.Applicative (liftA2) import Data.Either (isRight) import Data.Fixed (Pico) import Data.Maybe (fromJust, isJust, isNothing) @@ -18,46 +21,87 @@ secondsToDiffTime) import GHC.Real (Rational (..), Real (..)) import IntervalAlgebra as IA -import IntervalAlgebra.Arbitrary () +import IntervalAlgebra.Arbitrary (genDay) import Test.Hspec (Spec, describe, hspec, it, shouldBe) import Test.Hspec.QuickCheck (modifyMaxDiscardRatio, modifyMaxSuccess) import Test.QuickCheck (Arbitrary (arbitrary), Gen (..), Property, Testable (property), - generate, quickCheck, (===), (==>)) + forAll, generate, quickCheck, + (.&&.), (===), (==>)) +-- Convenience aliases +interval :: (iv ~ Interval a, SizedIv iv, Ord a, Ord (Moment iv)) => a -> a -> iv +interval = curry safeInterval + mkIntrvl :: Int -> Int -> Interval Int mkIntrvl = beginerval prop_expandl_end - :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property + :: (SizedIv (Interval a), Show a, Eq a) => Moment (Interval a) -> Interval a -> Property prop_expandl_end d i = end (expandl d i) === end i prop_expandr_begin - :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property + :: (SizedIv (Interval a), Show a, Eq a) => Moment (Interval a) -> Interval a -> Property prop_expandr_begin d i = begin (expandr d i) === begin i -- | 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 :: Ord a => Interval a -> Interval a -> Interval a -> Property +prop_compose :: (Ord a, SizedIv (Interval a)) => Interval a -> Interval a -> Interval a -> Property prop_compose x y z = member (relate x z) (compose (relate x y) (relate y z)) === True -- | If two intervals are disjoint and not meeting, then there should be a gap -- between the two (by ><), after the intervals are sorted. -prop_combinable_gap_exists :: Ord a => Interval a -> Interval a -> Property +prop_combinable_gap_exists :: (Ord a, SizedIv (Interval a), Ord (Moment (Interval a))) => Interval a -> Interval a -> Property prop_combinable_gap_exists x y = (before <|> after) x y ==> isJust ((><) (min x y) (max x y)) -- | If two intervals are not disjoint or meeting, then there should be NO gap -- between the two (by ><), after the intervals are sorted. -prop_combinable_nogap_exists :: Ord a => Interval a -> Interval a -> Property +prop_combinable_nogap_exists :: (Ord a, SizedIv (Interval a), Ord (Moment (Interval a))) => Interval a -> Interval a -> Property prop_combinable_nogap_exists x y = (predicate $ complement $ fromList [Before, After]) x y ==> isNothing ((><) (min x y) (max x y)) + {- Properties of SizedIv -} +-- When @Point iv@ is @Ord@, +-- +-- prop> ivBegin i < ivEnd i +prop_validIv :: forall a. (SizedIv (Interval a), Ord a, Show a, Ord (Moment (Interval a))) => a -> a -> Property +prop_validIv b e = (ivBegin i < ivEnd i) === True where i = safeInterval (b, e) + +-- When @iv@ is @Eq@, +-- +-- prop> interval (ivBegin i) (ivEnd i) == i +prop_validIv' :: forall a. (SizedIv (Interval a), Ord a, Show a, Ord (Moment (Interval a))) => a -> a -> Property +prop_validIv' b e = interval (ivBegin i) (ivEnd i) === i where i = interval b e + +-- When @iv@ is @Ord@, for all @i == interval b e@, +-- +-- prop> ivExpandr d i >= i +-- prop> ivExpandl d i <= i +prop_ivExpandr, prop_ivExpandl :: forall a. (SizedIv (Interval a), Ord (Interval a), Show (Interval a)) => Moment (Interval a) -> Interval a -> Property +prop_ivExpandr d i = (ivExpandr d i >= i) === True +prop_ivExpandl d i = (ivExpandl d i <= i) === True + +-- When @Moment iv@ is @Ord@, +-- +-- prop> duration (interval b e) >= moment +-- prop> duration (ivExpandr d i) >= duration i +-- prop> duration (ivExpandl d i) >= duration i +prop_duration :: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a)), Show (Interval a)) => Moment (Interval a) -> a -> a -> Property +prop_duration d b e = p1 .&&. p2 .&&. p3 + where i = interval b e + m = moment @(Interval a) + dur = duration i + p1 = (dur >= m) === True + p2 = (duration (ivExpandr d i) >= dur) === True + p3 = (duration (ivExpandl d i) >= dur) === True + +{- Specs -} spec :: Spec spec = do describe "Basic Interval unit tests of typeclass and creation methods" $ do @@ -80,10 +124,10 @@ it "beginervalMoment duration is moment" $ duration (beginervalMoment (-13 :: Int)) - `shouldBe` (moment @Int) + `shouldBe` (moment @(Interval Int)) it "endervalMoment duration is moment" $ duration (endervalMoment (26 :: Int)) - `shouldBe` (moment @Int) + `shouldBe` (moment @(Interval Int)) it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left (IA.ParseErrorInterval "0<=10") @@ -180,8 +224,8 @@ $ intersection (fromList [Before]) (fromList [After]) `shouldBe` fromList [] - describe "IntervalSizeable tests" $ do - it "moment is 1" $ moment @Int `shouldBe` 1 + describe "SizedIv tests" $ do + it "moment is 1" $ moment @(Interval Int) `shouldBe` 1 it "expandl doesn't change end" $ property (prop_expandl_end @Int) it "expandr doesn't change begin" $ property (prop_expandr_begin @Int) it "expand 0 5 Interval (0, 1) should be Interval (0, 6)" @@ -200,7 +244,7 @@ $ expand 5 (-5) (beginerval (1 :: Int) (0 :: Int)) `shouldBe` beginerval (6 :: Int) (-5 :: Int) it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)" - $ expand (moment @Int) 0 (beginerval (1 :: Int) (0 :: Int)) + $ expand (moment @(Interval Int)) 0 (beginerval (1 :: Int) (0 :: Int)) `shouldBe` beginerval (2 :: Int) (-1 :: Int) it "beginerval 2 10 should be Interval (10, 12)" @@ -230,21 +274,30 @@ $ shiftFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10) `shouldBe` beginerval 2 4 -- (4, 6) - it "shiftFromBegin can convert Interval Day to Interval Integer" - $ shiftFromBegin (beginerval 2 (fromGregorian 2001 1 1)) - (beginerval 2 (fromGregorian 2001 1 10)) - `shouldBe` beginerval 2 9 -- (9, 11) - - it "shiftFromEnd can convert Interval Day to Interval Integer" - $ shiftFromEnd (beginerval 2 (fromGregorian 2001 1 1)) - (beginerval 2 (fromGregorian 2001 1 10)) - `shouldBe` beginerval 2 7 -- (7, 9) - it "momentize works" $ momentize (beginerval 2 (fromGregorian 2001 1 1)) `shouldBe` beginerval 1 (fromGregorian 2001 1 1) + describe "SizedIv properties for Interval Int" $ do + it "validIv" $ property (prop_validIv @Int) + it "validIv'" $ property (prop_validIv' @Int) + it "ivExpandr" $ property (prop_ivExpandr @Int) + it "ivExpandl" $ property (prop_ivExpandl @Int) + it "duration" $ property (prop_duration @Int) + describe "SizedIv properties for Interval Day" $ do + it "validIv" $ forAll (liftA2 (,) genDay genDay) (uncurry prop_validIv) + it "validIv'" $ forAll (liftA2 (,) genDay genDay) (uncurry prop_validIv') + it "ivExpandr" $ property (prop_ivExpandr @Day) + it "ivExpandl" $ property (prop_ivExpandl @Day) + it "duration" $ forAll (do + m <- arbitrary + b <- genDay + e <- genDay + pure (m, b, e) + ) (\(m, b, e) -> prop_duration m b e) + + describe "Intervallic tests" $ -- modifyMaxSuccess (*10000) $ do @@ -267,7 +320,7 @@ (mkIntrvl 2 3) it "prop_compose holds" $ property (prop_compose @Int) - describe "IntervalCombinable tests" $ do + describe "(.+.) tests" $ do it "join non-meeting intervals is Nothing" $ beginerval 2 (0 :: Int) .+. beginerval 6 5 @@ -311,3 +364,4 @@ it "concur matches notDisjoint" $ concur (beginerval 1 0) (beginerval 10 (0 :: Int)) `shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int)) + diff --git a/tutorial/TutorialMain.hs b/tutorial/TutorialMain.hs --- a/tutorial/TutorialMain.hs +++ b/tutorial/TutorialMain.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,12 +19,22 @@ import Data.Time ( Day , UTCTime(..) , addDays + , diffDays , fromGregorian , secondsToDiffTime ) import Witch ( into ) -- end::import-declarations[] +-- tag::safeInterval-alias[] +interval :: + (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => + a -> + a -> + Interval a +interval = curry safeInterval +-- end::safeInterval-alias[] + main :: IO () main = do @@ -182,9 +193,9 @@ print $ getInterval pairListstringInteger putStr - "\nprint $ setInterval pairListstringInteger (safeInterval (4, 9) :: Interval Integer)\n---> " + "\nprint $ setInterval pairListstringInteger (interval 4 9 :: Interval Integer)\n---> " print $ setInterval pairListstringInteger - (safeInterval (4, 9) :: Interval Integer) + (interval 4 9 :: Interval Integer) putStr "\nprint $ intervals [pairListstringInteger, pairListstringInteger]\n---> " @@ -239,29 +250,38 @@ putStrLn "-- end::intervallic-interval-instance-print[]" - -- IntervalSizeable instance examples ------------------------------------------------------ + -- SizedIv instance examples ------------------------------------------------------ putStrLn "-- tag::intervalsizeable-instance-print[]" putStr "\nprint ivDay\n---> " print ivDay - putStr "\nprint $ moment @Day\n---> " - print $ moment @Day + putStr "\nprint $ moment @(Interval Day)\n---> " + print $ moment @(Interval Day) + putStr "\nprint $ interval (ivBegin ivDay) (ivEnd ivDay)\n---> " + print $ interval (ivBegin ivDay) (ivEnd ivDay) + + putStr "\nprint $ interval (ivEnd ivDay) (ivBegin ivDay)\n---> " + print $ interval (ivEnd ivDay) (ivBegin ivDay) + putStr "\nprint $ duration ivDay\n---> " print $ duration ivDay - putStr "\nprint $ add 15 (begin ivDay)\n---> " - print $ add 15 (begin ivDay) + putStr "\nprint $ ivExpandr 15 ivDay\n---> " + print $ ivExpandr 15 ivDay - putStr "\nprint $ diff (add 15 (begin ivDay)) (begin ivDay)\n---> " - print $ diff (add 15 (begin ivDay)) (begin ivDay) + putStr "\nprint $ ivExpandl 0 ivDay\n---> " + print $ ivExpandl 0 ivDay + putStr "\nprint $ ivExpandl 10 ivDay\n---> " + print $ ivExpandl 10 ivDay + putStrLn "-- end::intervalsizeable-instance-print[]" - -- IntervalCombineable Interval examples ------------------------------------- + -- "Combining" utility examples ------------------------------------- putStrLn "-- tag::intervalcombinable-interval-print[]" @@ -286,7 +306,7 @@ putStrLn "-- end::intervalcombinable-interval-print[]" - -- IntervalCombineable PairedInterval examples ------------------------------- + -- "Combining" utilities for PairedInterval examples ------------------------------- putStrLn "-- tag::intervalcombinable-pairedinterval-print[]" @@ -375,21 +395,12 @@ putStr "\nprint [iv2to4, iv5to8]\n---> " print [iv2to4, iv5to8] - putStr "\nprint ivDay\n---> " - print ivDay - putStr "\nprint $ shiftFromBegin iv2to4 iv5to8\n---> " print $ shiftFromBegin iv2to4 iv5to8 - putStr "\nprint $ shiftFromBegin ivDay ivDay\n---> " - print $ shiftFromBegin ivDay ivDay - putStr "\nprint $ shiftFromEnd iv2to4 iv5to8\n---> " print $ shiftFromEnd iv2to4 iv5to8 - putStr "\nprint $ shiftFromEnd ivDay ivDay\n---> " - print $ shiftFromEnd ivDay ivDay - putStrLn "-- end::shifting-intervals-print[]" @@ -509,34 +520,33 @@ -- end::parseinterval-examples[] --- tag::safeinterval-examples[] +-- tag::interval-examples[] ivInteger :: Interval Integer -ivInteger = safeInterval (2, 6) +ivInteger = interval 2 6 ivMinDurInteger :: Interval Integer -ivMinDurInteger = safeInterval (2, 2) +ivMinDurInteger = interval 2 2 ivDay :: Interval Day -ivDay = safeInterval (fromGregorian 1967 01 18, fromGregorian 1967 01 24) +ivDay = interval (fromGregorian 1967 01 18) (fromGregorian 1967 01 24) ivUTC :: Interval UTCTime -ivUTC = safeInterval - ( UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 32400) - , UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 33200) - ) --- end::safeinterval-examples[] +ivUTC = interval + (UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 32400)) + (UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 33200)) +-- end::interval-examples[] -- tag::ivXtoY-examples[] ---------------- iv0to2, iv2to4, iv2to5, iv4to5, iv5to8, iv6to8, iv3to6 :: Interval Integer -iv0to2 = safeInterval (0, 2) -iv2to4 = safeInterval (2, 4) -iv2to5 = safeInterval (2, 5) -iv3to6 = safeInterval (3, 6) -iv4to5 = safeInterval (4, 5) -iv5to8 = safeInterval (5, 8) -iv6to8 = safeInterval (6, 8) +iv0to2 = interval 0 2 +iv2to4 = interval 2 4 +iv2to5 = interval 2 5 +iv3to6 = interval 3 6 +iv4to5 = interval 4 5 +iv5to8 = interval 5 8 +iv6to8 = interval 6 8 -- end::ivXtoY-examples[] @@ -586,14 +596,14 @@ -- We can construct a predicate function from a 'Set IntervalRelation' endedPrior - :: (Ord a, Intervallic i0, Intervallic i1) + :: (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) endedPrior = predicate (fromList [Before, Meets]) -- We can also construct a predicate function directly from a list of predicate -- functions endedPrior' - :: (Ord a, Intervallic i0, Intervallic i1) + :: (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) endedPrior' = unionPredicates [before, meets] @@ -601,7 +611,7 @@ -- using the <|> operator. If we had multiple predicates we could use e.g.: -- p1 <|> p2 <|> p3 endedPrior'' - :: (Ord a, Intervallic i0, Intervallic i1) + :: (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) endedPrior'' = before <|> meets @@ -799,21 +809,21 @@ -- Calculate the difference between the start endpoint of the first Intervallic -- and the start endpoint of the second Intervallic calcDiff - :: (IntervalSizeable a b, Intervallic i0, Intervallic i1) + :: (SizedIv (Interval a), Num a, Intervallic i0, Intervallic i1) => Maybe (i0 a) -> Maybe (i1 a) - -> Maybe b -calcDiff (Just y) (Just x) = Just $ diff (begin y) (end x) + -> Maybe a +calcDiff (Just y) (Just x) = Just $ (-) (begin y) (end x) calcDiff _ _ = Nothing -- Calculate the difference between the end endpoint of the first Intervallic -- and the start endpoint of the second Intervallic calcAtRisk - :: (IntervalSizeable a b, Intervallic i0, Intervallic i1) + :: (SizedIv (Interval a), Num a, Intervallic i0, Intervallic i1) => Maybe (i0 a) -> Maybe (i1 a) - -> Maybe b -calcAtRisk (Just y) (Just x) = Just $ diff (end y) (end x) + -> Maybe a +calcAtRisk (Just y) (Just x) = Just $ (-) (end y) (end x) calcAtRisk _ _ = Nothing -- end::extended-example-1-processing-functions[]