interval-algebra 0.10.2 → 2.2.0

raw patch · 21 files changed

Files

• ChangeLog.md +125/−1
• LICENSE +2/−1
• README.md +62/−7
• interval-algebra.cabal +73/−24
• src/IntervalAlgebra.hs +18/−760
• src/IntervalAlgebra/Arbitrary.hs +126/−20
• src/IntervalAlgebra/Axioms.hs +341/−0
• src/IntervalAlgebra/Core.hs +1619/−0
• src/IntervalAlgebra/IntervalDiagram.hs +778/−0
• src/IntervalAlgebra/IntervalUtilities.hs +279/−552
• src/IntervalAlgebra/PairedInterval.hs +45/−50
• src/IntervalAlgebra/RelationProperties.hs +145/−0
• test-axioms/AxiomsSpec.hs +59/−0
• test-axioms/Main.hs +7/−0
• test-relation-properties/Main.hs +7/−0
• test-relation-properties/RelationPropertiesSpec.hs +72/−0
• test/IntervalAlgebra/IntervalUtilitiesSpec.hs +317/−487
• test/IntervalAlgebra/PairedIntervalSpec.hs +38/−55
• test/IntervalAlgebraSpec.hs +367/−776
• test/Spec.hs +0/−0
• tutorial/TutorialMain.hs +849/−0

@@ -1,5 +1,129 @@ # 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.++## 2.1.2++* Exports `IntervalAlgebra.IntervalDiagram` module and makes the following changes so as to export it as `safe`:+  * Removes `nonempty-containers` dependency and `Data.IntMap.NonEmpty` usage in `IntervalAlgebra.IntervalDiagram`. Replaces the non-empty `IntMap` with a key-value pair in a non-empty list.+  * Removes `From` instances, which were unnecessary.++## 2.1.1++* Makes the version bounds on the `time` package+consistent among project components.++## 2.1.0++* Changes the type signature of the `Intervallic` typeclass.+* Adds a package component `tutorial` used to provide data for a tutorial document.+* Adds a tutorial document: _interval-algebra foundations_.+* Adds a function `standardExampleDiagram` to `IntervalAlgebra.IntervalDiagram` that can be concisely invoked in Haddock documentation examples.+* Renames `enclose` to `encloses` so tense is consistent with other relational predicates.+* Changes `combineIntervals` and `combineIntervalsL` to sort their inputs and adds new functions `combineIntervalsFromSorted` and `combineIntervalsFromSortedL` for cases when the input data already are sorted.+* Removes the unnecessary `Ord` constraint from `begin` and `end`, made possible by the changes to `Intervallic`.+* Removes `Functor Interval` instance and the `Functor`, `Bifunctor` instances of `PairedInterval`. It is not possible to write an instance that both satisfies the `Functor` laws and maintains the desired `Interval` property that the `begin` be strictly less than the `end`.+* Minor changes to the `IntervalAlgebra.IntervalDiagram` module, such as re-exporting `Pretty` and its methods.+* Deprecates `(<+>)`.++## 2.0.3++* Adds `labeledIntervalDiagram`, which creates interval diagrams with labels and a `rangeInterval` reference interval.++## 2.0.2++* Adds `rangeInterval`, which creates the smallest inverval containing all intervals in a `Foldable`.++## 2.0.1++* Relaxes cabal package bounds; notably:+  * the `time` bounds gets a wider range+  * the `text` bounds include `2.0`++## 2.0.0++* Adds `Abitrary (Interval a)` instance generic over `Ord a, Arbitrary a`.+* Removes the `moment'` function from the `IntervalSizeable` class.+* Use type application with `moment` instead, as in `moment @Int`, `moment @Day`, etc.+* Adds the following utility functions:+`lookback`, `lookahead`, `makeGapsWithinPredicate`,+`pairGaps`, `anyGapsWithinAtLeastDuration`, `allGapsWithinLessThanDuration`++## 1.4.0++* Adds the `safeInterval` function to `Core`,+as a utility for creating intervals from a pair of endpoints.+* Uses+[PVP](https://pvp.haskell.org/)-style+major upper bounds in cabal dependencies as described+[here](https://cabal.readthedocs.io/en/3.4/cabal-package.html#build-information).+* Adds the `IntervalDiagram` module which includes functions and types+for printing diagrams of intervals as text.+These functions are useful for documentation and examples.++## 1.3.0++* Adds `NFData` and `Binary` instances for `Interval` and `PairedInterval`++## 1.2.0++* Derives `Generic` instances for `Interval` and `PairedInterval`.+* Adds an `Arbitrary` instance for `PairedInterval`.++## 1.1.3++* `Arbitrary` instances for `DiffTime`, `NominalDiffTime` and `Day` are now sized, the absence of which had prevented the 'fix' from version 1.1.1 from being effective. `DiffTime` and `NominalDiffTime` generators are also now limited to a maximum `86399` seconds directly.++## 1.1.2++* Adds an internal utility to `IntervalAlgebra.Arbitrary` to generate a `Maybe (i a)` for `Intervallic i a` from a reference interval and set of relations. `Nothing` is returned for cases in which no interval can be generated.++## 1.1.1++* Modifies internals of `IntervalAlgebra.Arbitrary` module to give uniformity over support for `Integer` and `UTCTime` intervals, yielding better interval generators. Also bounds the `UTCTime` `utctDayTime` argument to `86399` rather than `86400` to avoid trivial and rare cases of property testing failures related to leap seconds.++## 1.1.0++* Fixes bug in `parseInterval`. For example, `parseInterval 0 0` parsed to a `Right (Interval (0, 0))`. Oops, the inequality of the should have been `y <= x` not `y < x`. This was fixed and a test added to catch this error.++## 1.0.1++* Adds `beginervalMoment` and `endervalMoment` functions to create intervals of moment duration from a begin or end.++## 1.0.0++* Moves the main `IntervalAlgebra` module to `IntervalAlgebra.Core` and `IntervalAlgebra` now reexports `IntervalAlgebra.Core`, `IntervalAlgebra.IntervalUtilites`, and `IntervalAlgebra.PairedInterval`.+* Creates a new `IntervalAlgebra.Axioms` module containing the `IntervalAxioms` typeclass of property tests of the interval algebra axioms. These were in the testing suite. Including this as a module in case users need add new `Interval` types and want to test the axioms.+* Creates a new `IntervalAlgebra.RelationProperties` module containing a typeclass of property tests of the interval algebra. These were in the testing suite. Including this as a module in case users need add new `Interval` types and want to test the axioms.+* Adds `UTCTime`/`NominalDiffTime` instance for `IntervalSizeable`.+* Adds additional tests to the testing suite.+ ## 0.10.2  * Adds the `momentize` function for changing the duration of some interval value to a moment.@@ -10,7 +134,7 @@  ## 0.10.0 -* Adds `diffFromBegin` (`diffFromEnd`) functions (not totally satisfied with these names) which change the reference point of the interval in the second argument by the difference from the `begin` (`end`) of the interval in the first argument.+* Adds `shiftFromBegin` (`shiftFromEnd`) functions (not totally satisfied with these names) which change the reference point of the interval in the second argument by the difference from the `begin` (`end`) of the interval in the first argument. * Adds a `Functor` instance for `PairedInterval b`s, which maps an `PairedInterval c a` to `PairedInterval c b`. That is, `fmap` acts on the interval type.  ## 0.9.0

@@ -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,14 +1,16 @@ cabal-version:  2.2 name:           interval-algebra-version:        0.10.2+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-maintainer:     bsaul@novisci.com-copyright:      2020 NoviSci+author:         Bradley Saul, Brendan Brown+maintainer:     <bsaul@novisci.com> 2020-2022, <bbrown@targetrwe.com> 2023++copyright:      (c) NoviSci 2020-2022,+                    Target RWE 2023 license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple@@ -23,47 +25,94 @@ library   exposed-modules:       IntervalAlgebra+      IntervalAlgebra.Core       IntervalAlgebra.IntervalUtilities-      IntervalAlgebra.Arbitrary+      IntervalAlgebra.IntervalDiagram       IntervalAlgebra.PairedInterval+      IntervalAlgebra.Axioms+      IntervalAlgebra.RelationProperties+      IntervalAlgebra.Arbitrary   other-modules:       Paths_interval_algebra-  autogen-modules: +  autogen-modules:       Paths_interval_algebra   hs-source-dirs:       src   build-depends:       base >=4.7 && <5-    , time >=1.8 && <2-    , foldl == 1.4.12-    , containers >= 0.6-    , witherable >= 0.4-    , safe >= 0.3-    , QuickCheck == 2.14.2+    , binary ^>= 0.8+    , containers ^>= 0.6+    , deepseq >= 1.1 && < 1.5+    , foldl ^>= 1.4+    , prettyprinter ^>= 1.7+    , QuickCheck ^>= 2.14+    , text ^>= 1.2 || ^>= 2.0+    , time >= 1.9 && < 2   default-language: Haskell2010 +test-suite axioms+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      AxiomsSpec+  hs-source-dirs:+      test-axioms+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hspec < 2.12+    , interval-algebra+    , QuickCheck+    , time+  default-language: Haskell2010++test-suite relations+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      RelationPropertiesSpec+  hs-source-dirs:+      test-relation-properties+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , hspec < 2.12+    , interval-algebra+    , QuickCheck+    , time+  default-language: Haskell2010+ test-suite interval-algebra-test-  type: exitcode-stdio-1.0  -  -- this type means successful test run returns the zero exit code, -  -- and a failed test run returns a non-zero exit code-  main-is: Spec.hs +  type: exitcode-stdio-1.0+  main-is: Spec.hs   other-modules:       IntervalAlgebraSpec       IntervalAlgebra.IntervalUtilitiesSpec       IntervalAlgebra.PairedIntervalSpec       Paths_interval_algebra-  autogen-modules: +  autogen-modules:       Paths_interval_algebra   hs-source-dirs:       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      QuickCheck == 2.14.2-    , base >=4.7 && <5-    , hspec == 2.8.2-    , containers >= 0.6+      base >=4.7 && <5+    , containers+    , hspec < 2.12     , interval-algebra-    , time >=1.8 && <2-    , witherable >= 0.4-    , safe >= 0.3+    , QuickCheck+    , time+  build-tool-depends:+      hspec-discover:hspec-discover >= 2.9.2+  default-language: Haskell2010++executable tutorial+  main-is: TutorialMain.hs+  hs-source-dirs: tutorial+  build-depends:+      base >=4.7 && <5+    , containers ^>= 0.6+    , interval-algebra+    , prettyprinter ^>= 1.7+    , time >= 1.9 && < 2   default-language: Haskell2010

@@ -1,772 +1,30 @@ {-| 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 +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). +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.+This main module reexports @IntervalAlgebra.Core@, @IntervalAlgebra.IntervalUtilities@,+and @IntervalAlgebra.PairedInterval@, which is probably more than enough to get+going for most cases.  -} -{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}--module IntervalAlgebra(--    -- * Intervals-      Interval-    , Intervallic(..)-    , begin-    , end--    -- ** Create new intervals-    , parseInterval-    , beginerval-    , enderval--    -- ** Modify intervals  -    , expand-    , expandl-    , expandr--    -- * Interval Algebra --    -- ** Interval Relations and Predicates-    , IntervalRelation(..)--    {- |-    === Meets, Metby--    > x `meets` y-    > y `metBy` x--    @ -    x: |-----|-    y:       |-----| -    @-    -}-    , meets      , metBy--    {- |-    === Before, After--    > x `before` y-    > y `after` x--    @ -    x: |-----|  -    y:          |-----|-    @-    -}-    , before     , after--    {- |-    === Overlaps, OverlappedBy--    > x `overlaps` y-    > y `overlappedBy` x--    @ -    x: |-----|-    y:     |-----|-    @-    -}-    , overlaps   , overlappedBy--    {- |-    === Finishes, FinishedBy--    > x `finishes` y-    > y `finishedBy` x--    @ -    x:   |---| -    y: |-----|-    @-    -}-    , finishedBy , finishes--    {- |-    === During, Contains--    > x `during` y-    > y `contains` x--    @ -    x:   |-| -    y: |-----|-    @-    -}-    , contains   , during--    {- |-    === Starts, StartedBy--    > x `starts` y-    > y `startedBy` x--    @ -    x: |---| -    y: |-----|-    @-    -}-    , starts     , startedBy--    {- |-    === Equal--    > x `equal` y-    > y `equal` x--    @ -    x: |-----| -    y: |-----|-    @-    -}-    , equals--    -- ** Additional predicates and utilities-    , precedes, precededBy-    , disjoint , notDisjoint, concur-    , within, enclose, enclosedBy-    , (<|>)-    , predicate, unionPredicates-    , disjointRelations, withinRelations-    , ComparativePredicateOf1-    , ComparativePredicateOf2-    , beginervalFromEnd-    , endervalFromBegin-    , diffFromBegin-    , diffFromEnd-    , momentize--    -- ** Algebraic operations-    , intervalRelations-    , relate-    , compose-    , complement-    , union-    , intersection-    , converse--    -- * Combine two intervals-    , IntervalCombinable(..)-    , extenterval--    -- * Measure an interval-    , IntervalSizeable(..)--) where--import Prelude                  ( Eq, Show, Enum(..), Bounded(..)-                                , Maybe(..), Either(..), String, Bool(..)-                                , Integer, Int, Num-                                , map, otherwise, show-                                , any, negate, not-                                , replicate-                                , (++), (==), (&&), (+), (-), (!!))-import Data.Function            ( ($), id, (.), flip )-import Data.Functor             ( Functor(fmap) )-import Data.Ord                 ( Ord(..), Ordering(..), min, max )-import Data.Semigroup           ( Semigroup((<>)) )-import qualified Data.Set       ( Set-                                , fromList-                                , difference-                                , intersection-                                , union-                                , map-                                , toList )-import Data.Tuple               ( fst, snd )-import Data.Time as DT          ( Day-                                , addDays-                                , diffDays )-import Control.Applicative      ( Applicative(pure) )--{- | 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)---- | Safely parse a pair of @a@s to create an @'Interval' a@.------ >>> parseInterval 0 1--- Right (0, 1)--- --- >>> parseInterval 1 0--- Left "0<1"--- -parseInterval :: (Show a, Ord a) => a -> a -> Either String (Interval a)-parseInterval x y-    -- TODO: create more general framework for error handling-    |  y < x    = Left  $ show y ++ "<" ++ show x-    | otherwise = Right $ Interval (x, y)--intervalBegin :: (Ord a) => Interval a -> a-intervalBegin (Interval x) = fst x--intervalEnd :: (Ord a) => Interval a -> a-intervalEnd (Interval x) = snd x--instance Functor Interval where-    fmap f (Interval (x, y)) = Interval (f x, f y)--instance (Show a, Ord a) => Show (Interval a) where-   show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")"--{- | -The @'Intervallic'@ typeclass defines how to get and set the 'Interval' content-of a data structure. It also includes functions for getting the endpoints of the-'Interval' via @'begin'@ and @'end'@. -->>> getInterval (Interval (0, 10))-(0, 10)-->>> begin (Interval (0, 10))-0-->>> end (Interval (0, 10))-10--}-class (Ord a) => Intervallic i a where--    -- | Get the interval from an @i a@.-    getInterval :: i a -> Interval a--    -- | Set the interval in an @i a@.-    setInterval :: i a -> Interval a -> i a---- | Access the endpoints of an @i a@ .-begin, end :: Intervallic i a => i a -> a-begin = intervalBegin . getInterval-end   = intervalEnd . getInterval--{- | -The 'IntervalRelation' type and the associated predicate functions enumerate-the thirteen possible ways that two @'Interval'@ objects may 'relate' according-to Allen's interval algebra. Constructors are shown with their corresponding -predicate function.--}-data IntervalRelation =-      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?-meets, metBy  :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-meets x y = end x == begin y-metBy     = flip meets---- | Is x before y? Is x after y?-before, after, precedes, precededBy  :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-before   x y  = end x < begin y-after         = flip before-precedes      = before-precededBy    = after--- | Does x overlap y? Is x overlapped by y?-overlaps, overlappedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-overlaps x y  = begin x < begin y && end x < end y && end x > begin y-overlappedBy  = flip overlaps---- | Does x start y? Is x started by y?-starts, startedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-starts   x y  = begin x == begin y && end x < end y-startedBy     = flip starts---- | Does x finish y? Is x finished by y?-finishes, finishedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-finishes x y  = begin x > begin y && end x == end y-finishedBy    = flip finishes---- | Is x during y? Does x contain y?-during, contains :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-during   x y  = begin x > begin y && end x < end y-contains      = flip during---- | Does x equal y?-equals :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-equals   x y  = begin x == begin y && end x == end y---- | Operator for composing the union of two predicates-(<|>) :: (Intervallic i0 a, Intervallic i1 a)=>-       ComparativePredicateOf2 (i0 a) (i1 a)-    -> ComparativePredicateOf2 (i0 a) (i1 a)-    -> ComparativePredicateOf2 (i0 a) (i1 a)-(<|>) f g = unionPredicates [f, g]---- | 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]---- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')?-disjoint :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-disjoint    = predicate disjointRelations---- | Are x and y not disjoint (concur); i.e. do they share any support? This is---   the 'complement' of 'disjoint'.-notDisjoint, concur :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-notDisjoint = predicate (complement disjointRelations)-concur      = notDisjoint---- | Is x entirely *within* (enclosed by) the endpoints of y? That is, 'during', ---   'starts', 'finishes', or 'equals'?-within, enclosedBy:: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-within     = predicate withinRelations-enclosedBy = within---- | Does x enclose y? That is, is y 'within' x?-enclose :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-enclose  = flip enclosedBy---- | The 'Data.Set.Set' of all 'IntervalRelation's.-intervalRelations :: Data.Set.Set IntervalRelation-intervalRelations = Data.Set.fromList (Prelude.map toEnum [0..12] ::[IntervalRelation])---- | Find the converse of a single 'IntervalRelation'-converseRelation :: IntervalRelation  -> IntervalRelation-converseRelation x = toEnum (12 - fromEnum x)---- | Shortcut to creating a 'Set IntervalRelation' from a list.-toSet :: [IntervalRelation ] -> Data.Set.Set IntervalRelation-toSet = Data.Set.fromList---- | Compose a list of interval relations with _or_ to create a new--- @'ComparativePredicateOf1' i a@. For example, --- @unionPredicates [before, meets]@ creates a predicate function determining--- if one interval is either before or meets another interval.-unionPredicates :: [ComparativePredicateOf2 a b] -> ComparativePredicateOf2 a b-unionPredicates fs x y = any (\ f -> f x y) fs---- | Maps an 'IntervalRelation' to its corresponding predicate function.-toPredicate :: (Intervallic i0 a, Intervallic i1 a) =>-           IntervalRelation-        -> ComparativePredicateOf2 (i0 a) (i1 a)-toPredicate r =-    case r of-        Before       -> before-        Meets        -> meets-        Overlaps     -> overlaps-        FinishedBy   -> finishedBy-        Contains     -> contains-        Starts       -> starts-        Equals       -> equals-        StartedBy    -> startedBy-        During       -> during-        Finishes     -> finishes-        OverlappedBy -> overlappedBy-        MetBy        -> metBy-        After        -> after---- | Given a set of 'IntervalRelation's return a list of 'predicate' functions ---   corresponding to each relation.-predicates :: (Intervallic i0 a, Intervallic i1 a)=>-           Data.Set.Set IntervalRelation-        -> [ComparativePredicateOf2 (i0 a) (i1 a)]-predicates x = Prelude.map toPredicate (Data.Set.toList x)---- | Forms a predicate function from the union of a set of 'IntervalRelation's.-predicate :: (Intervallic i0 a, Intervallic i1 a)=>-           Data.Set.Set IntervalRelation-        -> ComparativePredicateOf2 (i0 a) (i1 a)-predicate = unionPredicates.predicates---- | The lookup table for the compositions of interval relations.-composeRelationLookup :: [[[IntervalRelation]]]-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 :: (Intervallic i0 a, Intervallic i1 a) => i0 a -> i1 a -> IntervalRelation-relate x y-    | x `before` y       = Before-    | x `after`  y       = After-    | x `meets`  y       = Meets-    | x `metBy`  y       = MetBy-    | x `overlaps` y     = Overlaps-    | x `overlappedBy` y = OverlappedBy-    | x `starts` y       = Starts-    | x `startedBy` y    = StartedBy-    | x `finishes` y     = Finishes-    | x `finishedBy` y   = FinishedBy-    | x `during` y       = During-    | x `contains` y     = Contains-    | otherwise          = Equals---- | 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 :: b-    moment = 1--    -- | Gives back a 'moment' based on the input's type.-    moment' :: Intervallic i a => i a -> b-    moment' x = moment @a--    -- | Determine the duration of an @'i a'@.-    duration :: Intervallic i a => 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. ------ >>> expand 0 0 (Interval (0::Int, 2::Int))--- (0, 2)------ >>> expand 1 1 (Interval (0::Int, 2::Int))--- (-1, 3)----expand :: (IntervalSizeable a b, Intervallic i a) =>-           b -- ^ duration to subtract from the 'begin'-        -> b -- ^ duration to add to the 'end'-        -> i a-        -> i a-expand l r p = setInterval p i-  where s = if l < moment' p then 0 else negate l-        e = if r < moment' p then 0 else r-        i = Interval (add s $ begin p, add e $ end p)---- | Expands an @i a@ to "left".------ >>> expandl 2 (Interval (0::Int, 2::Int))--- (-2, 2)----expandl :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a-expandl i = expand i 0---- | Expands an @i a@ to "right".------ >>> expandr 2 (Interval (0::Int, 2::Int))--- (0, 4)----expandr :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a-expandr = expand 0---- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding ---   @max 'moment' dur@ to @x@ as the 'end'.------ >>> beginerval (0::Int) (0::Int)--- (0, 1)------ >>> beginerval (1::Int) (0::Int)--- (0, 1)------ >>> beginerval (2::Int) (0::Int)--- (0, 2)----beginerval :: (IntervalSizeable a b) =>-           b -- ^ @dur@ation to add to the 'begin' -        -> a -- ^ the 'begin' point of the 'Interval'-        -> Interval a-beginerval dur x = Interval (x, y)-    where i = Interval (x, x)-          d = max (moment' i) dur-          y = add d x-{-# INLINABLE 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 :: (IntervalSizeable a b) =>-          b -- ^ @dur@ation to subtract from the 'end' -       -> a -- ^ the 'end' point of the 'Interval'-       -> Interval a-enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x)-    where i = Interval (x, x)-{-# INLINABLE enderval #-}---- | Creates a new Interval from the 'end' of an @i a@.-beginervalFromEnd :: (IntervalSizeable a b, Intervallic i a) =>-        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 a) => -       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)---- | Creates a new @Interval@ spanning the extent x and y.------ >>> extenterval (Interval (0, 1)) (Interval (9, 10))--- (0, 10)----extenterval :: Intervallic i a => i a -> i a -> Interval a-extenterval x y = Interval (s, e)-    where s = min (begin x) (begin y)-          e = max (end x) (end y)---- | Modifies the endpoints of second argument's interval by taking the difference---   from the first's input's 'begin'. --- >>> diffFromBegin (Interval ((5::Int), 6)) (Interval (10, 15))--- (5, 10)------ >>> diffFromBegin (Interval ((1::Int), 2)) (Interval (3, 15))--- (2, 14)----diffFromBegin :: ( IntervalSizeable a b-                 , Functor i1-                 , Intervallic i0 a ) => -    i0 a -> i1 a -> i1 b-diffFromBegin i = fmap (`diff` begin i)---- | Modifies the endpoints of second argument's interval by taking the difference---   from the first's input's 'end'.--- >>> diffFromEnd (Interval ((5::Int), 6)) (Interval (10, 15))--- (4, 9)------ >>> diffFromEnd (Interval ((1::Int), 2)) (Interval (3, 15))--- (1, 13)----diffFromEnd :: ( IntervalSizeable a b-               , Functor i1-               , Intervallic i0 a ) => -    i0 a -> i1 a -> i1 b-diffFromEnd i = fmap (`diff` end i)---- | Changes the duration of an 'Intervallic' value to a moment starting at the ---   'begin' of the interval.--- --- >>> momentize (Interval (6, 10))--- (6, 7)----momentize :: ( IntervalSizeable a b, Intervallic i a ) =>-    i a -> i a-momentize i = setInterval i (beginerval (moment' i) (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 (Intervallic i a) => IntervalCombinable i a where--    -- | Maybe form a new @i a@ by the union of two @i a@s that 'meets'.-    (.+.) ::  i a -> i a -> Maybe (i a)-    (.+.) 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)--{--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 (Ord a) => Intervallic Interval a 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 ( getInterval x ) <> pure ( getInterval 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   = (-)+module IntervalAlgebra+  ( module IntervalAlgebra.Core+  , module IntervalAlgebra.IntervalUtilities+  , module IntervalAlgebra.PairedInterval+  ) where -instance IntervalSizeable DT.Day Integer where-    moment = 1-    add    = addDays-    diff   = diffDays+import           IntervalAlgebra.Core+import           IntervalAlgebra.IntervalDiagram+import           IntervalAlgebra.IntervalUtilities+import           IntervalAlgebra.PairedInterval

@@ -1,33 +1,139 @@ {-| 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 NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -module IntervalAlgebra.Arbitrary() where -import Test.QuickCheck      ( Arbitrary(arbitrary, shrink) )-import GHC.Int              ( Int )-import GHC.Num              ( Num((+), negate) )-import Control.Applicative  ( (<$>) )-import Control.Monad        ( liftM2 )-import IntervalAlgebra      (Interval, beginerval)-import Data.Function        ( (.) )-import Data.Time as DT      ( Day(ModifiedJulianDay), toModifiedJulianDay)+module IntervalAlgebra.Arbitrary where +import           Control.Applicative (liftA2, (<$>))+import           Control.Monad       (liftM2)+import           Data.Bool+import           Data.Fixed+import           Data.Function       (flip, ($), (.))+import           Data.Maybe          (Maybe (Just, Nothing))+import           Data.Ord+import qualified Data.Set            (Set, difference, null, singleton)+import           Data.Time           as DT (Day (ModifiedJulianDay), DiffTime,+                                            NominalDiffTime, UTCTime (..),+                                            picosecondsToDiffTime,+                                            secondsToDiffTime,+                                            secondsToNominalDiffTime,+                                            toModifiedJulianDay)+import           GHC.Float+import           GHC.Int             (Int)+import           GHC.Num+import           GHC.Real+import           IntervalAlgebra     (Interval, IntervalRelation (..),+                                      Intervallic, PairedInterval, Point,+                                      SizedIv (..), beginerval, converse,+                                      duration, makePairedInterval, moment,+                                      predicate, strictWithinRelations)+import           Test.QuickCheck     (Arbitrary (arbitrary, shrink), Gen,+                                      NonNegative, arbitrarySizedNatural,+                                      elements, resize, sized, suchThat)++-- NOTE: the default size for arbitrary :: Gen Int appears to be 30+arbitrarySizedPositive :: Integral a => Gen a+arbitrarySizedPositive = (+ 1) <$> arbitrarySizedNatural++-- resize in utctDayTime is to avoid rare leap-seconds-related failure, in+-- which e.g.  1858-12-31 00:00:00 UTC /= 1858-12-30 23:59:60 UTC+maxDiffTime :: Int+maxDiffTime = 86399++--instance Arbitrary DT.DiffTime where+--  arbitrary = sized+--+--+--instance Arbitrary DT.UTCTime  where+--  arbitrary = liftA2 UTCTime arbitrary arbitrary++-- 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++-- Generators for types that do not implement Arbitrary. This avoids creating+-- orphan instances for these types.++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 = liftM2 beginerval arbitrary arbitrary+  arbitrary = sized (\s -> sizedIntervalGen s arbitrary arbitrary) -instance Arbitrary DT.Day where-    arbitrary = DT.ModifiedJulianDay . (2000 +) <$> arbitrary-    shrink    = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay+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 = liftM2 beginerval arbitrary arbitrary+  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.+-- If @iv@ and @rs@ are such that no possible relations can be generated, this+-- function returns `Nothing`. Otherwise, it returns `Just` an interval that+-- satisfies at least one of the possible relations in @rs@ relative to+-- @iv@.+--+-- @+-- > import Test.QuickCheck (generate)+-- > import Data.Set (fromList)+-- > isJust $ generate $ arbitraryWithRelation (beginerval 10 (0::Int)) (fromList [Before])+-- Just (20, 22)+-- > generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy])+-- Nothing+-- > generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy, Before])+-- Just (4, 13)+-- @+--+arbitraryWithRelation+  :: forall i a b+   . (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 (Interval a))+arbitraryWithRelation iv rs+  | rs == Data.Set.singleton Equals = elements [Just iv]+  | isEnclose && isMom = elements [Nothing]+  | isMom = Just <$> arbitrary `suchThat` predicate notStrictEnclose iv+  | otherwise = Just <$> arbitrary `suchThat` predicate rs iv+ where+  notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations)+  isEnclose        = Data.Set.null notStrictEnclose+  isMom            = duration iv == moment @(Interval a)

@@ -0,0 +1,341 @@+{- HLINT ignore -}+{-|+Module      : Interval Algebra Axioms+Description : Properties of Intervals+Copyright   : (c) NoviSci, Inc 2020-2022+                  TargetRWE, 2023+License     : BSD3+Maintainer  : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023++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 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           IntervalAlgebra.Arbitrary+import           IntervalAlgebra.Core+import           IntervalAlgebra.IntervalUtilities ((.+.))+import           Test.QuickCheck                   (Arbitrary (arbitrary),+                                                    Property, (===), (==>))+++xor :: Bool -> Bool -> Bool+xor a b = a /= b++-- | Internal function for converting a number to a strictly positive value.+makePos :: (Ord b, Num b) => b -> b+makePos x | x == 0    = x + 1+          | x < 0     = negate x+          | 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)++instance Arbitrary (M1set Int) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m1set x a b <$> arbitrary++instance Arbitrary (M1set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m1set x a b <$> arbitrary++instance Arbitrary (M1set DT.UTCTime) where+  arbitrary = do+    x <- 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)++instance Arbitrary (M2set Int) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m2set x a b <$> arbitrary++instance Arbitrary (M2set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m2set x a b <$> arbitrary++instance Arbitrary (M2set DT.UTCTime) where+  arbitrary = do+    x <- arbitrary+    a <- 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)++instance Arbitrary (M5set Int) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    m5set x a <$> arbitrary++instance Arbitrary (M5set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    m5set x a <$> arbitrary++instance Arbitrary (M5set DT.UTCTime) where+  arbitrary = do+    x <- arbitrary+    a <- genNominalDiffTime+    m5set x a <$> genNominalDiffTime++-- Axiom functions++-- | 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:++\[+  \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:++  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.++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 :: (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.++\[+  \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.++\[+\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:++\[+\forall i \exists j,k s.t. j:i:k+\]+-}++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.++\[+\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 :: (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.++\[+\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:++\[+\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

@@ -0,0 +1,1619 @@+{-# 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))

@@ -0,0 +1,778 @@+{-|+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,++>>> let ref = bi 30 (0 :: Int)+>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]+>>> pretty $ simpleIntervalDiagram ref ivs+--+          -----+                ------+==============================++Such diagrams are useful for documentation, examples,+and learning to reason with the interval algebra.++There are two main functions available:++* @'parseIntervalDiagram'@:+exposes all available options+and gives the most flexibility in producing diagrams+* @'simpleIntervalDiagram'@+produces simple diagram using defaults.+-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE UndecidableInstances  #-}++module IntervalAlgebra.IntervalDiagram+  (+  -- * Make nice-looking diagrams of intervals+  {-|+  All these functions return an @'IntervalDiagram'@,+  which can then be pretty printed using the @'Prettyprinter.pretty'@ function.+  -}+    parseIntervalDiagram+  , simpleIntervalDiagram+  , standardExampleDiagram++  -- * Diagram options+  , IntervalDiagramOptions(..)+  , defaultIntervalDiagramOptions+  , AxisPlacement(..)++  -- * Internal types+  , IntervalText+  , IntervalDiagram++  -- * Errors+  , IntervalTextLineParseError(..)+  , AxisParseError(..)+  , IntervalDiagramOptionsError(..)+  , IntervalDiagramParseError(..)++  -- * Re-exports+  , Prettyprinter.Pretty(..)+  ) where++import           Data.Foldable                     (Foldable (toList))+import qualified Data.List.NonEmpty                as NE hiding (toList)+import           Data.Maybe                        (fromMaybe, isNothing)+import           Data.Text                         (Text, pack)+import           IntervalAlgebra.Core+import           IntervalAlgebra.IntervalUtilities (rangeInterval)+import           IntervalAlgebra.PairedInterval    (PairedInterval, getPairData,+                                                    makePairedInterval)+import           Prettyprinter++-- $setup+-- >>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings+-- >>> import IntervalAlgebra.IntervalUtilities+-- >>> import Data.Time++{-+The key Type in this module is the IntervalDiagram,+which has several components.+Each component in sections below organized as follows:+ * Type(s)+ * (optional) Instances+ * (optional) parser+ * (optional) utilities+-}++{-------------------------------------------------------------------------------+  IntervalText+-------------------------------------------------------------------------------}++{-|+@IntervalText@ is an internal type+which contains an @Interval a@ and the @Char@ used to print+the interval in a diagram.++>>> pretty $ makeIntervalText '-' (beginerval 5 (0::Int))+-----+>>> pretty $ makeIntervalText '*' (beginerval 10 (0::Int))+**********+-}++newtype IntervalText a = MkIntervalText (PairedInterval Char a) deriving (Eq, Show)++makeIntervalText :: Char -> Interval a -> IntervalText a+makeIntervalText c = MkIntervalText . makePairedInterval c++instance Intervallic IntervalText where+  getInterval (MkIntervalText x) = getInterval x+  setInterval (MkIntervalText x) i = MkIntervalText $ setInterval x i++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+    i = getInterval x++{-------------------------------------------------------------------------------+  IntervalTextLine+-------------------------------------------------------------------------------}++{-|+The @IntervalTextLine@ is an internal type+containing a list of @IntervalText@.++Values of this type should only be created+through the 'parseIntervalTextLine' function,+which checks that the inputs are parsed correctly to form intervals+that will be pretty-printed correctly.++>>> let i1 =  makeIntervalText '*' (beginerval 10 (5::Int))+>>> let i2  = makeIntervalText '-' (beginerval 2 (1::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+UnsortedIntervals+>>> let i1 =  makeIntervalText '*' (beginerval 10 (5::Int))+>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+ConcurringIntervals+>>> let i1 =  makeIntervalText '*' (beginerval 10 ((-1)::Int))+>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine []  [i1, i2]+>>> pretty x+BeginsLessThanZero+>>> let i1 =  makeIntervalText '*' (beginerval  5 (0::Int))+>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+*****     --+>>> let i1 =  makeIntervalText '*' (beginerval  5 (5::Int))+>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+     *****--+>>> let i1 =  makeIntervalText '*' (beginerval  1 (5::Int))+>>> let i2  = makeIntervalText '-' (beginerval 1 (7::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+     * -+>>> let i1 =  makeIntervalText '*' (beginerval  3 (5::Int))+>>> let i2 = makeIntervalText '-' (beginerval 5 (10::Int))+>>> let i3 = makeIntervalText '#' (beginerval 1 17)+>>> pretty $ parseIntervalTextLine [] [i1, i2, i3]+     ***  -----  #+-}+data IntervalTextLine a = MkIntervalTextLine [IntervalText a] [Text]+  deriving Show++{-+NOTE:+a pretty-printed @IntervalTextLine@ does not print its labels.+Line labels are printed by @IntervalDiagram@.+This is because line labels are vertically aligned across lines,+and without the other lines we don't know where to align labels.+-}+instance Pretty (IntervalTextLine Int) where+  pretty (MkIntervalTextLine ivs _) =+    concatWith (<>) (fmap (\x -> indent (begin x) (pretty x)) ivs)++instance Pretty (Either IntervalTextLineParseError (IntervalTextLine Int)) where+  pretty (Left  e) = pretty $ show e+  pretty (Right l) = pretty l++{-|+A type representing errors that may occur+when a list of @IntervalText@ is parsed into a @IntervalTextLine@.+-}+data IntervalTextLineParseError =+    -- | The inputs contains concurring intervals.+    --   All inputs should be @'disjoint'@.+      ConcurringIntervals+    -- | The inputs are not sorted.+    | UnsortedIntervals+    -- | At least one of the inputs has a @'begin'@ less than zero.+    | BeginsLessThanZero+     deriving (Eq, Show, Ord)++{-|+Parses a list of @IntervalText Int@+into an @IntervalTextLine Int@,+handling the types of parse errors that could occur.++See 'IntervalTextLine' for examples.+-}+parseIntervalTextLine+  :: [Text]+  -> [IntervalText Int]+  -> Either IntervalTextLineParseError (IntervalTextLine Int)+parseIntervalTextLine labs l =+  let vals = NE.nonEmpty l+  in  if+        | any (uncurry concur) (pairs l) -> Left ConcurringIntervals+        | (not . isSorted . fmap getInterval) l -> Left UnsortedIntervals+        | any ((< 0) . begin) l -> Left BeginsLessThanZero+        | otherwise -> case vals of+          Nothing -> Right (MkIntervalTextLine [] [])+          Just v ->+            -- The use of makeIntervalLine is important here+            -- in order to get the intervals positioned correctly+            Right $ MkIntervalTextLine (toList (makeIntervalLine v)) labs+ where+  {-+  Modifies the inputs sequentially+  so that the begin of one interval is+  shifted based on the end of the previous interval.+  This function assumes that the inputs are sorted and disjoint.+  -}+  makeIntervalLine+    :: NE.NonEmpty (IntervalText Int) -> NE.NonEmpty (IntervalText Int)+  makeIntervalLine x =+    NE.head x NE.:| zipWith shiftFromEnd (toList x) (NE.tail x)++  -- Creates all pairs of a list+  pairs = go+   where+    go []       = []+    go (x : xs) = fmap (x, ) xs <> go xs+  isSorted xs = and $ zipWith (<=) xs (tail xs)+++{-------------------------------------------------------------------------------+  Axis Config and Components+-------------------------------------------------------------------------------}++{-|+A type representing options of where to place the axis in a printed diagram.+-}+data AxisPlacement =+  -- | Print the axis at the top of the diagram+    Top+  -- | Print the axis at the bottom of the diagram+  | Bottom deriving (Eq, Show)++{-|+Key-value list data that can be presented below the axis on an+@IntervalDiagram@. First element of the tuple is an Int key, the second the+Char to print. Note that it does not guarantee uniqueness of the keys, and most+if not all functions should first call @intMapList@ on the internal+@NE.NonEmpty@ list before using this type.+-}+newtype AxisLabels = MkAxisLabels (NE.NonEmpty (Int, Char))+  deriving (Eq, Show)++{-|+A type containing information on+how to configure the axis of an 'IntervalDiagram'.+-}+data AxisConfig = MkAxisConfig+  { placement :: Maybe AxisPlacement+  , labels    :: Maybe AxisLabels+  }+  deriving (Eq, Show)++-- Internal utility to give equivalent structure to IntMap from+-- Data.IntMap.NonEmpty for the key-value list in @AxisLabels@. Previously,+-- when using IntMap for the @AxisLabels@ container, uniqueness and ordering of+-- keys was guaranteed. Now, you should first call this function before using+-- those keys, e.g. in @prettyAxisLabels@, to get the same properties. This has+-- a runtime cost and could be rewritten for efficiency if that were a concern.+-- NOTE: NE does not have a sortOn.+intMapList :: NE.NonEmpty (Int, a) -> NE.NonEmpty (Int, a)+intMapList = NE.sortBy (\(k, _) (k', _) -> compare k k')+  . NE.nubBy (\(k, _) (k', _) -> k == k')++prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann]+prettyAxisLabels pos (MkAxisLabels labs) = do+  let labssorted = intMapList labs+  let ints       = NE.map fst labssorted+  let marks      = toList $ NE.map snd labssorted+  let labPos =+        NE.head ints : zipWith (\x y -> y - x - 1) (toList ints) (NE.tail ints)+  let out =+        [ hcat $ fmap (\i -> indent i (pretty '|')) labPos+        , hcat $ zipWith indent labPos (pretty <$> marks)+        ]+  case pos of+    Top    -> reverse out+    Bottom -> out++{-------------------------------------------------------------------------------+  Axis+-------------------------------------------------------------------------------}++{-|+A type containing the data necessary to print an axis in an 'IntervalDiagram'.++Use 'parseAxis' for construction.++>>> let ref = makeIntervalText '=' (beginerval 10 (0::Int))+++>>> let b = parseAxis [] (Just Top) ref+>>> pretty b+==========++>>> let c = parseAxis [(4, 'a'), (6, 'b')] (Just Top) ref+>>> pretty c+    a b+    | |+==========++>>> let d = parseAxis [(4, 'a'), (6, 'b')] (Just Bottom) ref+>>> pretty d+==========+    | |+    a b++>>> let e = parseAxis [(4, 'a'), (4, 'b')] (Just Top) ref+>>> pretty e+MultipleLabelAtSamePosition++>>> let f = parseAxis [(4, 'a'), (19, 'b')] (Just Top) ref+>>> pretty f+LabelsBeyondReference++-}+data Axis = MkAxis+  { refInterval :: IntervalText Int+  , config      :: AxisConfig+  }+  deriving (Eq, Show)++instance Pretty Axis where+  pretty (MkAxis ref (MkAxisConfig Nothing  _      )) = emptyDoc+  pretty (MkAxis ref (MkAxisConfig (Just _) Nothing)) = pretty ref+  pretty (MkAxis ref (MkAxisConfig (Just Bottom) (Just labels))) =+    vcat $ pretty ref : prettyAxisLabels Bottom labels+  pretty (MkAxis ref (MkAxisConfig (Just Top) (Just labels))) =+    vcat $ prettyAxisLabels Top labels ++ [pretty ref]++instance Pretty ( Either AxisParseError Axis ) where+  pretty (Left  e) = pretty $ show e+  pretty (Right a) = pretty a++{-|+A type representing errors that can occur when parsing an axis.+-}+data AxisParseError =+  -- | Indicates that the position of one ore more axis labels+  --   is outside the reference interval+    LabelsBeyondReference+  -- | Indicates that multiple labels have been put at the same position+  | MultipleLabelAtSamePosition+  deriving (Eq, Show)++{-|+Safely create an @Axis@.++See @Axis@ for examples.+-}+parseAxis+  :: [(Int, Char)]+  -> Maybe AxisPlacement+  -> IntervalText Int+  -> Either AxisParseError Axis+-- if the axis is not shown then any labels are ignored+parseAxis _ Nothing  i = Right $ MkAxis i (MkAxisConfig Nothing Nothing)+parseAxis l (Just p) i = do+  let labels          = intMapList <$> NE.nonEmpty l+  let labPos          = NE.map fst <$> labels+  let inputLabelCount = length l+  if+    |+-- Flag if any of the label positions are beyond the reference interval+      any (\x -> x < begin i || x > end i) (fmap fst l) -> Left+      LabelsBeyondReference+    |+-- Identify if the number of elements in the input list is different+-- from the number of elements after transforming the list+-- into a nonempty IntMap.+-- If different, then flag.+      inputLabelCount > 0 && fmap length labels /= Just inputLabelCount -> Left+      MultipleLabelAtSamePosition+    |+-- Otherwise, we have a good Axis.+      otherwise -> Right+    $  MkAxis i (MkAxisConfig (Just p) (fmap MkAxisLabels labels))++{-------------------------------------------------------------------------------+  IntervalDiagramOptions+-------------------------------------------------------------------------------}++{-|+A record containing options for printing an @'IntervalDiagram'@.+-}+data IntervalDiagramOptions = MkIntervalDiagramOptions+  { -- | See 'PrettyPrinter.LayoutOptions'+    layout      :: LayoutOptions+    -- | Number of spaces to pad the left of the diagram by.+    --   Must be greater than or equal to @0@.+  , leftPadding :: Int+  }+  deriving (Eq, Show)++{-|+A type representing the types of invalid @'IntervalDiagramOptions'@.+-}+data IntervalDiagramOptionsError =+  -- | Indicates that @'PageWidth'@ is @Unbounded@,+  --   which isn't allowed for an IntervalDiagram.+    UnboundedPageWidth+  -- | Indicates that the left padding in the option is < 0.+  | LeftPaddingLessThan0+  deriving (Eq, Show)++{-|+Takes an initial set of options+and checks that the values are valid,+returning an error if not.++Sorry the indirection in that the input type is also in the output type.+Better might be something like+PossibleOptions -> Either Error ValidOptions+But this works and this code is not exposed to the user.+-}+parseDiagramOptions+  :: IntervalDiagramOptions+  -> Either IntervalDiagramOptionsError IntervalDiagramOptions+parseDiagramOptions opts = if+  | leftPadding opts < 0                       -> Left LeftPaddingLessThan0+  | layoutPageWidth (layout opts) == Unbounded -> Left UnboundedPageWidth+  | otherwise                                  -> Right opts+  where isSorted xs = and $ zipWith (<=) xs (tail xs)++-- | Default 'IntervalDiagramOptions' options+defaultIntervalDiagramOptions :: IntervalDiagramOptions+defaultIntervalDiagramOptions = MkIntervalDiagramOptions defaultLayoutOptions 0++{-------------------------------------------------------------------------------+  IntervalDiagram+-------------------------------------------------------------------------------}++{-|+Type containing the data needed to pretty print an interval document.+-}+data IntervalDiagram a = MkIntervalDiagram+  { -- | The reference interval is the interval based on which 'intervalValues'+   --    are transformed.+   --    It is the only interval that retains the original type.+    reference      :: Interval a+  , axis           :: Axis+  , intervalValues :: [IntervalTextLine Int]+  , options        :: IntervalDiagramOptions+  }+  deriving Show++{-|+Type representing errors that may occur+when parsing inputs into an @'IntervalDiagram'@.++Not every possible state of a "bad" diagram is currently captured+by 'parseIntervalDiagram'.+In particular, line labels can be a source of problems.+The labels accept arbitrary @Text@.+Newline characters in a label would, for example, throw things off.+Labels that extend beyond the @'PrettyPrinter.pageWidth'@+will also cause problems.++-}+data IntervalDiagramParseError =+  -- | Indicates that one or more of the input intervals extend beyond the axis.+    IntervalsExtendBeyondAxis+  -- | Indicates that the reference axis is longer than the @'PageWidth'@+  --   given in the @'IntervalDiagramOptions'@.+  | AxisWiderThanAvailable+  -- | Indicates that left padding is >0+  --   and no axis is printed.+  --   This is considered an error because it be impossible+  --   to know the 'begin' values of intervals in a printed @IntervalDiagram@+  --   that has been padded and has no axis.+  | PaddingWithNoAxis+  -- | Indicates that an error occurring when checking the document options.+  | OptionsError IntervalDiagramOptionsError+  -- | Indicates something is wrong with the @Axis@.+  | AxisError AxisParseError+  -- | Indicates that at least one error occurred when parsing the interval lines.+  | IntervalLineError IntervalTextLineParseError+  deriving (Eq, Show)++instance (SizedIv (Interval a)) => Pretty (IntervalDiagram a) where+  pretty (MkIntervalDiagram _ axis ivs opts) = do++    -- Create a list of pretty IntervalLines+    let intervalLines = fmap pretty ivs++    -- Get the length of the reference interval+    -- in order to determine the column position of line labels+    let refDur        = end (refInterval axis)++    -- Position line labels relative to the reference interval+    -- and the end of the last interval in a line.+    -- NOTE:+    -- This is tricky because the intervals+    -- in a parsed IntervalTextLine are referenced relative+    -- to the previous interval in the line,+    -- not to the reference interval.+    -- 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 ((-) refDur . intervalLineEnd) ivs++    -- Create a list of the line label docs+    let labelLines =+          zipWith (\i l -> indent l (prettyLineLabel i)) ivs labelIndents++    -- Zip together each interval line and its labels horizontally,+    -- then stack all the lines.+    let intervalDiagram = vsep $ zipWith (<>) intervalLines labelLines++    -- Add the the axis in the appropriate position.+    let mainDiagram = case (placement . config) axis of+          Nothing     -> intervalDiagram+          Just Top    -> vcat [pretty axis, intervalDiagram]+          Just Bottom -> vcat [intervalDiagram, pretty axis]++    -- Add any left padding.+    indent (leftPadding opts) mainDiagram++   where+    intervalLineEnd :: IntervalTextLine Int -> Int+    intervalLineEnd (MkIntervalTextLine x _) = sum $ fmap end x++    prettyLineLabel :: IntervalTextLine Int -> Doc ann+    prettyLineLabel (MkIntervalTextLine _ t) = if null t+      then emptyDoc+      else space <> pretty ("<-" :: Text) <> space <> pretty t++instance (SizedIv (Interval a)) =>+  Pretty (Either IntervalDiagramParseError (IntervalDiagram a)) where+  pretty (Left  e) = pretty $ show e+  pretty (Right d) = pretty d++{-|+Parse inputs into a pretty printable document.++This function provides the most flexibility in producing interval diagrams.++Here's a basic diagram that shows+how to put more than one interval interval on a line:++>>> let mkIntrvl c d b = makeIntervalText c (bi d (b :: Int))+>>> let x = mkIntrvl  '=' 20 0+>>> let l1 = [ mkIntrvl '-' 1 4 ]+>>> let l2 = [ mkIntrvl '*' 3 5, mkIntrvl '*' 5 10, mkIntrvl 'x' 1 17 ]+>>> let l3 = [ mkIntrvl '#' 2 18]+>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions  [] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]+    -+     ***  *****  x+                  ##+====================+++We can put the axis on the top:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Top) x [ (l1, []), (l2, []), (l3, []) ]+====================+    -+     ***  *****  x+                  ##+++We can annotate the axis:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [(5, 'a')] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]+    -+     ***  *****  x+                  ##+====================+     |+     a+++We can also annotate each line with labels:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Bottom) x [ (l1, ["line1"]), (l2, ["line2a", "line2b"]), (l3, ["line3"])  ]+    -                <- [line1]+     ***  *****  x   <- [line2a, line2b]+                  ## <- [line3]+====================+++The parser tries to check that the data can be printed.+For example, the default @'Prettyprinter.LayoutOptions'@ is 80 characters.+Providing an reference interval wider than 80 characters+results in an error.++>>> let x = mkIntrvl '=' 100 5+>>> let ivs = [ mkIntrvl '-' 1 1 ]+>>> parseIntervalDiagram defaultIntervalDiagramOptions [] Nothing x [ (ivs, []) ]+Left AxisWiderThanAvailable++See 'IntervalDiagramParseError' for all the cases handled.++-}+parseIntervalDiagram+  :: (Ord a, SizedIv (Interval a), Enum a, Num a, Enum (Moment (Interval a)))+  => IntervalDiagramOptions+  -- ^ Document options (see 'IntervalDiagramOptions')+  -> [(Int, Char)]+  -- ^ A list of axis labels+  -> Maybe AxisPlacement+  -- ^ An optional 'AxisPlacement' of the axis+  -> IntervalText a+  -- ^ The reference (axis interval)+  -> [([IntervalText a], [Text])]+  -- ^ Intervals to include in the diagram.+  -- Each item in the list creates a new line in the printed diagram.+  -- Text creates an optional label for the line.+  -> Either IntervalDiagramParseError (IntervalDiagram a)+parseIntervalDiagram opts labels placement ref ivs =+  case parseDiagramOptions opts of+    Left  e -> Left $ OptionsError e+    Right o -> if+      |+-- check that the duration of the reference intervall+-- does not exceed the page width+        checkAvailableChar (layoutPageWidth $ layout o)+      -> Left AxisWiderThanAvailable+      |+-- check none of the interval extend beyond the reference interval+        any (extendsBeyond ref) (concatMap fst ivs)+      -> Left IntervalsExtendBeyondAxis+      |+-- check that padding == 0 and axis is displayed+        leftPadding o > 0 && isNothing placement+      -> Left PaddingWithNoAxis+      | otherwise+      -> let parsedReferencedIntervals = traverse+               (\(i, t) -> parseIntervalTextLine t (rereferenceL ref i))+               ivs+         in  case parsedReferencedIntervals of+               Left e -> Left $ IntervalLineError e+               Right vals ->+                 let parsedAxis =+                       parseAxis labels placement (rereference ref ref)+                 in  case parsedAxis of+                       Left e -> Left $ AxisError e+                       Right axis ->+                         Right $ MkIntervalDiagram (getInterval ref) axis vals o+ where+  extendsBeyond =+    before <|> meets <|> overlaps <|> overlappedBy <|> metBy <|> after+  checkAvailableChar (AvailablePerLine i _) = fromEnum (duration $ getInterval ref) > i+  checkAvailableChar Unbounded              = True+  {-+    Shifts the endpoints of an interval to be referenced from another interval,+    so that the 'begin' of the reference interval acts as the "zero" point.+  -}+  rereference x = fromEnumInterval . shiftFromBegin x+  rereferenceL x = fmap (rereference x)++{-|+Given a reference interval and a list of intervals,+produces an 'IntervalDiagram' with one line per interval,+using the 'defaultIntervalDiagramOptions'.++>>> pretty $ simpleIntervalDiagram (bi 10 (0 :: Int)) (fmap (bi 1) [0..9])+-+ -+  -+   -+    -+     -+      -+       -+        -+         -+==========++>>> let ref = bi 30 (0 :: Int)+>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]+>>> pretty $ simpleIntervalDiagram ref ivs+--+          -----+                ------+==============================+-}+simpleIntervalDiagram+  :: (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)+simpleIntervalDiagram ref ivs = parseIntervalDiagram+  defaultIntervalDiagramOptions+  []+  (Just Bottom)+  (makeIntervalText '=' (getInterval ref))+  (fmap (\x -> (pure $ makeIntervalText '-' $ getInterval x, [])) ivs)++{- | Given various inputs containing intervals and their label, creates an+interval diagram with labels, along with a reference range that spans all of the+intervals and is extended to include 0 if necesary.++In more detail, an interval diagram is created with one row in the diagram for+each interval and label pair provided as the first input, and followed by a+sequence of additional rows with one row per list element in the second input+and such that each row displays each interval provided in the intervals list and+label pair.++>>> x1 = beginerval 4 1+>>> x2 = beginerval 3 7+>>> x3 = beginerval 2 13+>>> ivs = [x1, x2, x3]+>>> gaps = [beginerval 2 5, beginerval 3 10]+>>> :{+pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gaps, "gaps")]+:}+ ----           <- [x1]+       ---      <- [x2]+             -- <- [x3]+     --   ---   <- [gaps]+===============++>>> :{+pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) []+:}+ ----           <- [x1]+       ---      <- [x2]+             -- <- [x3]+===============++>>> pretty $ standardExampleDiagram [] [(gaps, "gaps")]+     --   --- <- [gaps]+=============++>>> pretty $ standardExampleDiagram [] []+IntervalsExtendBeyondAxis+-}+standardExampleDiagram+  :: (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)+standardExampleDiagram ivs livs = op ref+ where+  op Nothing     = Left IntervalsExtendBeyondAxis+  op (Just ref') = parseIntervalDiagram defaultIntervalDiagramOptions+                                        []+                                        (Just Bottom)+                                        ref'+                                        combIvs+  range         = rangeInterval $ map fst ivs ++ concatMap fst livs+  anchoredRange = case range of+    Nothing  -> Nothing+    (Just x) -> Just $ safeInterval (min (begin x) 0, max (end x) 0)+  ref = fmap (makeIntervalText '=') anchoredRange+  f (iv, s) = ([iv], s)+  g (ivs, s) = (map (makeIntervalText '-') ivs, [pack s])+  combIvs = map (g . f) ivs ++ map g livs

@@ -1,612 +1,339 @@ {-| 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 -In the examples below, @iv@ is a synonym for 'beginerval' used to save space. -} -{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeFamilies        #-} -module IntervalAlgebra.IntervalUtilities (+module IntervalAlgebra.IntervalUtilities+  (      -- * Fold over sequential intervals-      combineIntervals-    , combineIntervalsL-    , gaps-    , gapsL-    , gapsWithin--    -- * Operations on Meeting sequences of paired intervals-    , foldMeetingSafe-    , formMeetingSequence+    combineIntervals+  , combineIntervalsFromSorted+  , rangeInterval -    -- * Withering functions+    -- * Combining intervals+  , (><)+  , (.+.) -    -- ** Clear containers based on predicate-    , nothingIf-    , nothingIfNone-    , nothingIfAny-    , nothingIfAll+    -- * Functions for manipulating intervals+  , lookback+  , lookahead -    -- ** Filter containers based on predicate-    , filterBefore-    , filterMeets-    , filterOverlaps-    , filterFinishedBy-    , filterContains-    , filterStarts-    , filterEquals-    , filterStartedBy-    , filterDuring-    , filterFinishes-    , filterOverlappedBy-    , filterMetBy-    , filterAfter-    , filterDisjoint-    , filterNotDisjoint-    , filterConcur-    , filterWithin-    , filterEnclose-    , filterEnclosedBy+    -- * Gaps+  , gaps+  , pairGaps      -- * Misc utilities-    , relations-    , relationsL-    , intersect-    , clip-    , durations-) where--import safe GHC.Show              ( Show )-import safe GHC.Int               ( Int )-import safe Control.Applicative   ( Applicative(pure)-                                  , (<*>) )-import qualified Control.Foldl as L-import safe Control.Monad         ( Functor(fmap) )-import safe Data.Bool             ( Bool, otherwise, not, (||), (&&) )-import safe Data.Eq               ( Eq((==)) )-import safe Data.Foldable         ( Foldable(null, foldl', toList)-                                  , all-                                  , any-                                  , or )-import safe Data.Function         ( ($), (.), flip )-import safe Data.Monoid           ( Monoid(mempty) )-import safe Data.Maybe            ( Maybe(..)-                                  , maybe-                                  , maybeToList )-import safe Data.Ord              ( Ord(min, max) )-import safe Data.Semigroup        ( Semigroup((<>)) )-import safe Data.Traversable      ( Traversable(sequenceA) )-import safe Data.Tuple            ( fst )-import safe Safe                  ( headMay, lastMay, initSafe, tailSafe)-import safe Witherable            ( Filterable(filter)-                                  , Witherable(..)-                                  , mapMaybe-                                  , catMaybes )-import safe IntervalAlgebra       ( (<|>),-                                  begin,-                                  end,-                                  after,-                                  before,-                                  beginerval,-                                  beginervalFromEnd,-                                  endervalFromBegin,-                                  concur,-                                  contains,-                                  disjoint,-                                  during,-                                  enclose,-                                  enclosedBy,-                                  enderval,-                                  equals,-                                  extenterval,-                                  finishedBy,-                                  finishes,-                                  meets,-                                  metBy,-                                  notDisjoint,-                                  overlappedBy,-                                  overlaps,-                                  relate,-                                  startedBy,-                                  starts,-                                  within,-                                  ComparativePredicateOf1,-                                  ComparativePredicateOf2,-                                  Interval,-                                  IntervalCombinable((<+>), (><)),-                                  IntervalRelation(..),-                                  IntervalSizeable(diff, duration),-                                  Intervallic(..) )-import safe IntervalAlgebra.PairedInterval-                                  ( PairedInterval-                                  , makePairedInterval-                                  , getPairData-                                  , equalPairData )+  , relations+  , intersect+  , clip+  , durations+  ) where +import           Control.Applicative            (Applicative (pure), liftA2,+                                                 (<$>), (<*>))+import qualified Control.Foldl                  as L+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 )+>>> import IntervalAlgebra.IntervalDiagram+>>> import Prettyprinter ( pretty )+-}  ------------------------------------------------- -- Unexported utilties used in functions below -- ------------------------------------------------- --- Just a synonym used to examples to save typing-iv :: Int -> Int -> Interval Int-iv = beginerval --- 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+-- | Gets the durations of gaps (via '(><)') between all pairs of the input.+pairGaps+  :: (Intervallic i, SizedIv (Interval a), Ord a, Ord (Moment (Interval a)))+  => [i a]+  -> [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)]+-- copied from the hgeometry library+-- (https://hackage.haskell.org/package/hgeometry-0.12.0.4/docs/src/Data.Geometry.Arrangement.Internal.html#allPairs)+ where+  pairs = go+   where+    go []       = []+    go (x : xs) = fmap (x, ) xs <> go xs --- 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 #-}+-- | Creates a new @Interval@ of a provided lookback duration ending at the+--   'begin' of the input interval.+--+-- >>> lookback 4 (beginerval 10 (1 :: Int))+-- (-3, 1)+lookback+  :: (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) --- | Returns a list of the 'IntervalRelation' between each consecutive pair ---   of intervals. This is just a specialized 'relations' which returns a list.+-- | Creates a new @Interval@ of a provided lookahead duration beginning at the+--   'end' of the input interval. ----- >>> relationsL [iv 1 0, iv 1 1] --- [Meets]-relationsL :: (Foldable f, Intervallic i a )=>-       f (i a)-    -> [IntervalRelation]-relationsL = relations+-- >>> lookahead 4 (beginerval 1 (1 :: Int))+-- (2, 6)+lookahead+  :: (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) --- | A generic form of 'relations' which can output any 'Applicative' and ---   'Monoid' structure. --- >>> (relations [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)]--- [Meets]+-- | Returns a list of the 'IntervalRelation' between each consecutive pair of @i a@. ---relations :: ( Foldable f-              , Applicative m-              , Intervallic i a-              , Monoid (m IntervalRelation ))=>-        f (i a)-     -> m IntervalRelation-relations = L.fold (makeFolder relate)-{-# INLINABLE relations #-}+-- >>> 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+  :: ( Intervallic i+     , Iv (Interval a)+     )+  => [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.--- --- >>> intersect (iv 5 0) (iv 2 3)+-- | 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 a, IntervalSizeable a b) =>-    i a -> i a -> Maybe (Interval a)-intersect x y-    | disjoint x y = Nothing-    | otherwise    = Just $ beginerval (diff e b) b-        where b = max (begin x) (begin y)-              e = min (end x) (end y)+--+intersect+  :: (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 $ 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 list of intervals consisting of the gaps between+consecutive intervals in the input, after they have been sorted by+interval ordering. --- | 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.------ >>> gaps [iv 4 1, iv 4 8, iv 3 11]----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 #-}+>>> x1 = bi 4 1+>>> x2 = bi 4 8+>>> x3 = bi 3 11+>>> ivs = [x1, x2, x3]+>>> ivs+[(1, 5),(8, 12),(11, 14)]+>>> gaps ivs+[(5, 8)]+>>> pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) []+ ----          <- [x1]+        ----   <- [x2]+           --- <- [x3]+============== --- | 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@.-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 #-}+>>> x1 = bi 4 1+>>> x2 = bi 3 7+>>> x3 = bi 2 13+>>> ivs = [x1, x2, x3]+>>> ivs+[(1, 5),(7, 10),(13, 15)]+>>> gapIvs = gaps ivs+>>> gapIvs+[(5, 7),(10, 13)]+>>> :{+  pretty $+    standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gapIvs, "gapIvs")]+:}+ ----           <- [x1]+       ---      <- [x2]+             -- <- [x3]+     --   ---   <- [gapIvs]+===============+-}+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 [iv 9 1, iv 10 2, iv 1 5]+-- >>> durations [bi 9 1, bi 10 2, bi 1 5 :: Interval Int] -- [9,10,1]-durations :: (Functor f, Intervallic i a, 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.--- --- >>> clip (iv 5 0) (iv 3 3)+--+-- >>> clip (bi 5 0) ((bi 3 3) :: Interval Int) -- Just (3, 5) ----- >>> clip (iv 3 0) (iv 2 4)+-- >>> clip (bi 3 0) ((bi 2 4) :: Interval Int) -- Nothing-clip :: (Intervallic i0 a, Intervallic i1 a, IntervalSizeable a b)=>-       i0 a-    -> i1 a-    -> Maybe (Interval a)+--+clip+  :: (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)-   | jx x y           = Just (getInterval x)-   | jy x y           = Just (getInterval y)-   | otherwise        = Nothing {- disjoint x y case -}-   where jy = equals <|> startedBy <|> contains <|> finishedBy-         jx = starts <|> during <|> finishes+  | 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 -}+ where+  jy = equals <|> startedBy <|> contains <|> finishedBy+  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 (iv 9 1) [iv 5 0, iv 2 7, iv 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 a-               , 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 #-}---- The Box is an internal type used to hold accumulated, combined intervals in --- 'combineIntervalsL'.-newtype Box a = Box { unBox :: [a] }--packIntervalBoxes :: (Intervallic i a)=> [i a] -> [Box (Interval a)]-packIntervalBoxes  = fmap (\z -> Box [getInterval z])--instance (Ord a) => Semigroup (Box (Interval a)) where-    Box x <> Box y = Box $ listCombiner (<->) x y---- | Returns a container of intervals where any intervals that meet or share support---   are combined into one interval. *To work properly, the input should ---   be sorted*. See 'combineIntervalsL' for a version that works only on lists.------ >>> combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]--- [(0, 12),(13, 15)]-combineIntervals :: ( Applicative f-                    , Ord a-                    , Intervallic i a-                    , Monoid (f (Interval a))-                    , Foldable f ) =>-      f (i a) ->-      f (Interval a)-combineIntervals x = -  foldl' (\x y -> x <> pure y) mempty (combineIntervalsL $ toList x)-  -- TODO: surely combineIntervals and combineIntervalsL could be combined-{-# INLINABLE combineIntervals #-}---- | Returns a list of intervals where any intervals that meet or share support---   are combined into one interval. *To work properly, the input list should ---   be sorted*. ------ >>> combineIntervalsL [iv 10 0, iv 5 2, iv 2 10, iv 2 13]--- [(0, 12),(13, 15)]-combineIntervalsL :: (Intervallic i a)=> [i a] -> [Interval a]-combineIntervalsL l = unBox $ foldl' (<>) (Box []) (packIntervalBoxes l)-{-# INLINABLE combineIntervalsL #-}---- Internal function for combining maybe intervals in the 'combineIntervalsL' --- function-(<->) :: (IntervalCombinable i a) =>-       Maybe (i a)-    -> Maybe (i a)-    -> [Interval a]-(<->) Nothing Nothing   = []-(<->) Nothing (Just y)  = [getInterval y]-(<->) (Just x) Nothing  = [getInterval x]-(<->) (Just x) (Just y) = (<+>) (getInterval x) (getInterval y)-{-# INLINABLE (<->) #-}---- | 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 (iv 2 3)) [iv 1 3, iv 1 5]--- Nothing------ In the following, (3, 5) 'starts' (3, 6), so 'Just' the input is returned.------ >>> nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5]--- Just [(3, 6),(5, 6)]----nothingIfNone :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (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 (starts (iv 2 3)) [iv 3 3, iv 1 5]--- Just [(3, 6),(5, 6)]------ >>> nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5]--- Nothing-nothingIfAny :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (i a -> Bool) -- ^ predicate to apply to each element of input list-  -> f (i a)-  -> Maybe (f (i a))-nothingIfAny = nothingIf any---- | Returns 'Nothing' if *all* of the element of input satisfy the predicate condition.--- >>> nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3]--- Nothing-nothingIfAll :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (i a -> Bool) -- ^ predicate to apply to each element of input list-  -> f (i a)-  -> Maybe (f (i a))-nothingIfAll = nothingIf all---- | 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 a-               , Intervallic i1 a) =>-        ComparativePredicateOf2 (i0 a) (i1 a)-      -> i0 a-      -> (f (i1 a) -> f (i1 a))-makeFilter f p = Witherable.filter (f p)+{- | 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@. -{- | -Filter 'Witherable.Filterable' containers of one @'Intervallic'@ type based by comparing to -a (potentially different) 'Intervallic' type using the corresponding interval-predicate function.+>>> 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]+=============== -}-filterOverlaps, filterOverlappedBy, filterBefore, filterAfter,-  filterStarts, filterStartedBy, filterFinishes, filterFinishedBy,-  filterMeets, filterMetBy, filterDuring, filterContains, filterEquals,-  filterDisjoint, filterNotDisjoint, filterConcur, filterWithin,-  filterEnclose, filterEnclosedBy ::-    ( Filterable f , Intervallic i0 a, Intervallic i1 a) =>-    i0 a -> f (i1 a) -> f (i1 a)-filterOverlaps          = makeFilter overlaps-filterOverlappedBy      = makeFilter overlappedBy-filterBefore            = makeFilter before-filterAfter             = makeFilter after-filterStarts            = makeFilter starts-filterStartedBy         = makeFilter startedBy-filterFinishes          = makeFilter finishes-filterFinishedBy        = makeFilter finishedBy-filterMeets             = makeFilter meets-filterMetBy             = makeFilter metBy-filterDuring            = makeFilter during-filterContains          = makeFilter contains-filterEquals            = makeFilter equals-filterDisjoint          = makeFilter disjoint-filterNotDisjoint       = makeFilter notDisjoint-filterConcur            = makeFilter concur-filterWithin            = makeFilter within-filterEnclose           = makeFilter enclose-filterEnclosedBy        = makeFilter enclosedBy---- | Folds over a list of Paired Intervals and in the case that the 'getPairData' ---   is equal between two sequential meeting intervals, these two intervals are ---   combined into one. This function is "safe" in the sense that if the input is---   invalid and contains any sequential pairs of intervals with an @IntervalRelation@,---   other than 'Meets', then the function returns an empty list. -foldMeetingSafe :: (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 :: Intervallic i a => [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+combineIntervals :: (SizedIv (Interval a), Intervallic i, Ord a) => [i a] -> [Interval a]+combineIntervals = combineIntervalsFromSorted . sortOn getInterval --- A general function for combining any two @Meeting [i a]@ by 'listCombiner'.-joinMeeting :: Intervallic i a =>-       ComparativePredicateOf1 (i a)-    -> Meeting [ i a ]-    -> Meeting [ i a ]-    -> Meeting [ i a ]-joinMeeting f (Meeting x) (Meeting y) = Meeting $ listCombiner (join2MeetingWhen f) x y+{- | 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__. --- The intervals @x@ and @y@ should meet! The predicate function @p@ determines--- when the two intervals that meet should be combined.-join2MeetingWhen :: Intervallic i a =>-       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+>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 2 10, bi 2 13]+[(0, 12),(13, 15)] -{- | -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. +>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 0 8]+[(0, 10)] -}-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 s -> ev (beginerval (diff e b) b) s-{-# INLINABLE disjoinPaired #-}+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+    -- Since x <= y, not (x `before` y) iff they meet or share support+    then yiv : x : xs+    else extenterval x yiv : xs+    where yiv = getInterval y -{- | -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+{- | @Maybe@ form an @Interval a@ from @Control.Foldl t => t (Interval a)@+spanning the range of all intervals in the list, i.e. whose @begin@ is the+minimum of @begin@ across intervals in the list and whose @end@ is the maximum+of @end@. -     {- 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+>>> rangeInterval ([] :: [Interval Int])+Nothing -    --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 #-}+>>> x1 = bi 2 2+>>> x2 = bi 3 6+>>> x3 = bi 4 7+>>> ivs = [x1, x2, x3] :: [Interval Int]+>>> ivs+[(2, 4),(6, 9),(7, 11)]+>>> spanIv = rangeInterval ivs+>>> spanIv+Just (2, 11)+>>> :{+case spanIv of+  Nothing -> pretty ""+  (Just x) -> pretty $ standardExampleDiagram+    (zip (ivs ++ [x]) ["x1", "x2", "x3", "spanIv"])+    []+:}+  --        <- [x1]+      ---   <- [x2]+       ---- <- [x3]+  --------- <- [spanIv]+=========== -{- | -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.+>>> rangeInterval (Nothing :: Maybe (Interval Int))+Nothing+>>> rangeInterval (Just (bi 1 0))+Just (0, 1) -}-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))+rangeInterval :: (L.Foldable t, Ord a, SizedIv (Interval a)) => t (Interval a) -> Maybe (Interval a)+rangeInterval = L.fold (liftA2 extenterval <$> L.minimum <*> L.maximum) -   -- 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,70 +1,60 @@ {-|-Module      : Paired interval +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 Safe #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} -module IntervalAlgebra.PairedInterval (-      PairedInterval-    , Empty(..)-    , makePairedInterval-    , getPairData-    , intervals-    , equalPairData-    , toTrivialPair-    , trivialize-) where+module IntervalAlgebra.PairedInterval+  ( PairedInterval+  , Empty(..)+  , makePairedInterval+  , getPairData+  , intervals+  , equalPairData+  , toTrivialPair+  , trivialize+  ) where -import IntervalAlgebra  ( Interval-                        , Intervallic(..)-                        , before-                        , IntervalCombinable(..)-                        , ComparativePredicateOf1-                        , extenterval )-import Witherable       ( Filterable(filter) )-import Data.Bifunctor   ( Bifunctor(bimap) )+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)--instance (Ord a) => Intervallic (PairedInterval b) a where-    getInterval (PairedInterval x)        = fst x-    setInterval (PairedInterval (x, y)) i = PairedInterval (i, y)+newtype PairedInterval b a+  = PairedInterval (Interval a, b)+  deriving (Eq, Generic) -instance Functor (PairedInterval b) where-    fmap f (PairedInterval (x, y)) = PairedInterval (fmap f x, y)+instance Intervallic (PairedInterval b) where+  getInterval (PairedInterval x) = fst x+  setInterval (PairedInterval (x, y)) i = PairedInterval (i, y) -instance Bifunctor PairedInterval where-    bimap f g (PairedInterval (x, y)) = PairedInterval (fmap g x, f y)+instance (NFData a, NFData b) => NFData (PairedInterval b a)+instance (Binary a, Binary b) => Binary (PairedInterval b a)  -- | Defines A total ordering on 'PairedInterval b a' based on the 'Interval a' --   part. instance (Eq a, Eq b, Ord a) => Ord (PairedInterval b a) where   (<=) x y = getInterval x <= getInterval y-  (<) x y  = getInterval x <  getInterval y+  (<) x y = getInterval x < getInterval y  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) +  show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}" --- | Make a paired interval. +-- | Make a paired interval. makePairedInterval :: b -> Interval a -> PairedInterval b a makePairedInterval d i = PairedInterval (i, d) @@ -82,11 +72,10 @@  -- | Empty is used to trivially lift an @Interval a@ into a @PairedInterval@. data Empty = Empty deriving (Eq, Ord, Show)-instance Semigroup Empty where -    x <> y = Empty+instance Semigroup Empty where+  x <> y = Empty instance Monoid Empty where-    mempty = Empty-    mappend x y = x <> y+  mempty = Empty  -- | Lifts an @Interval a@ into a @PairedInterval Empty a@, where @Empty@ is a --   trivial type that contains no data.@@ -97,3 +86,9 @@ --   @PairedInterval Empty a@(s). trivialize :: Functor f => f (Interval a) -> f (PairedInterval Empty a) trivialize = fmap toTrivialPair+++-- TODO REFACTOR need to revisit this+-- Arbitrary instance+--instance (Arbitrary b, Arbitrary (Interval a)) => Arbitrary (PairedInterval b a) where+--  arbitrary = liftA2 makePairedInterval arbitrary arbitrary

@@ -0,0 +1,145 @@+{-|+Module      : Interval Algebra Axioms+Description : Properties of Intervals+Copyright   : (c) NoviSci, Inc 2020-2022+                  TargetRWE, 2023+License     : BSD3+Maintainer  : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023++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.++-}+{- HLINT ignore -}+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}++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           IntervalAlgebra.Arbitrary+import           IntervalAlgebra.Core+import           IntervalAlgebra.IntervalUtilities ((.+.))+import           Test.QuickCheck                   (Arbitrary (arbitrary),+                                                    Property, (===), (==>))++allIArelations :: (SizedIv (Interval a), Ord a) => [ComparativePredicateOf1 (Interval a)]+allIArelations =+  [ equals+  , meets+  , metBy+  , before+  , after+  , starts+  , startedBy+  , finishes+  , finishedBy+  , overlaps+  , overlappedBy+  , during+  , 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).++-- | 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++-- | 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_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_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_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_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_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_disjoint_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint++prop_notdisjoint_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_notdisjoint_predicate =+  prop_predicate_unions (complement disjointRelations) notDisjoint++prop_concur_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_concur_predicate =+  prop_predicate_unions (complement disjointRelations) concur++prop_within_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_within_predicate = prop_predicate_unions withinRelations within++prop_enclosedBy_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy++prop_encloses_predicate :: (SizedIv (Interval a), Ord a) =>+      Interval a+    -> Interval a+    -> Property+prop_encloses_predicate = prop_predicate_unions (converse withinRelations) encloses

@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications      #-}+module AxiomsSpec+  ( spec+  ) where++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+testScale = 1000++spec :: Spec+spec = do++  describe "An Axiomatization of Interval Time"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "M1" $ property (prop_IAaxiomM1 @Int)+        it "M1" $ property (prop_IAaxiomM1 @Day)+        it "M1" $ property (prop_IAaxiomM1 @UTCTime)++        it "M2" $ property (prop_IAaxiomM2 @Int)+        it "M2" $ property (prop_IAaxiomM2 @Day)+        it "M2" $ property (prop_IAaxiomM2 @UTCTime)++        it "ML1" $ property (prop_IAaxiomML1 @Int)+        it "ML1" $ property (prop_IAaxiomML1 @Day)+        it "ML1" $ property (prop_IAaxiomML1 @UTCTime)++        it "ML2" $ property (prop_IAaxiomML2 @Int)+        it "ML2" $ property (prop_IAaxiomML2 @Day)+        it "ML2" $ property (prop_IAaxiomML2 @UTCTime)++        it "M3" $ property (prop_IAaxiomM3 @Int)+        it "M3" $ property (prop_IAaxiomM3 @Day)+        it "M3" $ forAll genNominalDiffTime (prop_IAaxiomM3 @UTCTime)++        it "M4" $ property (prop_IAaxiomM4 @Int)+        it "M4" $ property (prop_IAaxiomM4 @Day)+        it "M4" $ forAll genNominalDiffTime (prop_IAaxiomM4 @UTCTime)++        it "M5" $ property (prop_IAaxiomM5 @Int)+        it "M5" $ property (prop_IAaxiomM5 @Day)+        it "M5" $ property (prop_IAaxiomM5 @UTCTime)++        it "M4.1" $ property (prop_IAaxiomM4_1 @Int)+        it "M4.1" $ property (prop_IAaxiomM4_1 @Day)+        it "M4.1" $ forAll genNominalDiffTime (prop_IAaxiomM4_1 @UTCTime)+

@@ -0,0 +1,7 @@+module Main where++import           AxiomsSpec+import           Test.Hspec++main :: IO ()+main = hspec spec

@@ -0,0 +1,7 @@+module Main where++import           RelationPropertiesSpec+import           Test.Hspec++main :: IO ()+main = hspec spec

@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications      #-}+module RelationPropertiesSpec+  ( spec+  ) where++import           Data.Time+import           IntervalAlgebra.RelationProperties+import           Test.Hspec                         (Spec, describe, hspec, it)+import           Test.Hspec.QuickCheck              (modifyMaxSuccess)+import           Test.QuickCheck++testScale = 100++spec :: Spec+spec = do+  describe "Interval Algebra relation properties for Interval Int"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @Int)+        it "starts" $ property (prop_IAstarts @Int)+        it "finishes" $ property (prop_IAfinishes @Int)+        it "overlaps" $ property (prop_IAoverlaps @Int)+        it "during" $ property (prop_IAduring @Int)+        it "disjoint" $ property (prop_disjoint_predicate @Int)+        it "within" $ property (prop_within_predicate @Int)+        it "encloses" $ property (prop_encloses_predicate @Int)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @Int)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @Int)+        it "concur" $ property (prop_concur_predicate @Int)++  describe "Interval Algebra relation properties for Interval Day"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @Day)+        it "starts" $ property (prop_IAstarts @Day)+        it "finishes" $ property (prop_IAfinishes @Day)+        it "overlaps" $ property (prop_IAoverlaps @Day)+        it "during" $ property (prop_IAduring @Day)+        it "disjoint" $ property (prop_disjoint_predicate @Day)+        it "within" $ property (prop_within_predicate @Day)+        it "encloses" $ property (prop_encloses_predicate @Day)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @Day)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @Day)+        it "concur" $ property (prop_concur_predicate @Day)++  describe "Interval Algebra relation properties for Interval UTCTime"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @UTCTime)+        it "starts" $ property (prop_IAstarts @UTCTime)+        it "finishes" $ property (prop_IAfinishes @UTCTime)+        it "overlaps" $ property (prop_IAoverlaps @UTCTime)+        it "during" $ property (prop_IAduring @UTCTime)+        it "disjoint" $ property (prop_disjoint_predicate @UTCTime)+        it "within" $ property (prop_within_predicate @UTCTime)+        it "encloses" $ property (prop_encloses_predicate @UTCTime)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @UTCTime)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @UTCTime)+        it "concur" $ property (prop_concur_predicate @UTCTime)++  describe "Interval Algebra relation uniqueness"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @Int)+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @Day)+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @UTCTime)

@@ -1,124 +1,135 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-}-module IntervalAlgebra.IntervalUtilitiesSpec (spec) where+{-# LANGUAGE TypeApplications  #-}+{- HLINT ignore -}+module IntervalAlgebra.IntervalUtilitiesSpec+  ( spec+  ) where -import Test.Hspec.QuickCheck              ( modifyMaxSuccess-                                          , modifyMaxDiscardRatio )-import Test.Hspec                         ( Spec-                                          , it-                                          , shouldBe-                                          , describe-                                          , pending-                                          , xcontext )-import Test.QuickCheck                    ( Property-                                          , Testable(property)-                                          , Arbitrary(arbitrary, shrink)-                                          , suchThat-                                          , (===), (==>)-                                          , Arbitrary1 (liftArbitrary)-                                          , listOf-                                          , orderedList)-import Data.List                          (sort)-import IntervalAlgebra.Arbitrary          ( )-import IntervalAlgebra                    ( Interval-                                          , Intervallic(..)-                                          , IntervalCombinable(..)-                                          , IntervalRelation (..)-                                          , IntervalSizeable-                                          , beginerval-                                          , complement-                                          , converse-                                          , starts-                                          , disjointRelations-                                          , withinRelations-                                          , predicate  )-import IntervalAlgebra.IntervalUtilities  ( gapsL-                                          , gaps-                                          , durations-                                          , intersect-                                          , relationsL-                                          , clip-                                          , gapsWithin-                                          , nothingIfNone-                                          , filterBefore-                                          , filterMeets-                                          , filterOverlaps-                                          , filterFinishedBy-                                          , filterContains-                                          , filterStarts-                                          , filterEquals-                                          , filterStartedBy-                                          , filterDuring-                                          , filterFinishes-                                          , filterOverlappedBy-                                          , filterMetBy-                                          , filterAfter-                                          , filterDisjoint-                                          , filterNotDisjoint-                                          , filterConcur-                                          , filterWithin-                                          , filterEnclose-                                          , filterEnclosedBy-                                          , nothingIfAll-                                          , nothingIfAny-                                          , combineIntervals-                                          , foldMeetingSafe-                                          , formMeetingSequence )-import IntervalAlgebra.PairedInterval     ( trivialize-                                          , makePairedInterval-                                          , PairedInterval, getPairData )-import Control.Monad                      ( liftM2 )-import Data.Set                           ( Set, fromList, member )-import Witherable                         ( Filterable )+import           Control.Monad                     (liftM2)+import           Data.List                         (sort)+import           Data.Maybe                        (fromJust, isJust, isNothing)+import           Data.Set                          (Set, difference, fromList,+                                                    member, toList)+import qualified Data.Set                          (null)+import           Data.Time                         (Day, UTCTime)+import           IntervalAlgebra                   (Interval,+                                                    IntervalRelation (..),+                                                    Intervallic (..),+                                                    SizedIv (..), beginerval,+                                                    complement, converse,+                                                    disjointRelations, duration,+                                                    intervalRelations, moment,+                                                    predicate, rangeInterval,+                                                    safeInterval, starts,+                                                    strictWithinRelations,+                                                    withinRelations, (.+.),+                                                    (><))+import           IntervalAlgebra.Arbitrary         (arbitraryWithRelation)+import           IntervalAlgebra.IntervalUtilities (clip, combineIntervals,+                                                    combineIntervalsFromSorted,+                                                    durations, gaps, intersect,+                                                    relations)+import           IntervalAlgebra.PairedInterval    (PairedInterval, getPairData,+                                                    makePairedInterval,+                                                    trivialize)+import           Test.Hspec                        (Spec, describe, it,+                                                    shouldBe)+import           Test.Hspec.QuickCheck             (modifyMaxDiscardRatio,+                                                    modifyMaxSuccess)+import           Test.QuickCheck                   (Arbitrary (arbitrary, shrink),+                                                    Arbitrary1 (liftArbitrary),+                                                    Property,+                                                    Testable (property),+                                                    elements, listOf,+                                                    orderedList, resize,+                                                    sublistOf, suchThat, (===),+                                                    (==>))  -- Types for testing --- A "state" here is just used test formMeetingSequence -newtype Events a = Events {getEvents :: [PairedInterval State a]}-   deriving (Eq, Show, Ord)-newtype State = State [Bool] deriving (Show, Eq)+-- SmallInterval is just to test properties for which events of interest are so+-- rare QuickCheck gives up, e.g. filterEquals+newtype SmallInterval+  = SmallInterval { unSmall :: Interval Int }+  deriving (Eq, Show)++instance Arbitrary SmallInterval where+  arbitrary = SmallInterval . beginerval 0 <$> elements [0 .. 10]++-- A "state" here is just used test formMeetingSequence+newtype Events a+  = Events { getEvents :: [StateEvent a] }+  deriving (Eq, Ord, Show)++newtype State+  = State [Bool]+  deriving (Eq, Show)+ instance Semigroup State where-     State x <> State y = State $ zipWith (||) x y+  State x <> State y = State $ zipWith (||) x y+ instance Monoid State where-    mempty = State [False, False, False]-type StateEvent a = PairedInterval State a+  mempty = State [False, False, False] +newtype StateEvent a = MkEvent { getEvent :: PairedInterval State a }+   deriving (Eq, Ord, Show) -readInterval :: IntervalSizeable a a => (a, a) -> Interval a-readInterval (b, e) = beginerval (e - b) b+unEvents :: [StateEvent a] -> [PairedInterval State a]+unEvents = fmap getEvent -mkEv :: IntervalSizeable a a => (a, a) -> b -> PairedInterval b a-mkEv i s = makePairedInterval s (readInterval i)+-- Type for checking arbitraryWithRelation+-- A target and reference pair, where targetInterval satisfies at least one of+-- refRelations relative to refInterval+data IntervalReferenced = IntervalReferenced+  { refInterval    :: Interval Int+  , refRelations   :: Set IntervalRelation+  , targetInterval :: Maybe (Interval Int)+  }+  deriving (Eq, Show)  +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-   arbitrary =  State <$> suchThat (listOf arbitrary) (\x -> length x == 3)+  arbitrary = State <$> suchThat (listOf arbitrary) (\x -> length x == 3) -instance Arbitrary (PairedInterval State Int) where-   arbitrary = liftM2 makePairedInterval arbitrary arbitrary+-- SmallInterval again to address issue of generating from too large a possible+-- range of intervals+instance Arbitrary (StateEvent Int) where+  arbitrary = liftM2 (\x y -> MkEvent $ makePairedInterval x y)+                     arbitrary+                     (unSmall <$> arbitrary)  instance Arbitrary (Events Int) where-   arbitrary = Events <$> orderedList+  arbitrary = Events <$> orderedList +-- restricted refIv to decrease rareness causing quickcheck to quit+instance Arbitrary IntervalReferenced where+  arbitrary = do+    refIv <- liftM2 beginerval (elements [1 .. 3]) (elements [0 .. 3])+    rels  <- fromList <$> sublistOf (toList intervalRelations)+    iv    <- arbitraryWithRelation refIv rels+    pure $ IntervalReferenced refIv rels iv  -- Testing functions-checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool-checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x)+checkSeqStates :: (Intervallic i) => [i Int] -> Bool+checkSeqStates x = (length x > 1) || all (== Meets) (relations x)  -- Creation functions iv :: Int -> Int -> Interval Int iv = beginerval  evpi :: Int -> Int -> [Bool] -> StateEvent Int-evpi i j s = makePairedInterval (State s) (beginerval i j)+evpi i j s = MkEvent $ makePairedInterval (State s) (beginerval i j)  -- Test cases containmentInt :: Interval Int containmentInt = iv (10 :: Int) (0 :: Int)  noncontainmentInt :: Interval Int-noncontainmentInt = iv  6 4+noncontainmentInt = iv 6 4  anotherInt :: Interval Int anotherInt = iv 5 (15 :: Int)@@ -133,447 +144,266 @@ meets2 = [iv 2 0, iv 2 2, iv 10 4, iv 2 14]  meets3 :: [PairedInterval Int Int]-meets3 = map (uncurry makePairedInterval) [-      (5,  iv 2 0)-    , (5,  iv 2 2)-    , (9,  iv 10 4)-    , (10, iv 2 14)]+meets3 = map (uncurry makePairedInterval)+             [(5, iv 2 0), (5, iv 2 2), (9, iv 10 4), (10, iv 2 14)]  meets3eq :: [PairedInterval Int Int]-meets3eq = map (uncurry makePairedInterval) [-      (5,  iv 4 0)-    , (9,  iv 10 4)-    , (10, iv 2 14)]+meets3eq =+  map (uncurry makePairedInterval) [(5, iv 4 0), (9, iv 10 4), (10, iv 2 14)]  c0in :: [StateEvent Int] c0in =-  [ evpi 9 1  [True, False, False]-  , evpi 8 2  [True, False, False]-  , evpi 3 5  [False, True, False]-  , evpi 3 6  [False, True, False]]+  [ evpi 9 1 [True, False, False]+  , evpi 8 2 [True, False, False]+  , evpi 3 5 [False, True, False]+  , evpi 3 6 [False, True, False]+  ] c0out :: [StateEvent Int] c0out =-  [ evpi 4 1  [True, False, False]-  , evpi 4 5  [True, True, False]-  , evpi 1 9  [True, False, False]]+  [ evpi 4 1 [True, False, False]+  , evpi 4 5 [True, True, False]+  , evpi 1 9 [True, False, False]+  ]  c1in :: [StateEvent Int]-c1in =-  [ evpi 4 1  [True, False, False ]-  , evpi 4 6  [False, True, False ]]+c1in = [evpi 4 1 [True, False, False], evpi 4 6 [False, True, False]] c1out :: [StateEvent Int] c1out =-  [ evpi 4 1  [True, False, False]-  , evpi 1 5  [False, False, False]-  , evpi 4 6  [False, True, False]]+  [ evpi 4 1 [True, False, False]+  , evpi 1 5 [False, False, False]+  , evpi 4 6 [False, True, False]+  ]  c2in :: [StateEvent Int]-c2in =-  [ evpi 4 1  [True, False, False ]-  , evpi 5 5  [False, True, False ]]+c2in = [evpi 4 1 [True, False, False], evpi 5 5 [False, True, False]] c2out :: [StateEvent Int]-c2out =-  [ evpi 4 1  [True, False, False]-  , evpi 5 5  [False, True, False]]+c2out = [evpi 4 1 [True, False, False], evpi 5 5 [False, True, False]]  c3in :: [StateEvent Int]-c3in =-  [ evpi 4 1  [True, False, False ]-  , evpi 6 4  [False, True, False ]]+c3in = [evpi 4 1 [True, False, False], evpi 6 4 [False, True, False]] c3out :: [StateEvent Int] c3out =-  [ evpi 3 1  [True, False, False]-  , evpi 1 4  [True, True, False]-  , evpi 5 5  [False, True, False]]+  [ evpi 3 1 [True, False, False]+  , evpi 1 4 [True, True, False]+  , evpi 5 5 [False, True, False]+  ]  c4in :: [StateEvent Int] c4in =-  [ evpi 1 (-1)  [True, True, False ]-  , evpi 1 3     [True, False, True ]-  , evpi 1 3     [False, False, False]]+  [ evpi 1 (-1) [True, True, False]+  , evpi 1 3    [True, False, True]+  , evpi 1 3    [False, False, False]+  ] c4out :: [StateEvent Int] c4out =-  [ evpi 1 (-1)  [True, True, False ]-  , evpi 3 0     [False, False, False]-  , evpi 1 3     [True, False, True ]]+  [ evpi 1 (-1) [True, True, False]+  , evpi 3 0    [False, False, False]+  , evpi 1 3    [True, False, True]+  ]   -c5in :: [StateEvent Int]-c5in = [-     mkEv (-63, 21) (State [False,True,True])-   , mkEv (-56, 20) (State [True,True,True])-   , mkEv (1, 41) (State [False,True,False])-   , mkEv (11, 34) (State [True,False,True])-   , mkEv (27, 28) (State [False,True,True])-   ]+c5in :: [PairedInterval State Int]+c5in =+  [ mkEv (-63, 21) (State [False, True, True])+  , mkEv (-56, 20) (State [True, True, True])+  , mkEv (1  , 41) (State [False, True, False])+  , mkEv (11 , 34) (State [True, False, True])+  , mkEv (27 , 28) (State [False, True, True])+  ] -c5out :: [StateEvent Int]-c5out = [-     mkEv (-63, -56) (State [False,True,True])-   , mkEv (-56, 34) (State [True,True,True])-   , mkEv (34, 41) (State [False,True,False])-   ]+c5out :: [PairedInterval State Int]+c5out =+  [ mkEv (-63, -56) (State [False, True, True])+  , mkEv (-56, 34)  (State [True, True, True])+  , mkEv (34 , 41)  (State [False, True, False])+  ]  -- Properties --- 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-      where ci = f (sort x)+-- arbitraryWithRelation props+-- 'tautology' because this repeats the logic of arbitraryWithRelation+prop_withRelation_tautology :: IntervalReferenced -> Bool+prop_withRelation_tautology ir+  | isEnclose && isMom = isNothing iv+  | otherwise          = isJust iv && predicate rels refIv (fromJust iv)+ where+  refIv = refInterval ir+  iv    = targetInterval ir+  rels  = refRelations ir+  isEnclose =+    Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations)+  isMom = duration refIv == moment @(Interval Int) -prop_combineIntervals1:: (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+-- Check that the only relation remaining after applying a function is Before+prop_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) --- 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 es) === True-   where es = getEvents x+prop_combineIntervals1 :: (SizedIv (Interval a), Ord a, Show a, Eq a) => [Interval a] -> Property+prop_combineIntervals1 = prop_before combineIntervals --- In the case that 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]) (getEvents x))-   ) ==> beforeCount >= emptyCount-   where res = formMeetingSequence (getEvents x)-         beforeCount = lengthWhen (== Before) (relationsL (getEvents x))-         emptyCount  = lengthWhen (\x -> getPairData x == mempty ) res-         lengthWhen f x = length $ filter f x+prop_gaps1 :: (SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => [Interval a] -> Property+prop_gaps1 = prop_before gaps --- Check that formMeetingSequence doesn't return an empty list unless input is --- empty.-prop_formMeetingSequence2::-     Events Int+prop_filtration :: (SizedIv (Interval a), Ord a) =>+   (Interval a ->  [Interval a] -> [Interval a])+   -> Set IntervalRelation+   -> Interval a+   -> [Interval a]    -> Property-prop_formMeetingSequence2 x = not (null $ getEvents x) ==> not $ null res-   where res = formMeetingSequence (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_filterEnclose :: Interval a-      -> [Interval a]-      -> Property -   prop_filterEnclose = prop_filtration filterEnclose (converse withinRelations)--   prop_filterConcur :: Interval a-      -> [Interval a]-      -> Property -   prop_filterConcur = prop_filtration filterConcur (complement disjointRelations)+prop_filtration fltr s x l =+   not (null res) ==> and (fmap (predicate s x) res) === True+  where res = fltr x l -instance FiltrationProperties Int+prop_clip_intersect+  :: (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) +-- RUNNER  spec :: Spec spec = do-   describe "gaps tests" $-    modifyMaxSuccess (*10) $-    do-      it "no gaps in containmentInt and noncontainmentInt" $-         gapsL [containmentInt, noncontainmentInt] `shouldBe` []-      it "no gaps in containmentInt" $-         gapsL [containmentInt] `shouldBe` []-      it "single gap between containmentInt and anotherInt" $-         gapsL [containmentInt, anotherInt] `shouldBe` [gapInt]-      it "after gaps, only relation should be Before" $-         property (prop_gaps1 @Int)--   describe "durations unit tests" $-      do-         it "durations of containmentInt is 10" $-            durations [containmentInt] `shouldBe` [10]-         it "durations of empty list is empty list" $-            durations  ([] :: [Interval Int])  `shouldBe` []-         it "durations of [containmentInt, anotherInt] is [10, 5]" $-            durations [containmentInt, anotherInt] `shouldBe` [10, 5]--   describe "clip tests" $-      do-         it "clip disjoint should be Nothing" $-           clip containmentInt gapInt `shouldBe` Nothing-         it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)" $-           clip noncontainmentInt containmentInt `shouldBe`-             Just (iv 6 4)-         it "clip x y === intersect sort x y " pending--   describe "relationsL tests" $-         do-            it "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $-               relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe`-                  [FinishedBy, Meets, Meets]-            it "relationsL of [] shouldBe []" $-               relationsL ([] :: [Interval Int]) `shouldBe` []-            it "relationsL of singleton shouldBe []" $-               relationsL [containmentInt] `shouldBe` []-            it "more relationsL tests" pending--   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 (readInterval (0 :: Int, 455)) -               (fmap readInterval [(0, 730), (731, 762), (763, 793)])-               `shouldBe` Just []-         it "gapsWithin (1, 10) [] should be []" $-             gapsWithin (iv 9 1) ([] :: [Interval a]) `shouldBe` Nothing-         it "more gapsWithin tests" pending--   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]-         it "more emptyif tests" pending--   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_filterEquals @Int)-         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 "filterEnclose property" $ property (prop_filterEnclose @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)    `shouldBe` Nothing-         it "intersection of (0, 2) (3, 4) should be Nothing" $-            intersect (iv 2 0) (iv 1 3)    `shouldBe` Nothing-         it "intersection of (2, 4) (0, 2) should be Nothing" $-            intersect (iv 2 2) (iv 2 0)    `shouldBe` Nothing +  describe "gaps tests" $ modifyMaxSuccess (* 10) $ do+    it "no gaps in containmentInt and noncontainmentInt"+      $          gaps [containmentInt, noncontainmentInt]+      `shouldBe` []+    it "no gaps in containmentInt" $ gaps [containmentInt] `shouldBe` []+    it "single gap between containmentInt and anotherInt"+      $          gaps [containmentInt, anotherInt]+      `shouldBe` [gapInt]+    it "after gaps, only relation should be Before" $ property (prop_gaps1 @Int) -   describe "intersection tests" $-      do-         it "intersection of (0, 2) (2, 4) should be Nothing" $-            intersect (iv 2 0) (iv 2 2)    `shouldBe` Nothing-         it "intersection of (0, 2) (3, 4) should be Nothing" $-            intersect (iv 2 0) (iv 1 3)    `shouldBe` Nothing-         it "intersection of (2, 4) (0, 2) should be Nothing" $-            intersect (iv 2 2) (iv 2 0)    `shouldBe` Nothing-         it "intersection of (0, 2) (1, 3) should be Just (1, 2)" $-            intersect (iv 2 0) (iv 2 1)    `shouldBe` Just (iv 1 1)-         it "intersection of (0, 2) (-1, 3) should be Just (0, 2)" $-            intersect (iv 2 0) (iv 4 (-1)) `shouldBe` Just (iv 2 0)-         it "intersection of (0, 2) (0, 2) should be Just (0, 2)" $-            intersect (iv 2 0) (iv 2 0)    `shouldBe` Just (iv 2 0)-         it "intersection of (0, 2) (-1, 1) should be Just (0, 1)" $-            intersect (iv 2 0) (iv 2 (-1)) `shouldBe` Just (iv 1 0)-         it "intersection of (0, 3) (1, 2) should be Just (1, 2)" $-            intersect (iv 3 0) (iv 1 1)    `shouldBe` Just (iv 1 1)+  describe "durations unit tests" $ do+    it "durations of containmentInt is 10"+      $          durations [containmentInt]+      `shouldBe` [10]+    it "durations of empty list is empty list"+      $          durations ([] :: [Interval Int])+      `shouldBe` []+    it "durations of [containmentInt, anotherInt] is [10, 5]"+      $          durations [containmentInt, anotherInt]+      `shouldBe` [10, 5] -   describe "combineIntervals unit tests" $-      do-         it "noncontainmentInt combined into containmentInt" $-               combineIntervals [containmentInt, noncontainmentInt]-                  `shouldBe` [containmentInt]-         it "noncontainmentInt combined into containmentInt; anotherInt unchanged" $-               combineIntervals [containmentInt, noncontainmentInt, anotherInt]-                  `shouldBe` [containmentInt, anotherInt]-         it "idempotency of containmentInt" $-               combineIntervals [containmentInt] `shouldBe` [containmentInt]-         it "idempotency of noncontainmentInt" $-               combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt]-         it "combineIntervals [] should be []" $-               combineIntervals ([] :: [Interval Int]) `shouldBe` []-         it "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]" $-               combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]-                  `shouldBe` [iv 12 0, iv 2 13]+  describe "clip tests" $ do+    it "clip disjoint should be Nothing"+      $          clip containmentInt gapInt+      `shouldBe` Nothing+    it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)"+      $          clip noncontainmentInt containmentInt+      `shouldBe` Just (iv 6 4)+    it "clip x y === intersect sort x y " $ property (prop_clip_intersect @Int) -   describe "combineIntervals property tests" $-      modifyMaxSuccess (*10) $-      do-         it "after combining, only relation should be Before" $-               property ( prop_combineIntervals1 @Int)+  describe "relations tests" $ do+    it+        "relations [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]"+      $ relations [containmentInt, noncontainmentInt, gapInt, anotherInt]+      `shouldBe` [FinishedBy, Meets, Meets]+    it "relations of [] shouldBe []"+      $          relations ([] :: [Interval Int])+      `shouldBe` []+    it "relations of singleton shouldBe []"+      $          relations [containmentInt]+      `shouldBe` []+    it "length of relations result should be 1 less then length of input"+      $ property+          (\x ->+            not (null x)+              ==> length (relations x)+              === length (x :: [Interval Int])+              -   1+          ) -   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 "intersection tests" $ do+    it "intersection of (0, 2) (2, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 2 2)+      `shouldBe` Nothing+    it "intersection of (0, 2) (3, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 1 3)+      `shouldBe` Nothing+    it "intersection of (2, 4) (0, 2) should be Nothing"+      $          intersect (iv 2 2) (iv 2 0)+      `shouldBe` Nothing -   describe "formMeetingSequence unit tests" $-      do-         it "formMeetingSequence unit test 0" $-            formMeetingSequence c0in `shouldBe` c0out-         it "formMeetingSequence unit test 1"$-            formMeetingSequence c1in `shouldBe` c1out-         it "formMeetingSequence unit test 2"$-            formMeetingSequence c2in `shouldBe` c2out-         it "formMeetingSequence unit test 3"$-            formMeetingSequence c3in `shouldBe` c3out-         it "formMeetingSequence unit test 4"$-            formMeetingSequence c4in `shouldBe` c4out-         it "formMeetingSequence unit test 5"$-            formMeetingSequence c5in `shouldBe` c5out-         it "formMeetingSequence unit test 6"$-            formMeetingSequence ([] :: [StateEvent Int]) `shouldBe` []+  describe "intersection tests" $ do+    it "intersection of (0, 2) (2, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 2 2)+      `shouldBe` Nothing+    it "intersection of (0, 2) (3, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 1 3)+      `shouldBe` Nothing+    it "intersection of (2, 4) (0, 2) should be Nothing"+      $          intersect (iv 2 2) (iv 2 0)+      `shouldBe` Nothing+    it "intersection of (0, 2) (1, 3) should be Just (1, 2)"+      $          intersect (iv 2 0) (iv 2 1)+      `shouldBe` Just (iv 1 1)+    it "intersection of (0, 2) (-1, 3) should be Just (0, 2)"+      $          intersect (iv 2 0) (iv 4 (-1))+      `shouldBe` Just (iv 2 0)+    it "intersection of (0, 2) (0, 2) should be Just (0, 2)"+      $          intersect (iv 2 0) (iv 2 0)+      `shouldBe` Just (iv 2 0)+    it "intersection of (0, 2) (-1, 1) should be Just (0, 1)"+      $          intersect (iv 2 0) (iv 2 (-1))+      `shouldBe` Just (iv 1 0)+    it "intersection of (0, 3) (1, 2) should be Just (1, 2)"+      $          intersect (iv 3 0) (iv 1 1)+      `shouldBe` Just (iv 1 1)+  describe "rangeInterval unit tests" $ do+    it "range of empty list returns Nothing"+      $          rangeInterval ([] :: [Interval Int])+      `shouldBe` Nothing+    it "rangeInterval returns the containing interval"+      $          rangeInterval [beginerval 0 (1 :: Int), beginerval 3 (-1)]+      `shouldBe` (Just $ beginerval 3 (-1))+    it "disjoint intervals"+      $          rangeInterval [beginerval 10 (1 :: Int), beginerval 1 (-1)]+      `shouldBe` (Just $ beginerval 12 (-1))+    it "order of list does not matter"+      $          rangeInterval [beginerval 10 (1 :: Int), beginerval 1 (-1)]+      `shouldBe` rangeInterval [beginerval 1 (-1), beginerval 10 (1 :: Int)]+    it "works on Right"+      $          rangeInterval (Right $ beginerval 10 (1 :: Int))+      `shouldBe` (Just $ beginerval 10 (1 :: Int))+    it "Left variant returns Nothing"+      $          rangeInterval (Left $ beginerval 10 (1 :: Int))+      `shouldBe` (Nothing :: Maybe (Interval Int))+  describe "combineIntervals unit tests" $ do+    it "noncontainmentInt combined into containmentInt"+      $          combineIntervals [containmentInt, noncontainmentInt]+      `shouldBe` [containmentInt]+    it "noncontainmentInt combined into containmentInt; anotherInt unchanged"+      $ combineIntervals [containmentInt, noncontainmentInt, anotherInt]+      `shouldBe` [containmentInt, anotherInt]+    it "idempotency of containmentInt"+      $          combineIntervals [containmentInt]+      `shouldBe` [containmentInt]+    it "idempotency of noncontainmentInt"+      $          combineIntervals [noncontainmentInt]+      `shouldBe` [noncontainmentInt]+    it "combineIntervals [] should be []"+      $          combineIntervals ([] :: [Interval Int])+      `shouldBe` []+    it "combineIntervals works on sorted intervals"+      $          combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]+      `shouldBe` [iv 12 0, iv 2 13]+    it "combineIntervalsFromSorted works on sorted intervals"+      $          combineIntervalsFromSorted [iv 10 0, iv 5 2, iv 2 10, iv 2 13]+      `shouldBe` [iv 12 0, iv 2 13]+    it "combineIntervals works on unsorted intervals"+      $          combineIntervals [iv 2 13, iv 10 0, iv 2 10, iv 5 2]+      `shouldBe` [iv 12 0, iv 2 13] -   describe "formMeetingSequence property tests" $-      modifyMaxSuccess (*50) $-      do-          it "prop_formMeetingSequence0" $-            property prop_formMeetingSequence0-          it "prop_formMeetingSequence1" $-            property prop_formMeetingSequence1-          it "prop_formMeetingSequence2" $-            property prop_formMeetingSequence2+  describe "combineIntervals property tests" $ modifyMaxSuccess (* 10) $ do+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @Int)+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @Day)+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @UTCTime)

@@ -1,19 +1,17 @@-module IntervalAlgebra.PairedIntervalSpec (spec) where+module IntervalAlgebra.PairedIntervalSpec+  ( spec+  ) where -import Test.Hspec                       ( it, describe, Spec, shouldBe )-import IntervalAlgebra.PairedInterval   ( PairedInterval-                                        , makePairedInterval-                                        , intervals-                                        , Empty(..) )-import IntervalAlgebra                  ( beginerval-                                        , IntervalSizeable(duration)-                                        , equals-                                        , before-                                        , IntervalCombinable(..) )-import Data.Bifunctor                   ( Bifunctor(bimap) )-import Data.Bool-import Data.Time                        ( Day(ModifiedJulianDay)-                                        , fromGregorian )+import           Data.Bool+import           Data.Time                      (Day (ModifiedJulianDay),+                                                 fromGregorian)+import           IntervalAlgebra                (Intervallic (..),+                                                 SizedIv (duration), before,+                                                 beginerval, equals,+                                                 toEnumInterval)+import           IntervalAlgebra.PairedInterval (Empty (..), PairedInterval,+                                                 intervals, makePairedInterval)+import           Test.Hspec                     (Spec, describe, it, shouldBe)  type TestPair = PairedInterval String Int @@ -31,45 +29,30 @@  spec :: Spec spec = do-  describe "Basic tests of paired intervals" $-    do -    it "the same pairInterval should be equal" $ t1 == t1 `shouldBe` True +  describe "Basic tests of paired intervals" $ do+    it "the same pairInterval should be equal" $ t1 == t1 `shouldBe` True     it "different pairInterval should not be equal" $ t1 /= t2 `shouldBe` True-    it "fmapping into a different interval type" $ -        fmap ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0))-            `shouldBe` makePairedInterval "hi" (beginerval 5 (fromGregorian 1858 11 17)) -    it "bimapping into a different type" $ -        bimap (== "hi") ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0))-            `shouldBe `makePairedInterval True (beginerval 5 (fromGregorian 1858 11 17))-    it "show paired interval" $-      show t1 `shouldBe` "{(0, 5), \"hi\"}"+    -- NOTE toEnum (fromGregorian 1858 11 17) is 0, since that date is the+    -- origin in the modified Julian calendar.+    it "toEnumInterval into PairedInterval b Day"+      $          toEnumInterval (makePairedInterval "hi" (beginerval 5 0))+      `shouldBe` makePairedInterval "hi"+                                    (beginerval 5 (fromGregorian 1858 11 17))+    it "show paired interval" $ show t1 `shouldBe` "{(0, 5), \"hi\"}" -    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 "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"-        it "combine emptyies" $ Empty <> Empty `shouldBe` Empty -        it "monoid empty" $ (mempty :: Empty) `shouldBe` Empty-        it "monoid mappend" $ mappend Empty Empty `shouldBe` Empty -        it "ord empty" $ Empty < Empty `shouldBe` False-        it "ord empty" $ Empty <= Empty `shouldBe` True+    describe "tests on paired intervals" $ do+      it "t1 is before t2" $ (t1 `before` t2) `shouldBe` True+      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 "tests on empty" $ do+      it "show empty" $ show Empty `shouldBe` "Empty"+      it "combine emptyies" $ Empty <> Empty `shouldBe` Empty+      it "monoid empty" $ (mempty :: Empty) `shouldBe` Empty+      it "monoid <>" $ Empty <> Empty `shouldBe` Empty+      it "ord empty" $ Empty < Empty `shouldBe` False+      it "ord empty" $ Empty <= Empty `shouldBe` True

@@ -1,776 +1,367 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module IntervalAlgebraSpec (spec) where--import Test.Hspec                 ( hspec, describe, it, Spec, shouldBe, pending )-import Test.Hspec.QuickCheck      ( modifyMaxSuccess, modifyMaxDiscardRatio )-import Test.QuickCheck            ( (===)-                                  , (==>)-                                  , Arbitrary(arbitrary)-                                  , Property-                                  ,  Testable(property) )-import Data.Maybe                 ( fromJust )-import Data.Either                ( isRight )-import IntervalAlgebra.Arbitrary  ()-import Data.Time as DT            ( Day(..)-                                  , fromGregorian-                                  )-import Data.Set                   ( Set-                                  , member-                                  , disjointUnion-                                  , fromList )-import IntervalAlgebra as IA      ( enderval-                                  , beginerval-                                  , expandr-                                  , expandl-                                  , expand-                                  , parseInterval-                                  , before-                                  , meets-                                  , overlaps-                                  , finishedBy-                                  , contains-                                  , starts-                                  , precedes-                                  , precededBy-                                  , equals-                                  , startedBy-                                  , during-                                  , finishes-                                  , overlappedBy-                                  , metBy-                                  , after-                                  , relate-                                  , compose-                                  , disjoint-                                  , within-                                  , concur-                                  , notDisjoint-                                  , enclose-                                  , enclosedBy-                                  , (<|>)-                                  , begin-                                  , end-                                  , disjointRelations-                                  , withinRelations-                                  , converse-                                  , union-                                  , intersection-                                  , complement-                                  , diffFromBegin-                                  , diffFromEnd-                                  , IntervalCombinable((.+.))-                                  , IntervalSizeable(moment, moment', diff)-                                  , ComparativePredicateOf1-                                  , ComparativePredicateOf2-                                  , Intervallic-                                  , Interval-                                  , IntervalRelation (..)-                                  , intervalRelations-                                  , notDisjoint-                                  , momentize )--mkIntrvl :: Int -> Int -> Interval Int-mkIntrvl = beginerval--xor :: Bool -> Bool -> Bool-xor a b = a /= b---- | Internal function for converting a number to a strictly positive value.-makePos :: (Ord b, Num b) => b -> b-makePos x-  | x == 0    = x + 1-  | x <  0    = negate x-  | 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)---- TODO: remove duplication like this:-instance Arbitrary (M1set Int) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    b <- arbitrary-    m1set x a b <$> arbitrary--instance Arbitrary (M1set DT.Day) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    b <- arbitrary-    m1set x a b <$> arbitrary---- | 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)--{--- ** 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:-- \[-   \forall i,j,k,l s.t. (i:j & i:k & 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--prop_IAaxiomM1_Int :: M1set Int -> Property-prop_IAaxiomM1_Int = prop_IAaxiomM1--prop_IAaxiomM1_Day :: M1set DT.Day -> Property-prop_IAaxiomM1_Day = prop_IAaxiomM1---- | 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)--instance Arbitrary (M2set Int) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    b <- arbitrary-    m2set x a b <$> arbitrary--instance Arbitrary (M2set DT.Day) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    b <- arbitrary-    m2set x a b <$> arbitrary---- | 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--{---** Axiom M2--If period i meets period j and period k meets l, -then exactly one of the following holds:-  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.-   -That is,-- \[-   \forall i,j,k,l s.t. (i:j & 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_Int :: M2set Int -> Property-prop_IAaxiomM2_Int = prop_IAaxiomM2--prop_IAaxiomM2_Day :: M2set DT.Day -> Property-prop_IAaxiomM2_Day = prop_IAaxiomM2--{--- ** Axiom ML1-- An interval cannot meet itself.-- \[-   \forall i \lnot i:i- \] --}--prop_IAaxiomML1 :: (Ord a) => Interval a -> Property-prop_IAaxiomML1 x = not (x `meets` x) === True--prop_IAaxiomML1_Int :: Interval Int -> Property-prop_IAaxiomML1_Int = prop_IAaxiomML1--prop_IAaxiomML1_Day :: Interval DT.Day -> Property-prop_IAaxiomML1_Day = prop_IAaxiomML1--{---** Axiom ML2--If i meets j then j does not meet i.--\[- \forall i,j i:j \implies \lnot j: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--prop_IAaxiomML2_Int :: M2set Int -> Property-prop_IAaxiomML2_Int = prop_IAaxiomML2--prop_IAaxiomML2_Day :: M2set DT.Day -> Property-prop_IAaxiomML2_Day = prop_IAaxiomML2--{---** Axiom M3--Time does not start or stop:--\[- \forall i \exists j,k s.t. j:i:k-\] --}--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)--prop_IAaxiomM3_Int :: Interval Int -> Property-prop_IAaxiomM3_Int = prop_IAaxiomM3 1--prop_IAaxiomM3_Day :: Interval Day -> Property-prop_IAaxiomM3_Day = prop_IAaxiomM3 1--{---** Axiom M4--If two meets are separated by intervals, then this sequence is a longer interval.--\[- \forall i,j i:j \implies (\exists k,m,n s.t m:i:j:n & m:k:n) -\] --}--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)--prop_IAaxiomM4_Int :: M2set Int -> Property-prop_IAaxiomM4_Int = prop_IAaxiomM4 1--prop_IAaxiomM4_Day :: M2set DT.Day -> Property-prop_IAaxiomM4_Day = prop_IAaxiomM4 1--{---** Axiom M5--If two meets are separated by intervals, then this sequence is a longer interval.--\[- \forall i,j,k,l (i:j:l & i:k:l) \seteq j = k-\] --}---- | A set used for testing M5.-data M5set a = M5set {-     m51 :: Interval a-   , m52 :: Interval a }-   deriving (Show)--instance Arbitrary (M5set Int) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    m5set x a <$> arbitrary--instance Arbitrary (M5set DT.Day) where-  arbitrary = do-    x <- arbitrary-    a <- arbitrary-    m5set x a <$> arbitrary---- | 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---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--prop_IAaxiomM5_Int :: M5set Int -> Property-prop_IAaxiomM5_Int = prop_IAaxiomM5--prop_IAaxiomM5_Day :: M5set DT.Day -> Property-prop_IAaxiomM5_Day = prop_IAaxiomM5--{---** Axiom M4.1--Ordered unions:--\[- \forall i,j i:j \implies (\exists m,n s.t. m:i:j:n & 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--prop_IAaxiomM4_1_Int :: M2set Int -> Property-prop_IAaxiomM4_1_Int = prop_IAaxiomM4_1 1--prop_IAaxiomM4_1_Day :: M2set DT.Day -> Property-prop_IAaxiomM4_1_Day = prop_IAaxiomM4_1 1--{--* Interval Relation property testing --}--class ( IntervalSizeable a b ) => IntervalRelationProperties a b where--    prop_IAbefore :: Interval a -> Interval a -> Property-    prop_IAbefore i j =-      IA.before i j ==> (i `meets` k) && (k `meets` j)-        where k = beginerval (diff (begin j) (end i)) (end i)--    prop_IAstarts:: Interval a -> Interval a -> Property-    prop_IAstarts i j-      | IA.starts i j = (j == fromJust (i .+. k)) === True-      | otherwise     = IA.starts i j === False-        where k = beginerval (diff (end j) (end i)) (end i)--    prop_IAfinishes:: Interval a -> Interval a -> Property-    prop_IAfinishes i j-      | IA.finishes i j = (j == fromJust ( k .+. i)) === True-      | otherwise       = IA.finishes i j === False-        where k = beginerval (diff (begin i) (begin j)) (begin j)--    prop_IAoverlaps:: Interval a -> Interval a -> Property-    prop_IAoverlaps i j-      | IA.overlaps i j = ((i == fromJust ( k .+. l )) &&-                          (j == fromJust ( l .+. m ))) === True-      | otherwise       = IA.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_IAduring:: Interval a -> Interval a-> Property-    prop_IAduring i j-      | IA.during i j = (j == fromJust ( fromJust (k .+. i) .+. l)) === True-      | otherwise     = IA.during i j === False-        where k = beginerval (diff (begin i) (begin j)) (begin j)-              l = beginerval (diff (end j)   (end i))   (end i)--    -- | 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--    -- | 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)--    prop_disjoint_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint--    prop_notdisjoint_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_notdisjoint_predicate = -      prop_predicate_unions (complement disjointRelations) notDisjoint--    prop_concur_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_concur_predicate = -      prop_predicate_unions (complement disjointRelations) concur --    prop_within_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_within_predicate = prop_predicate_unions withinRelations within--    prop_enclosedBy_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy--    prop_enclose_predicate :: (Ord a) =>        -          Interval a -        -> Interval a-        -> Property -    prop_enclose_predicate = prop_predicate_unions (converse withinRelations) enclose--instance IntervalRelationProperties Int Int-instance IntervalRelationProperties Day Integer--allIArelations:: (Ord a) => [ComparativePredicateOf1 (Interval a)]-allIArelations =   [  IA.equals-                    , IA.meets-                    , IA.metBy-                    , IA.before-                    , IA.after-                    , IA.starts-                    , IA.startedBy-                    , IA.finishes-                    , IA.finishedBy-                    , IA.overlaps-                    , IA.overlappedBy-                    , IA.during-                    , IA.contains ]--prop_expandl_end ::(IntervalSizeable a b, Show a)=>-       b-    -> 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-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 x y z = member (relate x z) (compose (relate x y) (relate y z)) === True---spec :: Spec-spec = do-  describe "Basic Interval unit tests of typeclass and creation methods" $-    do-      it "equality works" $ beginerval 6 (1::Int) == beginerval 6 1 `shouldBe` True-      it "equality works" $ beginerval 0 (1::Int) == beginerval (-1) 1 `shouldBe` True-      it "equality works" $ enderval 1 (2::Int) == beginerval 1 1 `shouldBe` True-      it "not equality works" $ enderval 5 (2::Int) /= beginerval 1 1 `shouldBe` True--      it "parsing fails on bad inputs" $-         parseInterval 10 0 `shouldBe` Left "0<10"-      it "parsing works on good inputs" $-         parseInterval 0 10 `shouldBe` Right (beginerval 10 (0::Int))--      it "show displays intervals as expected" $-         show (beginerval 10 (0::Int)) `shouldBe` "(0, 10)"--      it "fmap can convert Interval Integer to Interval Day" $-         fmap ModifiedJulianDay (beginerval 1 0) `shouldBe`-            beginerval 1 (fromGregorian 1858 11 17)--      it "(0, 2) <= (1, 3) is True" $-          beginerval 2 (0::Int) <= beginerval 2 1 `shouldBe` True--      it "(1, 2) < (0, 3) is True" $-          beginerval 2 (1::Int) < beginerval 3 0 `shouldBe` False-      it "(0, 2) < (1, 3) is True" $-          beginerval 2 (0::Int) < beginerval 2 1 `shouldBe` True-      it "(0, 2) < (0, 3) is True" $-          beginerval 2 (0::Int) < beginerval 3 0 `shouldBe` True--  describe "Basic IntervalRelation unit tests" $-    do -      it "equality of IntervalRelations" $ Before == Before `shouldBe` True-      it "equality of IntervalRelations" $ Before /= After `shouldBe` True--      it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before-      it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After--      it "show Before is Before" $ show Before `shouldBe` "Before"--  describe "Relate unit tests" $-    do -      it "relate before" $ -        relate (beginerval 1 (0::Int)) (beginerval 1 2) `shouldBe` Before -      it "relate after" $-        relate (beginerval 1 (2::Int)) (beginerval 1 0) `shouldBe` After -      it "relate meets" $ -        relate (beginerval 1 (0::Int)) (beginerval 1 1) `shouldBe` Meets -      it "relate metBy" $ -        relate (beginerval 1 (1::Int)) (beginerval 1 0) `shouldBe` MetBy -      it "relate overlaps" $ -        relate (beginerval 3 (0::Int)) (beginerval 5 2) `shouldBe` Overlaps -      it "relate overlappedBy" $ -        relate (beginerval 5 (2::Int)) (beginerval 3 0) `shouldBe` OverlappedBy-      it "relate starts" $-        relate (beginerval 3 (0::Int)) (beginerval 5 0) `shouldBe` Starts -      it "relate startedBy" $-        relate (beginerval 5 (0::Int)) (beginerval 3 0) `shouldBe` StartedBy-      it "relate finishes" $-        relate (enderval 3 (0::Int)) (enderval 5 0) `shouldBe` Finishes-      it "relate finishedBy" $-        relate (enderval 5 (0::Int)) (enderval 3 0) `shouldBe` FinishedBy-      it "relate during" $-        relate (beginerval 1 (1::Int)) (beginerval 3 0) `shouldBe` During-      it "relate Contains" $-        relate (beginerval 3 (0::Int)) (beginerval 1 1) `shouldBe` Contains--  describe "IntervalRelation algebraic operations" $-    do -      it "converse of Before is After" $ converse (fromList [Before]) `shouldBe`  fromList [After]--      it "union of IntervalRelations" $ union (fromList [Before]) (fromList [After]) -        `shouldBe` fromList [Before, After]-      it "intersection of IntervalRelations" $ intersection (fromList [Before]) (fromList [After]) -        `shouldBe` fromList []--  describe "IntervalSizeable tests" $-    do-      it "moment is 1" $ moment @Int `shouldBe` 1-      it "moment' is 1" $ moment' (beginerval 1 (0::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)" $-        expand 0 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int)-      it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)" $-        expand 5 0 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (-5::Int)-      it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)" $-        expand 5 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (11::Int) (-5::Int)-      it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)" $-        expand (-1) 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int)-      it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)" $-        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)) `shouldBe`-         beginerval (2::Int) (-1::Int)--      it "beginerval 2 10 should be Interval (10, 12)" $-        Right (beginerval (2::Int) 10) `shouldBe` parseInterval (10::Int) (12::Int)-      it "beginerval 0 10 should be Interval (10, 11)" $-        Right (beginerval (0::Int) 10) `shouldBe` parseInterval (10::Int) (11::Int)-      it "beginerval -2 10 should be Interval (10, 11)" $-        Right (beginerval (-2::Int) 10) `shouldBe` parseInterval (10::Int) (11::Int)-      it "enderval 2 10 should be Interval (8, 10)" $-        Right (enderval (2::Int) 10) `shouldBe` parseInterval (8::Int) (10::Int)-      it "enderval 0 10 should be Interval (9, 10)" $-        Right (enderval (0::Int) 10) `shouldBe` parseInterval (9::Int) (10::Int)-      it "enderval -2 10 should be Interval (9, 10)" $-        Right (enderval (-2::Int) 10) `shouldBe` parseInterval (9::Int) (10::Int)--      it "diffFromBegin can convert Interval Int to Interval Int" $-         diffFromBegin -            (beginerval 2 (4 :: Int))-            (beginerval 2 10) `shouldBe`-            beginerval 2 6 -- (6, 8)--      it "diffFromEnd can convert Interval Int to Interval Int" $-         diffFromEnd-            (beginerval 2 (4 :: Int))-            (beginerval 2 10) `shouldBe`-            beginerval 2 4 -- (4, 6)--      it "diffFromBegin can convert Interval Day to Interval Integer" $-         diffFromBegin -            (beginerval 2 (fromGregorian 2001 1 1))-            (beginerval 2 (fromGregorian 2001 1 10)) `shouldBe`-            beginerval 2 9 -- (9, 11)--      it "diffFromEnd can convert Interval Day to Interval Integer" $-         diffFromEnd-            (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 "Intervallic tests" $-     modifyMaxSuccess (*10000) $-     do-      it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True" $-        (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1))-         `shouldBe` True-      it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True" $-        (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0)-         `shouldBe` True-      it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False" $-        (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1))-         `shouldBe` False-      it "disjoint x y same as explicit union of predicates" $-         disjoint (mkIntrvl 2 0) (mkIntrvl 2 3) `shouldBe`-         (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0) (mkIntrvl 2 3)-      it "within x y same as explicit union of predicates" $-         within (mkIntrvl 2 3) (mkIntrvl 2 3) `shouldBe`-         (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3) (mkIntrvl 2 3)-      it "prop_compose holds" $-         property (prop_compose @Int)--  describe "IntervalCombinable tests" $-      do-        it "join non-meeting intervals is Nothing" $ -          beginerval 2 (0::Int) .+. beginerval 6 5 `shouldBe` Nothing-        it "join meeting intervals is Just _" $ -          beginerval 2 (0::Int) .+. beginerval 6 2 `shouldBe` Just (beginerval 8 0) -        it "" pending--  describe "Interval Algebra Axioms for meets properties" $-    modifyMaxSuccess (*10) $-    do-      it "M1 Int" $ property prop_IAaxiomM1_Int-      it "M1 Day" $ property prop_IAaxiomM1_Day-      it "M2_Int" $ property prop_IAaxiomM2_Int-      it "M2_Day" $ property prop_IAaxiomM2_Day-      it "ML1_Int" $ property prop_IAaxiomML1_Int-      it "ML1_Day" $ property prop_IAaxiomML1_Day-      it "ML2_Int" $ property prop_IAaxiomML2_Int-      it "ML2_Day" $ property prop_IAaxiomML2_Day-      {--        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.-      -}-      --it "ML3" $ property prop_IAaxiomML3-      it "M3_Int" $ property prop_IAaxiomM3_Int-      it "M3_Day" $ property prop_IAaxiomM3_Day-      it "M4_Int" $ property prop_IAaxiomM4_Int-      it "M4_Day" $ property prop_IAaxiomM4_Day-      it "M5_Int" $ property prop_IAaxiomM5_Int-      it "M5_Day" $ property prop_IAaxiomM5_Day-      it "M4.1_Int" $ property prop_IAaxiomM4_1_Int-      it "M4.1_Day" $ property prop_IAaxiomM4_1_Day--  describe "Interval Algebra relation properties" $-      modifyMaxSuccess (*10) $-    do-      it "before"   $ property (prop_IAbefore @Int)-      it "starts"   $ property (prop_IAstarts @Int)-      it "finishes" $ property (prop_IAfinishes @Int)-      it "overlaps" $ property (prop_IAoverlaps @Int)-      it "during"   $ property (prop_IAduring @Int)-      it "before"   $ property (prop_IAbefore @Day)-      it "starts"   $ property (prop_IAstarts @Day)-      it "finishes" $ property (prop_IAfinishes @Day)-      it "overlaps" $ property (prop_IAoverlaps @Day)-      it "during"   $ property (prop_IAduring @Day)--      it "disjoint" $ property (prop_disjoint_predicate @Int)-      it "disjoint" $ property (prop_disjoint_predicate @Day)-      it "within" $ property (prop_within_predicate @Int)-      it "within" $ property (prop_within_predicate @Day)-      it "enclose" $ property (prop_enclose_predicate @Int)-      it "enclose" $ property (prop_enclose_predicate @Day)-      it "enclosedBy" $ property (prop_enclosedBy_predicate @Int)-      it "enclosedBy" $ property (prop_enclosedBy_predicate @Day)-      it "notDisjoint" $ property (prop_notdisjoint_predicate @Int)-      it "notDisjoint" $ property (prop_notdisjoint_predicate @Day)-      it "concur" $ property (prop_concur_predicate @Int)-      it "concur" $ property (prop_concur_predicate @Day)--  describe "Interval Algebra relation unit tests for synonyms" $-    do-      it "(0, 2) precedes (10, 12)" $-          beginerval  2 (0::Int) `precedes` beginerval 2 10 `shouldBe` True-      it "precedes matches before" $-          beginerval  10 (0::Int) `precedes` beginerval 1 11 `shouldBe`-          beginerval  10 (0::Int) `before` beginerval 1 11-      it "(10, 12) precededBy (0, 2)" $-          precededBy (beginerval 2 10) (beginerval  2 (0::Int)) `shouldBe` True-      it "precededBy matches after" $-          precededBy (beginerval 1 11) (beginerval  10 (0::Int)) `shouldBe` -          after (beginerval 1 11) (beginerval  10 (0::Int))-      it "concur matches notDdisjoint" $-          concur (beginerval 1 11) (beginerval  10 (0::Int)) `shouldBe` -          notDisjoint (beginerval 1 11) (beginerval  10 (0::Int))-      it "concur matches notDisjoint" $-          concur (beginerval 1 0) (beginerval  10 (0::Int)) `shouldBe` -          notDisjoint (beginerval 1 0) (beginerval  10 (0::Int)) ---  describe "Interval Algebra relation uniqueness" $-      modifyMaxSuccess (*100) $-    do-      it "exactly one relation must be true" $-        property (prop_exclusiveRelations @Int)-      it "exactly one relation must be true" $-        property (prop_exclusiveRelations @Day)+{-# 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)+import           Data.Set                  (Set, disjointUnion, fromList,+                                            member)+import           Data.Time                 as DT (Day (..), DiffTime,+                                                  NominalDiffTime, UTCTime (..),+                                                  fromGregorian,+                                                  picosecondsToDiffTime,+                                                  secondsToDiffTime)+import           GHC.Real                  (Rational (..), Real (..))+import           IntervalAlgebra           as IA+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),+                                            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+  :: (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+  :: (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, 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, 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, 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+    it "equality works"+      $          beginerval 6 (1 :: Int)+      ==         beginerval 6 1+      `shouldBe` True+    it "equality works"+      $          beginerval 0    (1 :: Int)+      ==         beginerval (-1) 1+      `shouldBe` True+    it "equality works"+      $          enderval 1 (2 :: Int)+      ==         beginerval 1 1+      `shouldBe` True+    it "not equality works"+      $          enderval 5 (2 :: Int)+      /=         beginerval 1 1+      `shouldBe` True++    it "beginervalMoment duration is moment"+      $          duration (beginervalMoment (-13 :: Int))+      `shouldBe` (moment @(Interval Int))+    it "endervalMoment duration is moment"+      $          duration (endervalMoment (26 :: Int))+      `shouldBe` (moment @(Interval Int))++    it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left+      (IA.ParseErrorInterval "0<=10")+    it "parsing fails on bad inputs" $ parseInterval 0 0 `shouldBe` Left+      (IA.ParseErrorInterval "0<=0")+    it "parsing works on good inputs" $ parseInterval 0 10 `shouldBe` Right+      (beginerval 10 (0 :: Int))++    it "show displays intervals as expected"+      $          show (beginerval 10 (0 :: Int))+      `shouldBe` "(0, 10)"++    -- NOTE toEnum (fromGregorian 1858 11 17) is 0,+    -- since that date is the origin in the modified+    -- Julian calendar.+    it "fromEnumInterval converts Interval Day"+      $          fromEnumInterval (beginerval 0 (fromGregorian 1858 11 17))+      `shouldBe` beginerval 0 0++    it "(0, 2) <= (1, 3) is True"+      $          beginerval 2 (0 :: Int)+      <=         beginerval 2 1+      `shouldBe` True++    it "(1, 2) < (0, 3) is True"+      $          beginerval 2 (1 :: Int)+      <          beginerval 3 0+      `shouldBe` False+    it "(0, 2) < (1, 3) is True"+      $          beginerval 2 (0 :: Int)+      <          beginerval 2 1+      `shouldBe` True+    it "(0, 2) < (0, 3) is True"+      $          beginerval 2 (0 :: Int)+      <          beginerval 3 0+      `shouldBe` True++  describe "Basic IntervalRelation unit tests" $ do+    it "equality of IntervalRelations" $ Before == Before `shouldBe` True+    it "equality of IntervalRelations" $ Before /= After `shouldBe` True++    it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before+    it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After++    it "show Before is Before" $ show Before `shouldBe` "Before"++  describe "Relate unit tests" $ do+    it "relate before"+      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 2)+      `shouldBe` Before+    it "relate after"+      $          relate (beginerval 1 (2 :: Int)) (beginerval 1 0)+      `shouldBe` After+    it "relate meets"+      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 1)+      `shouldBe` Meets+    it "relate metBy"+      $          relate (beginerval 1 (1 :: Int)) (beginerval 1 0)+      `shouldBe` MetBy+    it "relate overlaps"+      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 2)+      `shouldBe` Overlaps+    it "relate overlappedBy"+      $          relate (beginerval 5 (2 :: Int)) (beginerval 3 0)+      `shouldBe` OverlappedBy+    it "relate starts"+      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 0)+      `shouldBe` Starts+    it "relate startedBy"+      $          relate (beginerval 5 (0 :: Int)) (beginerval 3 0)+      `shouldBe` StartedBy+    it "relate finishes"+      $          relate (enderval 3 (0 :: Int)) (enderval 5 0)+      `shouldBe` Finishes+    it "relate finishedBy"+      $          relate (enderval 5 (0 :: Int)) (enderval 3 0)+      `shouldBe` FinishedBy+    it "relate during"+      $          relate (beginerval 1 (1 :: Int)) (beginerval 3 0)+      `shouldBe` During+    it "relate Contains"+      $          relate (beginerval 3 (0 :: Int)) (beginerval 1 1)+      `shouldBe` Contains++  describe "IntervalRelation algebraic operations" $ do+    it "converse of Before is After"+      $          converse (fromList [Before])+      `shouldBe` fromList [After]++    it "union of IntervalRelations"+      $          union (fromList [Before]) (fromList [After])+      `shouldBe` fromList [Before, After]+    it "intersection of IntervalRelations"+      $          intersection (fromList [Before]) (fromList [After])+      `shouldBe` fromList []++  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)"+      $          expand 0 5 (beginerval (1 :: Int) (0 :: Int))+      `shouldBe` beginerval (6 :: Int) (0 :: Int)+    it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)"+      $          expand 5 0 (beginerval (1 :: Int) (0 :: Int))+      `shouldBe` beginerval (6 :: Int) (-5 :: Int)+    it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)"+      $          expand 5 5 (beginerval (1 :: Int) (0 :: Int))+      `shouldBe` beginerval (11 :: Int) (-5 :: Int)+    it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)"+      $          expand (-1) 5 (beginerval (1 :: Int) (0 :: Int))+      `shouldBe` beginerval (6 :: Int) (0 :: Int)+    it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)"+      $          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 @(Interval Int)) 0 (beginerval (1 :: Int) (0 :: Int))+      `shouldBe` beginerval (2 :: Int) (-1 :: Int)++    it "beginerval 2 10 should be Interval (10, 12)"+      $          Right (beginerval (2 :: Int) 10)+      `shouldBe` parseInterval (10 :: Int) (12 :: Int)+    it "beginerval 0 10 should be Interval (10, 11)"+      $          Right (beginerval (0 :: Int) 10)+      `shouldBe` parseInterval (10 :: Int) (11 :: Int)+    it "beginerval -2 10 should be Interval (10, 11)"+      $          Right (beginerval (-2 :: Int) 10)+      `shouldBe` parseInterval (10 :: Int) (11 :: Int)+    it "enderval 2 10 should be Interval (8, 10)"+      $          Right (enderval (2 :: Int) 10)+      `shouldBe` parseInterval (8 :: Int) (10 :: Int)+    it "enderval 0 10 should be Interval (9, 10)"+      $          Right (enderval (0 :: Int) 10)+      `shouldBe` parseInterval (9 :: Int) (10 :: Int)+    it "enderval -2 10 should be Interval (9, 10)"+      $          Right (enderval (-2 :: Int) 10)+      `shouldBe` parseInterval (9 :: Int) (10 :: Int)++    it "shiftFromBegin can convert Interval Int to Interval Int"+      $          shiftFromBegin (beginerval 2 (4 :: Int)) (beginerval 2 10)+      `shouldBe` beginerval 2 6 -- (6, 8)++    it "shiftFromEnd can convert Interval Int to Interval Int"+      $          shiftFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10)+      `shouldBe` beginerval 2 4 -- (4, 6)++    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+    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True"+      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1))+      `shouldBe` True+    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True"+      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0)+      `shouldBe` True+    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False"+      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1))+      `shouldBe` False+    it "disjoint x y same as explicit union of predicates"+      $          disjoint (mkIntrvl 2 0) (mkIntrvl 2 3)+      `shouldBe` (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0)+                                                        (mkIntrvl 2 3)+    it "within x y same as explicit union of predicates"+      $          within (mkIntrvl 2 3) (mkIntrvl 2 3)+      `shouldBe` (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3)+                                                             (mkIntrvl 2 3)+    it "prop_compose holds" $ property (prop_compose @Int)++  describe "(.+.) tests" $ do+    it "join non-meeting intervals is Nothing"+      $          beginerval 2 (0 :: Int)+      .+.        beginerval 6 5+      `shouldBe` Nothing+    it "join meeting intervals is Just _"+      $          beginerval 2 (0 :: Int)+      .+.        beginerval 6 2+      `shouldBe` Just (beginerval 8 0)++    it "gap of disjoint intervals should be something"+      $ property (prop_combinable_gap_exists @Int)+    it "gap of disjoint intervals should be something"+      $ property (prop_combinable_gap_exists @Day)+    it "gap of disjoint intervals should be something"+      $ property (prop_combinable_gap_exists @UTCTime)++    it "gap of nondisjoint, nonmeeting intervals should be nothing"+      $ property (prop_combinable_nogap_exists @Int)+    it "gap of nondisjoint, nonmeeting intervals should be nothing"+      $ property (prop_combinable_nogap_exists @Day)++  describe "Interval Algebra relation unit tests for synonyms" $ do+    it "(0, 2) precedes (10, 12)"+      $          beginerval 2 (0 :: Int)+      `precedes` beginerval 2 10+      `shouldBe` True+    it "precedes matches before"+      $          beginerval 10 (0 :: Int)+      `precedes` beginerval 1  11+      `shouldBe` beginerval 10 (0 :: Int)+      `before`   beginerval 1  11+    it "(10, 12) precededBy (0, 2)"+      $          precededBy (beginerval 2 10) (beginerval 2 (0 :: Int))+      `shouldBe` True+    it "precededBy matches after"+      $          precededBy (beginerval 1 11) (beginerval 10 (0 :: Int))+      `shouldBe` after (beginerval 1 11) (beginerval 10 (0 :: Int))+    it "concur matches notDdisjoint"+      $          concur (beginerval 1 11) (beginerval 10 (0 :: Int))+      `shouldBe` notDisjoint (beginerval 1 11) (beginerval 10 (0 :: Int))+    it "concur matches notDisjoint"+      $          concur (beginerval 1 0) (beginerval 10 (0 :: Int))+      `shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int))+

@@ -0,0 +1,849 @@+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++-- tag::import-declarations[]+import           IntervalAlgebra+import           IntervalAlgebra.IntervalDiagram++import           Data.Bifunctor                 ( Bifunctor(..) )+import           Data.List                      ( sort )+import           Data.Set                       ( Set+                                                , difference+                                                , fromList+                                                )+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++  -- Add file header -----------------------------------------------------------++  putStrLn+    "Generated by running `cabal run tutorial -v0 > tutorial/TutorialMain.out`"+  putStrLn "Do not edit by hand\n\n"+++  -- show Interval examples ----------------------------------------------------++  putStrLn "-- tag::interval-show-print[]"++  putStr "\n-- An example Interval Integer"+  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\n-- An example Interval Day"+  putStr "\nprint ivDay\n---> "+  print ivDay++  putStr "\n-- An example Interval UTCTime"+  putStr "\nprint ivUTC\n---> "+  print ivUTC++  putStrLn "-- end::interval-show-print[]"+++  -- Basic Interval instances examples ------------------------------------------++  putStrLn "-- tag::interval-basic-instances-print[]"++  putStr "\nprint $ ivInteger == ivInteger\n---> "+  print $ ivInteger == ivInteger++  putStr "\nprint $ ivDay < ivDay\n---> "+  print $ ivDay < ivDay++  putStr "\nprint $ show ivInteger\n---> "+  print $ show ivInteger++  putStrLn "-- end::interval-basic-instances-print[]"+++  -- parseInterval examples ----------------------------------------------------++  putStrLn "-- tag::parseinterval-print[]"++  putStr "\nprint rightIvInteger\n---> "+  print rightIvInteger++  putStr "\nprint leftIvInteger\n---> "+  print leftIvInteger++  putStr "\nprint rightIvDay\n---> "+  print rightIvDay++  putStr "\nprint rightIvUTC\n---> "+  print rightIvUTC++  putStrLn "-- end::parseinterval-print[]"+++  -- safeInterval examples -----------------------------------------------------++  putStrLn "-- tag::safeinterval-print[]"++  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\nprint ivMinDurInteger\n---> "+  print ivMinDurInteger++  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\nprint ivDay\n---> "+  print ivDay++  putStr "\nprint ivUTC\n---> "+  print ivUTC++  putStrLn "-- end::safeinterval-print[]"+++  -- beginerval and enderval examples -------------------------------------------------------++  putStrLn "-- tag::beginerval-enderval-print[]"++  putStr "\nprint (beginerval 2 3 :: Interval Integer)\n---> "+  print (beginerval 2 3 :: Interval Integer)++  putStr "\nprint (beginerval (-2) 3 :: Interval Integer)\n---> "+  print (beginerval (-2) 3 :: Interval Integer)++  putStr "\nprint (enderval 2 12 :: Interval Integer)\n---> "+  print (enderval 2 12 :: Interval Integer)++  putStr "\nprint (enderval (-2) 12 :: Interval Integer)\n---> "+  print (enderval (-2) 12 :: Interval Integer)++  putStrLn "-- end::beginerval-enderval-print[]"+++  -- Creating moments examples --------------------------------------------------++  putStrLn "-- tag::creating-moments-print[]"++  putStr "\nprint (beginervalMoment 11 :: Interval Integer)\n---> "+  print (beginervalMoment 11 :: Interval Integer)++  putStr "\nprint (endervalMoment 11 :: Interval Integer)\n---> "+  print (endervalMoment 11 :: Interval Integer)++  putStrLn "-- end::creating-moments-print[]"+++  -- Creating PairedIntervals examples --------------------------------------++  putStrLn "-- tag::creating-pairedinterval-print[]"++  putStr "\nprint pairListstringInteger\n---> "+  print pairListstringInteger++  putStr "\nprint pairStringDay\n---> "+  print pairStringDay++  putStrLn "-- end::creating-pairedinterval-print[]"+++  -- Basic PairedInterval instances examples ------------------------------------++  putStrLn "-- tag::pairedinterval-basic-instances-print[]"++  putStr "\nprint $ pairStringDay == pairStringDay\n---> "+  print $ pairStringDay == pairStringDay++  putStr "\nprint $ pairListstringInteger < pairListstringInteger\n---> "+  print $ pairListstringInteger < pairListstringInteger++  putStr "\nprint $ show pairStringDay\n---> "+  print $ show pairStringDay++  putStrLn "-- end::pairedinterval-basic-instances-print[]"+++  -- Getting/setting PairedInterval intervals example --------------------------++  putStrLn "-- tag::pairedinterval-getset-intervals-print[]"++  putStr "\nprint pairListstringInteger\n---> "+  print pairListstringInteger++  putStr "\nprint $ getInterval pairListstringInteger\n---> "+  print $ getInterval pairListstringInteger++  putStr+    "\nprint $ setInterval pairListstringInteger (interval 4 9 :: Interval Integer)\n---> "+  print $ setInterval pairListstringInteger+                      (interval 4 9 :: Interval Integer)++  putStr+    "\nprint $ intervals [pairListstringInteger, pairListstringInteger]\n---> "+  print $ intervals [pairListstringInteger, pairListstringInteger]++  putStr "\nprint $ begin pairListstringInteger\n---> "+  print $ begin pairListstringInteger++  putStr "\nprint $ end pairListstringInteger\n---> "+  print $ end pairListstringInteger++  putStrLn "-- end::pairedinterval-getset-intervals-print[]"+++  -- Example getting/setting PairedInterval data -------------------------------++  putStrLn "-- tag::pairedinterval-getset-data-print[]"++  putStr "\nprint pairStringDay\n---> "+  print pairStringDay++  putStr "\nprint $ getPairData pairStringDay\n---> "+  print $ getPairData pairStringDay++  putStr+    "\nprint $ makePairedInterval \"ski trip\" (getInterval pairStringDay)\n---> "+  print $ makePairedInterval "ski trip" (getInterval pairStringDay)++  putStrLn "-- end::pairedinterval-getset-data-print[]"+++  -- Intervallic interval instance examples ------------------------------------------------------++  putStrLn "-- tag::intervallic-interval-instance-print[]"++  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\nprint $ getInterval ivInteger\n---> "+  print $ getInterval ivInteger++  putStr+    "\nprint $ setInterval ivInteger (beginerval 3 12 :: Interval Integer)\n---> "+  print $ setInterval ivInteger (beginerval 3 12 :: Interval Integer)++  putStr "\nprint $ begin ivInteger\n---> "+  print $ begin ivInteger++  putStr "\nprint $ end ivInteger\n---> "+  print $ end ivInteger++  putStrLn "-- end::intervallic-interval-instance-print[]"+++  -- SizedIv instance examples ------------------------------------------------------++  putStrLn "-- tag::intervalsizeable-instance-print[]"++  putStr "\nprint ivDay\n---> "+  print ivDay++  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 $ ivExpandr 15 ivDay\n---> "+  print $ ivExpandr 15 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[]"+++  -- "Combining" utility examples -------------------------------------++  putStrLn "-- tag::intervalcombinable-interval-print[]"++  putStrLn+    "\n-- The Just Interval formed from combining the Intervals, since iv0to2 `meets` iv2to5"+  putStr "print $ iv0to2 .+. iv2to5\n---> "+  print $ iv0to2 .+. iv2to5++  putStrLn "\n-- A Nothing since iv0to2 doesn't `meets` iv5to8"+  putStr "print $ iv0to2 .+. iv5to8\n---> "+  print $ iv0to2 .+. iv5to8++  putStrLn+    "\n-- The Just Interval formed from the end of the first and the beginning of the\n-- second, since iv0to2 is `before` iv5to8"+  putStr "print $ iv0to2 >< iv5to8\n---> "+  print $ iv0to2 >< iv5to8++  putStrLn "\n-- A Nothing since iv0to2 isn't `before` iv2to5"+  putStr "print $ iv0to2 >< iv2to5\n---> "+  print $ iv0to2 >< iv2to5++  putStrLn "-- end::intervalcombinable-interval-print[]"+++  -- "Combining" utilities for PairedInterval examples -------------------------------++  putStrLn "-- tag::intervalcombinable-pairedinterval-print[]"++  putStrLn+    "\n-- The Just Interval formed from combining the Intervals and taking the data\n-- portion from the second argument, since iv0to2 `meets` iv2to5"+  putStr+    "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv2to5\n---> "+  print $ makePairedInterval "a" iv0to2 .+. makePairedInterval "b" iv2to5++  putStrLn "\n-- A Nothing since iv0to2 doesn't `meets` iv5to8"+  putStr+    "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv5to8\n---> "+  print $ makePairedInterval "a" iv0to2 .+. makePairedInterval "b" iv5to8++  putStrLn+    "\n-- The Just Interval formed from spanning the Intervals and taking the data\n-- portion from the `mempty` method of the Monoid String instance, since\n-- iv0to2 is `before` iv5to8"+  putStr+    "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv5to8\n---> "+  print $ makePairedInterval "a" iv0to2 >< makePairedInterval "b" iv5to8++  putStrLn "\n-- A Nothing since iv0to2 isn't `before` iv2to5"+  putStr+    "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv2to5\n---> "+  print $ makePairedInterval "a" iv0to2 >< makePairedInterval "b" iv2to5++  putStrLn "-- end::intervalcombinable-pairedinterval-print[]"+++  -- Expanding intervals examples -----------------------------------------------++  putStrLn "-- tag::expanding-intervals-print[]"++  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\nprint $ expandl 4 ivInteger\n---> "+  print $ expandl 4 ivInteger++  putStr "\nprint $ expandl 0 ivInteger\n---> "+  print $ expandl 0 ivInteger++  putStr "\nprint $ expandr 5 ivInteger\n---> "+  print $ expandr 5 ivInteger++  putStr "\nprint $ expandr (-3) ivInteger\n---> "+  print $ expandr (-3) ivInteger++  putStr "\nprint $ expand 4 5 ivInteger\n---> "+  print $ expand 4 5 ivInteger++  putStr "\nprint $ expand 0 (-3) ivInteger\n---> "+  print $ expand 0 (-3) ivInteger++  putStrLn "-- end::expanding-intervals-print[]"+++  -- Sharing an endpoint interval examples -----------------------------------------------++  putStrLn "-- tag::sharing-endpoint-interval-print[]"++  putStr "\nprint ivInteger\n---> "+  print ivInteger++  putStr "\nbeginervalFromEnd 5 ivInteger\n---> "+  print $ beginervalFromEnd 5 ivInteger++  putStr "\nbeginervalFromEnd (-2) ivInteger\n---> "+  print $ beginervalFromEnd (-2) ivInteger++  putStr "\nendervalFromBegin 12 ivInteger\n---> "+  print $ endervalFromBegin 12 ivInteger++  putStr "\nendervalFromBegin (-6) ivInteger\n---> "+  print $ endervalFromBegin (-6) ivInteger++  putStr "\nprint $ momentize ivInteger\n---> "+  print $ momentize ivInteger++  putStrLn "-- end::sharing-endpoint-interval-print[]"+++  -- Example shifting intervals -----------------------------------------------++  putStrLn "-- tag::shifting-intervals-print[]"++  putStr "\nprint [iv2to4, iv5to8]\n---> "+  print [iv2to4, iv5to8]++  putStr "\nprint $ shiftFromBegin iv2to4 iv5to8\n---> "+  print $ shiftFromBegin iv2to4 iv5to8++  putStr "\nprint $ shiftFromEnd iv2to4 iv5to8\n---> "+  print $ shiftFromEnd iv2to4 iv5to8++  putStrLn "-- end::shifting-intervals-print[]"+++  -- Relations variables diagram example --------------------------------------------++  putStrLn "-- tag::relations-variables-diagram-print[]"++  print $ pretty diagr++  putStrLn "-- end::relations-variables-diagram-print[]"+++  -- Composing relations examples -------------------------------------------++  putStrLn "-- tag::composing-relations-print[]"++  putStr "\nprint endedPriorRelations\n---> "+  print endedPriorRelations++  putStr "\nprint notEndedPriorRelations\n---> "+  print notEndedPriorRelations++  putStr "\nprint notEndedPriorRelations'\n---> "+  print notEndedPriorRelations'++  putStr "\nprint intervalRelations'\n---> "+  print intervalRelations'++  putStr "\nprint empty\n---> "+  print empty++  putStrLn "-- end::composing-relations-print[]"+++  -- Composing predicates v1 examples ---------------------------------------++  putStrLn "-- tag::composing-predicates-1-print[]"++  putStr "\nprint $ iv0to2 `precedes` iv3to6"+  putStr "\nprint $ iv0to2 `meets` iv3to6"+  putStr "\nprint $ iv0to2 `endedPrior` iv3to6\n---> "+  print $ iv0to2 `precedes` iv3to6+  putStr "---> "+  print $ iv0to2 `meets` iv3to6+  putStr "---> "+  print $ iv0to2 `endedPrior` iv3to6++  putStrLn "-- end::composing-predicates-1-print[]"+++  -- Composing predicates v2 examples ---------------------------------------++  putStrLn "-- tag::composing-predicates-2-print[]"++  putStr "\nprint $ iv0to2 `precedes` iv2to4"+  putStr "\nprint $ iv0to2 `meets` iv2to4"+  putStr "\nprint $ iv0to2 `endedPrior` iv2to4\n---> "+  print $ iv0to2 `precedes` iv2to4+  putStr "---> "+  print $ iv0to2 `meets` iv2to4+  putStr "---> "+  print $ iv0to2 `endedPrior` iv2to4++  putStrLn "-- end::composing-predicates-2-print[]"+++  -- Composing predicates v3 examples ---------------------------------------++  putStrLn "-- tag::composing-predicates-3-print[]"++  putStr "\nprint $ iv5to8 `precedes` iv2to4"+  putStr "\nprint $ iv5to8 `meets` iv2to4"+  putStr "\nprint $ iv5to8 `endedPrior` iv2to4\n---> "+  print $ iv5to8 `precedes` iv2to4+  putStr "---> "+  print $ iv5to8 `meets` iv2to4+  putStr "---> "+  print $ iv5to8 `endedPrior` iv2to4++  putStrLn "-- end::composing-predicates-3-print[]"+++  -- Extended example 1 examples --------------------------------------------------------++  putStrLn "-- tag::extended-example-1-print[]"++  putStr "\nprint $ head results\n---> "+  print $ head results++  putStr "\nprint $ results !! 1\n---> "+  print $ results !! 1++  putStr "\nprint $ results !! 2\n---> "+  print $ results !! 2++  putStr "\nprint $ results !! 3\n---> "+  print $ results !! 3++  putStrLn "-- end::extended-example-1-print[]"+++-- tag::parseinterval-examples[]+rightIvInteger :: Either ParseErrorInterval (Interval Integer)+rightIvInteger = parseInterval 0 2++leftIvInteger :: Either ParseErrorInterval (Interval Integer)+leftIvInteger = parseInterval 2 2++rightIvDay :: Either ParseErrorInterval (Interval Day)+rightIvDay =+  parseInterval (fromGregorian 1967 01 18) (fromGregorian 1967 01 22)++rightIvUTC :: Either ParseErrorInterval (Interval UTCTime)+rightIvUTC = parseInterval+  (UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 32400))+  (UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 33200))+-- end::parseinterval-examples[]+++-- tag::interval-examples[]+ivInteger :: Interval Integer+ivInteger = interval 2 6++ivMinDurInteger :: Interval Integer+ivMinDurInteger = interval 2 2++ivDay :: Interval Day+ivDay = interval (fromGregorian 1967 01 18) (fromGregorian 1967 01 24)++ivUTC :: Interval UTCTime+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 = 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[]+++-- tag::creating-pairedinterval-examples[] --------------------++pairListstringInteger :: PairedInterval [String] Integer+pairListstringInteger =+  makePairedInterval ["John", "Paul", "George", "Ringo"] ivInteger++pairStringDay :: PairedInterval String Day+pairStringDay = makePairedInterval "vacation" ivDay++-- end::creating-pairedinterval-examples[]+++-- tag::composing-relations-examples[]++-- Set, `fromList`, and in a later example `difference` are imported from+-- Data.Set+endedPriorRelations :: Set IntervalRelation+endedPriorRelations = fromList [Before, Meets]++-- We can in general create a new Set by taking the set Difference of one Set+-- and another Set+notEndedPriorRelations :: Set IntervalRelation+notEndedPriorRelations = intervalRelations `difference` endedPriorRelations++-- However, the `complement` function is provided for the common case of taking+-- the Set Difference of the `intervalRelations` Set and another Set+notEndedPriorRelations' :: Set IntervalRelation+notEndedPriorRelations' = complement endedPriorRelations++-- IntervalAlgebra exports versions of `Data.Set`s `intersection` and `union`+-- functions where the types are specialized to `Set IntervalRelation`s+intervalRelations' :: Set IntervalRelation+intervalRelations' = endedPriorRelations `union` notEndedPriorRelations++-- The intersection of two disjoint sets+empty :: Set IntervalRelation+empty = endedPriorRelations `intersection` notEndedPriorRelations++-- end::composing-relations-examples[]+++-- tag::composing-predicates-examples[] -----------------------++-- We can construct a predicate function from a 'Set IntervalRelation'+endedPrior+  :: (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'+  :: (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1)+  => ComparativePredicateOf2 (i0 a) (i1 a)+endedPrior' = unionPredicates [before, meets]++-- As an alternative to `unionPredicates` we can compose predicate functions+-- using the <|> operator. If we had multiple predicates we could use e.g.:+--     p1 <|> p2 <|> p3+endedPrior''+  :: (SizedIv (Interval a), Ord a, Intervallic i0, Intervallic i1)+  => ComparativePredicateOf2 (i0 a) (i1 a)+endedPrior'' = before <|> meets++-- end::composing-predicates-examples[]+++-- tag::extended-example-1-types[] --------------------++data DataType = Enrollment | Treatment TreatmentType | Diagnosis DiagnosisType+  deriving (Eq, Ord, Show)++data TreatmentType = StandardVaccine | NewVaccine+  deriving (Eq, Ord, Show)++data DiagnosisType = RightAsRain | UpsetTummy | CommonCold | Flu+  deriving (Eq, Ord, Show)++type StudyEvent = PairedInterval DataType Integer++type SubjEvents = [StudyEvent]++data ProcessedSubj = ProcessedSubj+  { getEnrollment   :: Maybe (Interval Integer)+  , getFirstTrt     :: Maybe StudyEvent+  , getFirstFlu     :: Maybe StudyEvent+  , getTrtType      :: Maybe TreatmentType+  , getTimeToFlu    :: Maybe Integer+  , getTimeToEndEnr :: Maybe Integer+  }+  deriving Show++maxEnrGap :: Integer+maxEnrGap = 8++-- end::extended-example-1-types[]+++-- tag::extended-example-1-study-data-subj-1[] ----------------++id1Event1, id1Event2, id1Event3, id1Event4, id1Event5, id1Event6, id1Event7+  :: StudyEvent+id1Event1 = makePairedInterval Enrollment (safeInterval (6, 191))+id1Event2 = makePairedInterval Enrollment (safeInterval (199, 345))+id1Event3 = makePairedInterval Enrollment (safeInterval (347, 422))+id1Event4 = makePairedInterval (Diagnosis RightAsRain) (safeInterval (12, 13))+id1Event5 = makePairedInterval (Treatment NewVaccine) (safeInterval (22, 23))+id1Event6 =+  makePairedInterval (Diagnosis RightAsRain) (safeInterval (131, 132))+id1Event7 = makePairedInterval (Diagnosis CommonCold) (safeInterval (161, 162))++id1Events :: SubjEvents+id1Events = sort+  [id1Event1, id1Event2, id1Event3, id1Event4, id1Event5, id1Event6, id1Event7]++-- end::extended-example-1-study-data-subj-1[]+++-- tag::extended-example-1-study-data-subj-2[] ----------------++id2Event1, id2Event2, id2Event3, id2Event4, id2Event5, id2Event6, id2Event7, id2Event8+  :: StudyEvent+id2Event1 = makePairedInterval Enrollment (safeInterval (2, 206))+id2Event2 = makePairedInterval Enrollment (safeInterval (222, 299))+id2Event3 = makePairedInterval Enrollment (safeInterval (304, 486))+id2Event4 = makePairedInterval (Diagnosis RightAsRain) (safeInterval (4, 5))+id2Event5 =+  makePairedInterval (Treatment StandardVaccine) (safeInterval (98, 99))+id2Event6 = makePairedInterval (Diagnosis CommonCold) (safeInterval (161, 162))+id2Event7 = makePairedInterval (Diagnosis UpsetTummy) (safeInterval (191, 192))+id2Event8 = makePairedInterval (Diagnosis Flu) (safeInterval (255, 256))++id2Events :: SubjEvents+id2Events = sort+  [ id2Event1+  , id2Event2+  , id2Event3+  , id2Event4+  , id2Event5+  , id2Event6+  , id2Event7+  , id2Event8+  ]++-- end::extended-example-1-study-data-subj-2[]+++-- tag::extended-example-1-study-data-subj-3[] ----------------++id3Event1, id3Event2, id3Event3 :: StudyEvent+id3Event1 = makePairedInterval Enrollment (safeInterval (7, 197))+id3Event2 =+  makePairedInterval (Treatment StandardVaccine) (safeInterval (19, 20))+id3Event3 = makePairedInterval (Diagnosis Flu) (safeInterval (180, 181))++id3Events :: SubjEvents+id3Events = sort [id3Event1, id3Event2, id3Event3]++-- end::extended-example-1-study-data-subj-3[]+++-- tag::extended-example-1-study-data-subj-4[] ----------------++id4Event1, id4Event2 :: StudyEvent+id4Event1 = makePairedInterval Enrollment (safeInterval (3, 89))+id4Event2 = makePairedInterval (Diagnosis RightAsRain) (safeInterval (47, 48))++id4Events :: SubjEvents+id4Events = sort [id4Event1, id4Event2]++-- end::extended-example-1-study-data-subj-4[]+++-- tag::extended-example-1-processing-functions[] -------------++-- Construct the elements of a `ProcessedSubj` one step at-a-time. Most of the+-- actual work is done by the helper functions defined below+processSubj :: SubjEvents -> ProcessedSubj+processSubj xs =+  let enrPeriod    = calcEnrPeriod xs                   -- enrollment period+      enrEvents    = calcEnrEvents enrPeriod xs         -- events within enrollment+      firstTrt     = findFirstTrt enrPeriod xs          -- first treatment in enr+      firstTrtType = extractTrtType firstTrt            -- first trt type+      firstTrtIv   = fmap getInterval firstTrt          -- first trt interval+      firstFlu     = findFirstFlu firstTrtIv enrEvents  -- first flu in enr+      ttFlu        = calcDiff firstFlu firstTrt         -- time to first flu+      ttEndEnr     = calcAtRisk enrPeriod firstTrt      -- time to end of enr+  in  ProcessedSubj enrPeriod firstTrt firstFlu firstTrtType ttFlu ttEndEnr++-- Construct the "enrollment period", which is defined at the period of time+-- with the start endpoint given by their earliest enrollment period and end+-- endpoint given by the first time that they fall out of the grace period. In+-- the event that a subject did not have any enrollment periods then the return+-- value is a Nothing.+--+-- Note that this function uses the `combineIntervals` function which was not+-- covered in this tutorial, but is exported from IntervalAlgebra via+-- IntervalAlgebra.IntervalUtilities.+calcEnrPeriod :: SubjEvents -> Maybe (Interval Integer)+calcEnrPeriod xs | null combinedPeriods = Nothing+                 | otherwise            = Just (head combinedPeriods)+  where combinedPeriods = (combineIntervals . addMaxEnrGap . extractEnrIvs) xs++-- Filter the enrollment events in the SubjEvents and extract the Interval+-- from each one+extractEnrIvs :: SubjEvents -> [Interval Integer]+extractEnrIvs = intervals . filter (checkEnr . getPairData)+ where+  checkEnr Enrollment = True+  checkEnr _          = False++-- Extend the end endpoint for each Interval by `maxEnrGap`+addMaxEnrGap :: [Interval Integer] -> [Interval Integer]+addMaxEnrGap = map (expandr maxEnrGap)++-- Filter the SubjEvents to those with endpoints that do not extend past the+-- enrollment period's endpoints+calcEnrEvents :: Maybe (Interval Integer) -> SubjEvents -> SubjEvents+calcEnrEvents mayIv xs = case mayIv of+  Nothing -> []+  Just y  -> filter (\x -> getInterval x `enclosedBy` y) xs++-- Find the first flu vaccine administrations occuring within the enrollment+-- period+findFirstTrt :: Maybe (Interval Integer) -> SubjEvents -> Maybe StudyEvent+findFirstTrt Nothing _ = Nothing+findFirstTrt (Just iv) xs | null filteredIntakes = Nothing+                          | otherwise            = Just (head filteredIntakes)+ where+  p x = checkTrt (getPairData x) && (getInterval x `enclosedBy` iv)+  checkTrt (Treatment _) = True+  checkTrt _             = False+  filteredIntakes = filter p xs++-- Extract the treatment type out of a StudyEvent. If there is no event or the+-- StudyEvent type isn't TreatmentType then return Nothing+extractTrtType :: Maybe StudyEvent -> Maybe TreatmentType+extractTrtType Nothing  = Nothing+extractTrtType (Just x) = case getPairData x of+  Treatment StandardVaccine -> Just StandardVaccine+  Treatment NewVaccine      -> Just NewVaccine+  _                         -> Nothing++-- Find the first flu diagnosis occuring within the enrollment period+findFirstFlu :: Maybe (Interval Integer) -> SubjEvents -> Maybe StudyEvent+findFirstFlu Nothing _ = Nothing+findFirstFlu (Just iv) xs | null filteredFlus = Nothing+                          | otherwise         = Just (head filteredFlus)+ where+  endedPrior = before <|> meets+  p x = checkDiagFlu (getPairData x) && (iv `endedPrior` getInterval x)+  checkDiagFlu (Diagnosis Flu) = True+  checkDiagFlu _               = False+  filteredFlus = filter p xs++-- Calculate the difference between the start endpoint of the first Intervallic+-- and the start endpoint of the second Intervallic+calcDiff+  :: (SizedIv (Interval a), Num a, Intervallic i0, Intervallic i1)+  => Maybe (i0 a)+  -> Maybe (i1 a)+  -> 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+  :: (SizedIv (Interval a), Num a, Intervallic i0, Intervallic i1)+  => Maybe (i0 a)+  -> Maybe (i1 a)+  -> Maybe a+calcAtRisk (Just y) (Just x) = Just $ (-) (end y) (end x)+calcAtRisk _        _        = Nothing++-- end::extended-example-1-processing-functions[]+++-- tag::extended-example-1-calculate-results[] ----------------++results :: [ProcessedSubj]+results = map processSubj [id1Events, id2Events, id3Events, id4Events]++-- end::extended-example-1-calculate-results[]+++--------------------------------------------------------------------------------+-- The remaining is untagged data+--------------------------------------------------------------------------------++diagr :: Either IntervalDiagramParseError (IntervalDiagram Integer)+diagr = standardExampleDiagram (zip ivs labels) []+ where+  ivs = [iv0to2, iv2to4, iv2to5, iv3to6, iv4to5, iv6to8, iv5to8]+  labels =+    ["iv0to2", "iv2to4", "iv2to5", "iv3to6", "iv4to5", "iv6to8", "iv5to8"]