interval-algebra 2.1.3 → 2.2.0

raw patch · 18 files changed

+2419/−2837 lines, 18 filesdep −safedep −witchdep −witherabledep ~hspecPVP ok

version bump matches the API change (PVP)

Dependencies removed: safe, witch, witherable

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−0
• LICENSE +2/−1
• README.md +62/−7
• interval-algebra.cabal +8/−16
• src/IntervalAlgebra.hs +8/−7
• src/IntervalAlgebra/Arbitrary.hs +62/−29
• src/IntervalAlgebra/Axioms.hs +206/−205
• src/IntervalAlgebra/Core.hs +1619/−1349
• src/IntervalAlgebra/IntervalDiagram.hs +19/−27
• src/IntervalAlgebra/IntervalUtilities.hs +102/−665
• src/IntervalAlgebra/PairedInterval.hs +19/−28
• src/IntervalAlgebra/RelationProperties.hs +100/−98
• test-axioms/AxiomsSpec.hs +11/−10
• test-relation-properties/RelationPropertiesSpec.hs +1/−1
• test/IntervalAlgebra/IntervalUtilitiesSpec.hs +40/−314
• test/IntervalAlgebra/PairedIntervalSpec.hs +4/−12
• test/IntervalAlgebraSpec.hs +77/−23
• tutorial/TutorialMain.hs +55/−45

@@ -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.

@@ -1,4 +1,5 @@-Copyright NoviSci, Inc (c) 2020+Copyright NoviSci, Inc (c) 2020-2022+Copyright Target RWE   (c) 2023  All rights reserved. 

@@ -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.

@@ -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 <https://github.com/novisci/interval-algebra> 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:     <bsaul@novisci.com> 2020-2022, <bbrown@targetrwe.com> 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

@@ -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

@@ -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)

@@ -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

@@ -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-<https://thomasalspaugh.org/pub/fnd/allen.html#BasicCompositionsTable this table>.--}-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+-- <https://thomasalspaugh.org/pub/fnd/allen.html#BasicCompositionsTable this table>.+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))

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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

@@ -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

@@ -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"

@@ -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))+

@@ -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[]