diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright NoviSci, Inc (c) 2020 +Copyright NoviSci, Inc (c) 2020-2022 +Copyright Target RWE (c) 2023 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,72 @@ # interval-algebra -The `interval-algebra` package implements [Allen's interval algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html) in [Haskell](https://www.haskell.org). The main module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). +The `interval-algebra` package implements [Allen's interval +algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra) in +[Haskell](https://www.haskell.org), for a canonical representation of intervals +as a pair of points representing a begin and an end. The main module provides +data types and related classes for the interval-based temporal logic described +in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen +and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). A good +primer on Allen's algebra can be [found +here](https://thomasalspaugh.org/pub/fnd/allen.html). ## Design +The module provides an `Interval` type wrapping the most basic type of interval +needed for the relation algebra defined in the papers cited above. `Interval a` +wraps `(a, a)`, giving the interval's `begin` and `end` points. -The module is built around three typeclasses designed to separate concerns of constructing, relating, and combining types that contain `Interval`s: +However, the module provides typeclasses to generalize an `Interval` and the +interval algebra for temporal logic: -1. `Intervallic` provides an interface to the data structures which contain an `Interval`. -2. `IntervalCombinable` provides an interface to methods of combining two `Interval`s. -3. `IntervalSizeable` provides methods for measuring and modifying the size of an interval. +1. `Iv` provides an abstract interface for defining the 13 relations of the + interval algebra. Instances are provided for the canonical `Interval a`, + when `a` is an instance of `Ord`, as described in Allen 1983. However, + the interval algebra can be used for temporal logic on "intervals" that + are qualitative and not represented as pairs of points in an ordered set, + as provided in examples of that paper. +2. `PointedIv` is an interface for types that, in effect, be cast to the + canonical `Interval`. +3. `SizedIv` provides a generic interface for creating and + manipulating `PointedIv` intervals. In particular, when the interval type also + is an instance of `Iv`, it specifies class properties to ensure + intervals created or altered via its methods are valid for the purpose using the interval + algebra. +1. `Intervallic` provides an interface for data structures which contain an + `Interval`, allowing the relation algebra to be performed relative to the + `Interval` within. The `PairedInterval` defined here is the prototypical + case. -An advantage of nested typeclass design is that developers can define an `Interval` of type `a` with just the amount of structure that they need. +The module defines instances of the classes above for `Interval a`, and only +provides `SizedIv (Interval a)` instances for a few common `a`. See class +documentation for examples of other possible use-cases. It also defines a +variety of ways to construct valid `Interval a` values for supported point +types `a`. +The loose naming convention is: "Bare" names such as `starts` or `contains` are +generalized over `Intervallic` and their `Iv*` class counterparts start with +`iv`, for example `ivStarts` and `ivContains`. + ## Axiom tests -The package [includes tests](test/IntervalAlgebraSpec.hs) that the functions of the `IntervalAlgebraic` typeclass meets the axioms for _intervals_ (not points) as laid out in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). +The package [includes tests](test/IntervalAlgebraSpec.hs) that the functions of +the `IntervalAlgebraic` typeclass meets the axioms for _intervals_ (not points) +as laid out in [Allen and Hayes +(1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). + +## Comparisons + +`interval-algebra` differs from `data-interval` mainly in that it is more +general and has as its starting point the relation algebra from Allen 1983. The +latter package provides an interval type that is tied to the notion of an +interval as a connected convex subset of the integer or real lines, +differentiating for example between closed and open endpoints. It provides +a `Relation` type codifying the 13 temporal relations from Allen 1983. + +For use-cases where that structure is meaningful, `data-interval` might be a +more natural choice. `interval-algebra` might be used instead when more +abstract concepts are needed or there is no need for the notion of +connectedness between the starting and ending points. + +An important difference is that `data-interval` supports empty +intervals. `interval-algebra` does not, since Allen's interval relations cannot +be defined for such intervals. diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,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 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: 2020-2022, 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 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -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 . -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 diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -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) diff --git a/src/IntervalAlgebra/Axioms.hs b/src/IntervalAlgebra/Axioms.hs new file mode 100644 --- /dev/null +++ b/src/IntervalAlgebra/Axioms.hs @@ -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 diff --git a/src/IntervalAlgebra/Core.hs b/src/IntervalAlgebra/Core.hs new file mode 100644 --- /dev/null +++ b/src/IntervalAlgebra/Core.hs @@ -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 +-- . +compose :: + IntervalRelation -> IntervalRelation -> Data.Set.Set IntervalRelation +compose x y = toSet (composeRelationLookup !! fromEnum x !! fromEnum y) + +-- | Finds the complement of a @'Data.Set.Set' 'IntervalRelation'@. +complement :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation +complement = Data.Set.difference intervalRelations + +-- | Find the intersection of two 'Data.Set.Set's of 'IntervalRelation's. +intersection :: + Data.Set.Set IntervalRelation -> + Data.Set.Set IntervalRelation -> + Data.Set.Set IntervalRelation +intersection = Data.Set.intersection + +-- | Find the union of two 'Data.Set.Set's of 'IntervalRelation's. +union :: + Data.Set.Set IntervalRelation -> + Data.Set.Set IntervalRelation -> + Data.Set.Set IntervalRelation +union = Data.Set.union + +-- | Find the converse of a @'Data.Set.Set' 'IntervalRelation'@. +converse :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation +converse = Data.Set.map converseRelation + +{- Generic interval interfaces -} + +-- | Generic interface for defining relations between abstract representations +-- of intervals, for the purpose of [Allen's interval algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra). +-- +-- In general, these "intervals" need not be representable as temporal intervals with a fixed +-- beginning and ending. Specifically, the relations can be defined to provide temporal reasoning +-- in a qualitative setting, examples of which are in Allen 1983. +-- +-- For intervals that can be cast in canonical form as 'Interval' s with begin and end points, +-- see 'PointedIv' and 'SizedIv'. +-- +-- Instances of 'Iv' must ensure any pair of intervals satisfies exactly one +-- of the thirteen possible 'IntervalRelation' s. +-- +-- When 'iv' is also an instance of 'PointedIv', with @Ord (Point iv)@, +-- the requirement implies +-- +-- @ +-- ivBegin i < ivEnd i +-- @ +-- +-- [Allen 1983](https://dl.acm.org/doi/10.1145/182.358434) +-- defines the 'IntervalRelation' s for such cases, which is provided in this module +-- for the canonical representation @'Interval' a@. +-- +-- ==== __Examples__ +-- +-- The following example is modified from Allen 1983 to demonstrate the algebra used for temporal +-- reasoning in a qualitative setting, for a case where 'iv' does not have points. +-- +-- It represents the temporal logic of the statement +-- +-- > We found the letter during dinner, after we made the decision. +-- +-- >>> :{ +--data GoingsOn = Dinner | FoundLetter | MadeDecision +-- deriving (Show, Eq) +--instance Iv GoingsOn where +-- ivRelate MadeDecision Dinner = Before +-- ivRelate MadeDecision FoundLetter = Before +-- ivRelate FoundLetter Dinner = During +-- ivRelate x y +-- | x == y = Equals +-- | otherwise = converseRelation (ivRelate y x) +-- :} +class Iv iv where + {-# MINIMAL ivRelate | ivBefore, ivMeets, ivOverlaps, ivStarts, ivFinishes, ivDuring, ivEquals #-} + + -- | The 'IntervalRelation' between two intervals. + ivRelate :: iv -> iv -> IntervalRelation + ivRelate x y + | x `ivBefore` y = Before + | x `ivAfter` y = After + | x `ivMeets` y = Meets + | x `ivMetBy` y = MetBy + | x `ivOverlaps` y = Overlaps + | x `ivOverlappedBy` y = OverlappedBy + | x `ivStarts` y = Starts + | x `ivStartedBy` y = StartedBy + | x `ivFinishes` y = Finishes + | x `ivFinishedBy` y = FinishedBy + | x `ivDuring` y = During + | x `ivContains` y = Contains + | otherwise = Equals + + -- \| Is @'ivRelate' x y == Before@? @'ivAfter' = flip 'ivBefore'@. + ivBefore, + ivAfter :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivBefore x = (== Before) . ivRelate x + ivAfter = flip ivBefore + + -- | Is @'ivRelate' x y == Meets@? @'ivMetBy' = flip 'ivMeets'@. + ivMeets, + ivMetBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivMeets x = (== Meets) . ivRelate x + ivMetBy = flip ivMeets + + -- | Is @'ivRelate' x y == Overlaps@? @'ivOverlappedBy' = flip 'ivOverlaps'@. + ivOverlaps, + ivOverlappedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivOverlaps x = (== Overlaps) . ivRelate x + ivOverlappedBy = flip ivOverlaps + + -- | Is @'ivRelate' x y == Starts@? @'ivStartedBy' = flip 'ivStarts'@. + ivStarts, + ivStartedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivStarts x = (== Starts) . ivRelate x + ivStartedBy = flip ivStarts + + -- | Is @'ivRelate' x y == Finishes@? @'ivFinishedBy' = flip 'ivFinishes'@. + ivFinishes, + ivFinishedBy :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivFinishes x = (== Finishes) . ivRelate x + ivFinishedBy = flip ivFinishes + + -- | Is @'ivRelate' x y == During@? @'ivContains' = flip 'ivDuring'@. + ivDuring, + ivContains :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivDuring x = (== During) . ivRelate x + ivContains = flip ivDuring + + -- | Is @'ivRelate' x y == Equals@? + ivEquals :: + -- | 'x' + iv -> + -- | 'y' + iv -> + Bool + ivEquals x = (== Equals) . ivRelate x + +-- | Class representing intervals that can be cast to and from the canonical +-- representation @'Interval' a@. +-- +-- When 'iv' is also an instance of 'PointedIv', with @Ord (Point iv)@, it should +-- adhere to Allen's construction of the interval algebra for intervals represented +-- by left and right endpoints. See [sections 3 and 4](https://cse.unl.edu/~choueiry/Documents/Allen-CACM1983.pdf) +-- of Allen 1983. +-- +-- Specifically, the requirements for interval relations imply +-- +-- @ +-- ivBegin i < ivEnd i +-- @ +-- +-- This module provides default implementations for methods of 'Iv' in that case. +-- +-- Note @iv@ should not be an instance of @Intervallic@ unless @iv ~ Interval +-- a@, since @Intervallic@ is a class for getting and setting intervals as +-- @Interval a@ in particular. +-- +-- A @Vector@ whose elements are provided in strict ascending order is an example of +-- a type that could implement 'PointedIv' without being equivalent to 'Interval', +-- with @ivBegin = head@ and @ivEnd = last@. +class PointedIv iv where + type Point iv + + -- | Access the left ("begin") and right ("end") endpoints of an interval. + ivBegin, ivEnd :: iv -> Point iv + +-- | The 'SizedIv' typeclass is a generic interface for constructing and +-- manipulating intervals. The class imposes strong requirements on its +-- methods, in large part to ensure the constructors 'ivExpandr' and 'ivExpandl' +-- return "valid" intervals, particularly in the typical case where 'iv' also +-- implements the interval algebra. +-- +-- In all cases, 'ivExpandr' and 'ivExpandl' should preserve the value of the +-- point *not* shifted. That is, +-- +-- @ +-- ivBegin (ivExpandr d i) == ivBegin i +-- ivEnd (ivExpandl d i) == ivEnd i +-- @ +-- +-- In addition, using 'Interval' as example, the following must hold: +-- +-- When @iv@ is @Ord@, for all @i == Interval (b, e)@, +-- +-- @ +-- ivExpandr d i >= i +-- ivExpandl d i <= i +-- @ +-- +-- When @Moment iv@ is @Ord@, +-- +-- @ +-- duration (ivExpandr d i) >= max moment (duration i) +-- duration (ivExpandl d i) >= max moment (duration i) +-- @ +-- +-- In particular, if the duration 'd' by which to expand is less than 'moment', +-- and @'duration' i >= moment@ then these constructors should return the input. +-- +-- @ +-- ivExpandr d i == i +-- ivExpandl d i == i +-- @ +-- +-- When @Moment iv@ also is @Num@, the default 'moment' value is @1@ and in all +-- cases should be positive. +-- +-- @ +-- moment @iv > 0 +-- @ +-- +-- When in addition @Point iv ~ Moment iv@, the class provides a default 'duration' as +-- @duration i = ivEnd i - ivBegin i@. +-- +-- This module enforces @'Point' (Interval a) = a@. However, it need not be +-- that @a ~ Moment iv@. For example @Moment (Interval UTCTime) ~ +-- NominalDiffTime@. +-- +-- ==== SizedIv and the interval algebra +-- +-- When 'iv' is an instance of 'Iv', the methods of this class should ensure +-- the validity of the resulting interval with respect to the interval algebra. +-- For example, when @'Point' iv@ is 'Ord', they must always produce a valid +-- interval 'i' such that @'ivBegin' i < 'ivEnd' i@. +-- +-- In addition, the requirements of 'SizedIv' implementations in the common case +-- where @'Moment' iv@ is 'Num' and 'Ord' require the constructors to produce intervals +-- with 'duration' of at least 'moment'. +-- +-- In order to preserve the properties above, @ivExpandr, ivExpandl@ will not want to assume +-- validity of the input interval. In other words, @'ivExpandr' d i@ need not be the +-- identity when @d < 'moment'@ since it will need to ensure the result is a valid interval +-- even if 'i' is not. +-- +-- These two methods can therefore be used as constructors for valid intervals. +class (PointedIv iv) => SizedIv iv where + -- | Type of 'moment'. + type Moment iv + + -- | The smallest duration for an 'iv'. When 'Moment iv' is an instance of + -- 'Num', the default is 1. If @'Moment' iv@ is @Ord@ and @Num@, @'moment' > 0@ + -- is required. + moment :: Moment iv + + -- | The duration of an 'iv'. When @Moment iv ~ Point iv@ and @Point iv@ is + -- @Num@ this defaults to @ivEnd i - ivBegin i@. + duration :: iv -> Moment iv + + -- | Resize @iv@ by expanding to the "left" or to the "right" by some + -- duration. If @iv@ implements the interval algebra via @Iv@, these + -- methods must produce valid intervals regardless of the validity of the input + -- and thus serve as constructors for intervals. See also 'beginerval', + -- 'endverval', 'safeInterval' and related. + -- + -- See the class documentation for details requirements. + -- + -- >>> ivExpandr 1 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 2) + -- True + -- >>> ivExpandr 0 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 1) + -- True + -- >>> ivExpandl 1 (safeInterval (0, 1) :: Interval Int) == safeInterval (-1, 1) + -- True + -- >>> ivExpandl 0 (safeInterval (0, 1) :: Interval Int) == safeInterval (0, 1) + -- True + ivExpandr, ivExpandl :: Moment iv -> iv -> iv + + default moment :: (Num (Moment iv)) => Moment iv + moment = 1 + + default duration :: (Point iv ~ Moment iv, Num (Point iv)) => iv -> Moment iv + duration i = ivEnd i - ivBegin i + +-- | Resize an @i a@ to by expanding to "left" by @l@ and to the "right" by @r@. +-- In the case that @l@ or @r@ are less than a 'moment' the respective endpoints +-- are unchanged. +-- +-- >>> iv2to4 = safeInterval (2::Int, 4) +-- >>> iv2to4' = expand 0 0 iv2to4 +-- >>> iv1to5 = expand 1 1 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv2to4' +-- (2, 4) +-- +-- >>> iv1to5 +-- (1, 5) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv1to5, "iv1to5")] [] +-- -- <- [iv2to4] +-- ---- <- [iv1to5] +-- ===== +expand :: + (SizedIv (Interval a), Intervallic i) => + -- | duration to subtract from the 'begin' + Moment (Interval a) -> + -- | duration to add to the 'end' + Moment (Interval a) -> + i a -> + i a +expand l r = expandl l . expandr r + +-- | Expands an @i a@ to the "left". +-- +-- >>> iv2to4 = (safeInterval (2::Int, 4::Int)) +-- >>> iv0to4 = expandl 2 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv0to4 +-- (0, 4) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv0to4, "iv0to4")] [] +-- -- <- [iv2to4] +-- ---- <- [iv0to4] +-- ==== +expandl :: (SizedIv (Interval a), Intervallic i) => Moment (Interval a) -> i a -> i a +expandl l i = setInterval i $ ivExpandl l $ getInterval i + +-- | Expands an @i a@ to the "right". +-- +-- >>> iv2to4 = (safeInterval (2::Int, 4::Int)) +-- >>> iv2to6 = expandr 2 iv2to4 +-- +-- >>> iv2to4 +-- (2, 4) +-- +-- >>> iv2to6 +-- (2, 6) +-- +-- >>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv2to6, "iv2to6")] [] +-- -- <- [iv2to4] +-- ---- <- [iv2to6] +-- ====== +expandr :: (SizedIv (Interval a), Intervallic i) => Moment (Interval a) -> i a -> i a +expandr r i = setInterval i $ ivExpandr r $ getInterval i + +-- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding @max +-- 'moment' dur@ to @x@ as the 'end'. For the 'SizedIv' instances this +-- module exports, 'beginerval' is the same as 'interval'. However, it is defined +-- separately since 'beginerval' will /always/ have this behavior whereas +-- 'interval' behavior might differ by implementation. +-- +-- >>> beginerval (0::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (1::Int) (0::Int) +-- (0, 1) +-- +-- >>> beginerval (2::Int) (0::Int) +-- (0, 2) +beginerval :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to add to the 'begin' + Moment (Interval a) -> + -- | the 'begin' point of the 'Interval' + a -> + Interval a +beginerval dur x = ivExpandr dur $ Interval (x, x) + +-- | A synonym for `beginerval` +bi :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to add to the 'begin' + Moment (Interval a) -> + -- | the 'begin' point of the 'Interval' + a -> + Interval a +bi = beginerval + +-- | Safely creates an 'Interval a' using @x@ as the 'end' and adding @negate max +-- 'moment' dur@ to @x@ as the 'begin'. +-- +-- >>> enderval (0::Int) (0::Int) +-- (-1, 0) +-- +-- >>> enderval (1::Int) (0::Int) +-- (-1, 0) +-- +-- >>> enderval (2::Int) (0::Int) +-- (-2, 0) +enderval :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to subtract from the 'end' + Moment (Interval a) -> + -- | the 'end' point of the 'Interval' + a -> + Interval a +enderval dur x = ivExpandl dur $ Interval (x, x) + +-- | A synonym for `enderval` +ei :: + forall a. + (SizedIv (Interval a)) => + -- | @dur@ation to subtract from the 'end' + Moment (Interval a) -> + -- | the 'end' point of the 'Interval' + a -> + Interval a +ei = enderval + +-- | Safely creates an @'Interval'@ from a pair of endpoints, +-- expanding from the left endpoint if necessary to create a valid interval +-- according to the rules of 'SizedIv'. This function simply wraps +-- 'ivExpandr'. +-- +-- >>> safeInterval (4, 5 ::Int) +-- (4, 5) +-- >>> safeInterval (4, 3 :: Int) +-- (4, 5) +safeInterval :: + forall a. + (SizedIv (Interval a), Ord (Moment (Interval a))) => + (a, a) -> + Interval a +safeInterval (b, e) + | duration i < m = ivExpandr m $ Interval (b, b) + | otherwise = i + where + i = Interval (b, e) + m = moment @(Interval a) + +-- | A synonym for `safeInterval` +si :: + (SizedIv (Interval a), Ord (Moment (Interval a))) => + (a, a) -> + Interval a +si = safeInterval + +-- | Creates a new 'Interval' from the 'end' of another. +beginervalFromEnd :: + (SizedIv (Interval a), Intervallic i) => + -- | @dur@ation to add to the 'end' + Moment (Interval a) -> + -- | the @i a@ from which to get the 'end' + i a -> + Interval a +beginervalFromEnd d i = beginerval d (end i) + +-- | Creates a new 'Interval' from the 'begin' of another. +endervalFromBegin :: + (SizedIv (Interval a), Intervallic i) => + -- | @dur@ation to subtract from the 'begin' + Moment (Interval a) -> + -- | the @i a@ from which to get the 'begin' + i a -> + Interval a +endervalFromBegin d i = enderval d (begin i) + +-- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@ +-- +-- >>> beginervalMoment (10 :: Int) +-- (10, 11) +beginervalMoment :: forall a. (SizedIv (Interval a)) => a -> Interval a +beginervalMoment = beginerval (moment @(Interval a)) + +-- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ +-- +-- >>> endervalMoment (10 :: Int) +-- (9, 10) +endervalMoment :: forall a. (SizedIv (Interval a)) => a -> Interval a +endervalMoment = enderval (moment @(Interval a)) + +-- | Creates a new @Interval@ spanning the extent x and y. +-- +-- >>> extenterval (Interval (0, 1)) (Interval (9, 10)) +-- (0, 10) +extenterval :: (SizedIv (Interval a), Ord a, Intervallic i) => i a -> i a -> Interval a +extenterval x y = Interval (s, e) + where + s = min (begin x) (begin y) + e = max (end x) (end y) + +-- | Modifies the endpoints of second argument's interval by taking the difference +-- from the first's input's 'begin'. +-- +-- Example data with corresponding diagram: +-- +-- >>> a = bi 3 2 :: Interval Int +-- >>> a +-- (2, 5) +-- >>> x = bi 3 7 :: Interval Int +-- >>> x +-- (7, 10) +-- >>> y = bi 4 9 :: Interval Int +-- >>> y +-- (9, 13) +-- >>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] +-- --- <- [a] +-- --- <- [x] +-- ---- <- [y] +-- ============= +-- +-- Examples: +-- +-- >>> x' = shiftFromBegin a x +-- >>> x' +-- (5, 8) +-- >>> y' = shiftFromBegin a y +-- >>> y' +-- (7, 11) +-- >>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] +-- --- <- [x'] +-- ---- <- [y'] +-- =========== +shiftFromBegin :: + (Num a, SizedIv (Interval a), Intervallic i1, Intervallic i0) => + i0 a -> + i1 a -> + i1 a +shiftFromBegin i = imapStrictMonotone (\x -> x - begin i) + +-- | Modifies the endpoints of second argument's interval by taking the difference +-- from the first's input's 'end'. +-- +-- Example data with corresponding diagram: +-- +-- >>> a = bi 3 2 :: Interval Int +-- >>> a +-- (2, 5) +-- >>> x = bi 3 7 :: Interval Int +-- >>> x +-- (7, 10) +-- >>> y = bi 4 9 :: Interval Int +-- >>> y +-- (9, 13) +-- >>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] +-- --- <- [a] +-- --- <- [x] +-- ---- <- [y] +-- ============= +-- +-- Examples: +-- +-- >>> x' = shiftFromEnd a x +-- >>> x' +-- (2, 5) +-- >>> y' = shiftFromEnd a y +-- >>> y' +-- (4, 8) +-- >>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] +-- --- <- [x'] +-- ---- <- [y'] +-- ======== + +shiftFromEnd :: + (Num a, SizedIv (Interval a), Intervallic i1, Intervallic i0) => + i0 a -> + i1 a -> + i1 a +shiftFromEnd i = imapStrictMonotone (\x -> x - end i) + +-- | Converts an @i a@ to an @i Int@ via @fromEnum@. This assumes the provided +-- @fromEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@ with values @x, y@, then @x < y@ implies @fromEnum x < fromEnum y@, so +-- long as the latter is well-defined. +fromEnumInterval :: (Enum a, Intervallic i) => i a -> i Int +fromEnumInterval = imapStrictMonotone fromEnum + +-- | Converts an @i Int@ to an @i a@ via @toEnum@. This assumes the provided +-- @toEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@, then for @Int@ values @x, y@ it holds that @x < y@ implies @toEnum x +-- < toEnum y@. +toEnumInterval :: (Enum a, Intervallic i) => i Int -> i a +toEnumInterval = imapStrictMonotone toEnum + +-- | Changes the duration of an 'Intervallic' value to a moment starting at the +-- 'begin' of the interval. Uses 'beginervalMoment'. +-- +-- >>> momentize (Interval (6, 10)) +-- (6, 7) +momentize :: + forall i a. (SizedIv (Interval a), Intervallic i) => i a -> i a +momentize i = setInterval i $ beginervalMoment $ begin i + +{- +Misc +-} + +-- | Defines a predicate of two objects of type @a@. +type ComparativePredicateOf1 a = (a -> a -> Bool) + +-- | Defines a predicate of two object of different types. +type ComparativePredicateOf2 a b = (a -> b -> Bool) + +{- Common instance helpers -} + +-- | Internal. Helper for SizedIv constructor implementations +-- defined in this module, so as to ensure the class properties. +ivExpandrI :: + (Ord b) => + -- | 'moment' value to be passed here. + b -> + -- | 'duration' + (a -> a -> b) -> + -- | function for adding an amount of moments to a point. + -- It must always satisfy addFun (dFun x y) y == x + (b -> a -> a) -> + -- | duration by which to expand. + b -> + Interval a -> + Interval a +ivExpandrI mom dFun addFun d (Interval (b, e)) + | d < mom = Interval (b, addFun (max (dFun e b) mom) b) + | otherwise = Interval (b, addFun d e) + +ivExpandlI :: + (Ord b) => + -- | 'moment' value to be passed here. + b -> + -- | 'duration' + (a -> a -> b) -> + -- | function for subtracting a amount of moments to a point. + -- It must always satisfy subFun (dFun x y) x == y + (b -> a -> a) -> + -- | duration by which to expand. + b -> + Interval a -> + Interval a +ivExpandlI mom dFun subFun d (Interval (b, e)) + | d < mom = Interval (subFun (max (dFun e b) mom) e, e) + | otherwise = Interval (subFun d b, e) + +{- Instances -} + +-- | Imposes a total ordering on @'Interval' a@ based on first ordering the +-- 'begin's then the 'end's. +instance (Ord a) => Ord (Interval a) where + (Interval pts1) <= (Interval pts2) = pts1 <= pts2 + (Interval pts1) < (Interval pts2) = pts1 < pts2 + +instance Intervallic Interval where + getInterval = id + setInterval _ x = x + +instance PointedIv (Interval a) where + type Point (Interval a) = a + + ivBegin (Interval (b, _)) = b + ivEnd (Interval (_, e)) = e + +-- | Implements the interval algebra for intervals represented as left and right endpoints, +-- with points in a totally ordered set, as prescribed in +-- [Allen 1983](https://dl.acm.org/doi/10.1145/182.358434). +instance (Ord a) => Iv (Interval a) where + ivBefore x y = ivEnd x < ivBegin y + ivMeets x y = ivEnd x == ivBegin y + ivOverlaps x y = ivBegin x < ivBegin y && ivEnd x < ivEnd y && ivEnd x > ivBegin y + ivStarts x y = ivBegin x == ivBegin y && ivEnd x < ivEnd y + ivFinishes x y = ivBegin x > ivBegin y && ivEnd x == ivEnd y + ivDuring x y = ivBegin x > ivBegin y && ivEnd x < ivEnd y + ivEquals x y = ivBegin x == ivBegin y && ivEnd x == ivEnd y + +-- TODO: Consider whether blanket instance for +-- Num a => SizedIv (Interval a) is good. + +instance SizedIv (Interval Int) where + type Moment (Interval Int) = Int + ivExpandr = ivExpandrI (moment @(Interval Int)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Int)) (-) (flip (-)) + +instance SizedIv (Interval Integer) where + type Moment (Interval Integer) = Integer + ivExpandr = ivExpandrI (moment @(Interval Integer)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Integer)) (-) (flip (-)) + +instance SizedIv (Interval Double) where + type Moment (Interval Double) = Double + ivExpandr = ivExpandrI (moment @(Interval Double)) (-) (+) + ivExpandl = ivExpandlI (moment @(Interval Double)) (-) (flip (-)) + +instance SizedIv (Interval DT.Day) where + type Moment (Interval DT.Day) = Integer + duration (Interval (b, e)) = diffDays e b + moment = 1 + ivExpandr = ivExpandrI (moment @(Interval DT.Day)) diffDays addDays + ivExpandl = ivExpandlI (moment @(Interval DT.Day)) diffDays (\d -> addDays (-d)) + +-- | Note this instance changes the @moment@ to 1 'Pico' second, not 1 second +-- as would be the case if the default were used. +instance SizedIv (Interval DT.UTCTime) where + type Moment (Interval DT.UTCTime) = NominalDiffTime + moment = toEnum 1 + duration (Interval (b, e)) = diffUTCTime e b + ivExpandr = ivExpandrI (moment @(Interval DT.UTCTime)) diffUTCTime addUTCTime + ivExpandl = ivExpandlI (moment @(Interval DT.UTCTime)) diffUTCTime (\d -> addUTCTime (-d)) diff --git a/src/IntervalAlgebra/IntervalDiagram.hs b/src/IntervalAlgebra/IntervalDiagram.hs new file mode 100644 --- /dev/null +++ b/src/IntervalAlgebra/IntervalDiagram.hs @@ -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 diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -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 diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -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 diff --git a/src/IntervalAlgebra/RelationProperties.hs b/src/IntervalAlgebra/RelationProperties.hs new file mode 100644 --- /dev/null +++ b/src/IntervalAlgebra/RelationProperties.hs @@ -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 diff --git a/test-axioms/AxiomsSpec.hs b/test-axioms/AxiomsSpec.hs new file mode 100644 --- /dev/null +++ b/test-axioms/AxiomsSpec.hs @@ -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) + diff --git a/test-axioms/Main.hs b/test-axioms/Main.hs new file mode 100644 --- /dev/null +++ b/test-axioms/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import AxiomsSpec +import Test.Hspec + +main :: IO () +main = hspec spec diff --git a/test-relation-properties/Main.hs b/test-relation-properties/Main.hs new file mode 100644 --- /dev/null +++ b/test-relation-properties/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import RelationPropertiesSpec +import Test.Hspec + +main :: IO () +main = hspec spec diff --git a/test-relation-properties/RelationPropertiesSpec.hs b/test-relation-properties/RelationPropertiesSpec.hs new file mode 100644 --- /dev/null +++ b/test-relation-properties/RelationPropertiesSpec.hs @@ -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) diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -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) diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -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 diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -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)) + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs diff --git a/tutorial/TutorialMain.hs b/tutorial/TutorialMain.hs new file mode 100644 --- /dev/null +++ b/tutorial/TutorialMain.hs @@ -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"]