diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,22 @@ # Changelog for interval-algebra +## 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`. @@ -14,7 +31,7 @@ * 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. +* Use type application with `moment` instead, as in `moment @Int`, `moment @Day`, etc. * Adds the following utility functions: `lookback`, `lookahead`, `makeGapsWithinPredicate`, `pairGaps`, `anyGapsWithinAtLeastDuration`, `allGapsWithinLessThanDuration` diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra -version: 2.0.2 +version: 2.1.0 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -32,7 +32,7 @@ IntervalAlgebra.Arbitrary other-modules: Paths_interval_algebra - autogen-modules: + autogen-modules: Paths_interval_algebra hs-source-dirs: src @@ -53,46 +53,46 @@ default-language: Haskell2010 test-suite axioms - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: + 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 + , hspec , interval-algebra , QuickCheck , time default-language: Haskell2010 test-suite relations - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: + 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 + , hspec , interval-algebra - , QuickCheck - , time + , QuickCheck + , time default-language: Haskell2010 test-suite interval-algebra-test - type: exitcode-stdio-1.0 - 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 @@ -100,7 +100,7 @@ build-depends: base >=4.7 && <5 , containers - , hspec + , hspec , interval-algebra , QuickCheck , safe @@ -108,4 +108,16 @@ , witherable 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 + , witch ^>= 1.0 default-language: Haskell2010 diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -120,7 +120,7 @@ -- arbitraryWithRelation :: forall i a b - . (IntervalSizeable a b, Intervallic i a, Arbitrary (i a)) + . (IntervalSizeable a b, Intervallic i, Arbitrary (i a)) => i a -- ^ reference interval -> Data.Set.Set IntervalRelation -- ^ set of `IntervalRelation`s, of which at least one will hold for the generated interval relative to the reference -> Gen (Maybe (i a)) diff --git a/src/IntervalAlgebra/Core.hs b/src/IntervalAlgebra/Core.hs --- a/src/IntervalAlgebra/Core.hs +++ b/src/IntervalAlgebra/Core.hs @@ -5,15 +5,15 @@ License : BSD3 Maintainer : bsaul@novisci.com -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: +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'@. @@ -53,111 +53,27 @@ , safeInterval , si - -- ** Modify intervals + -- ** Modify intervals , expand , expandl , expandr - -- * Interval Algebra + -- * 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 @@ -167,7 +83,7 @@ , notDisjoint , concur , within - , enclose + , encloses , enclosedBy , (<|>) , predicate @@ -184,6 +100,8 @@ , shiftFromBegin , shiftFromEnd , momentize + , toEnumInterval + , fromEnumInterval -- ** Algebraic operations , intervalRelations @@ -213,7 +131,6 @@ , flip , id ) -import Data.Functor ( Functor(fmap) ) import Data.Ord ( Ord(..) , Ordering(..) , max @@ -282,6 +199,10 @@ , suchThat ) +{- $setup +>>> import IntervalAlgebra.IntervalDiagram +-} + {- | An @'Interval' a@ is a pair \( (x, y) \text{ such that } x < y\). To create intervals use the @'parseInterval'@, @'beginerval'@, or @'enderval'@ functions. -} @@ -291,19 +212,20 @@ newtype ParseErrorInterval = ParseErrorInterval String deriving (Eq, Show) --- | Helper defining what a valid relation is between begin and end of an --- Interval. +{- | Helper defining what a valid relation is between begin and end of an +Interval. +-} isValidBeginEnd :: (Ord a) => a -> a -> Bool isValidBeginEnd b e = b < e --- | Safely parse a pair of @a@s to create an @'Interval' a@. --- --- >>> parseInterval 0 1 --- Right (0, 1) --- --- >>> parseInterval 1 0 --- Left (ParseErrorInterval "0<=1") --- +{- | Safely parse a pair of @a@s to create an @'Interval' a@. + +>>> parseInterval 0 1 +Right (0, 1) + +>>> parseInterval 1 0 +Left (ParseErrorInterval "0<=1") +-} parseInterval :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) parseInterval x y @@ -313,25 +235,21 @@ prsi :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) prsi = parseInterval -intervalBegin :: (Ord a) => Interval a -> a +intervalBegin :: Interval a -> a intervalBegin (Interval x) = fst x -intervalEnd :: (Ord a) => Interval a -> a +intervalEnd :: 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) ++ ")" instance Binary a => Binary (Interval a) instance NFData a => NFData (Interval a) -{- | -The @'Intervallic'@ typeclass defines how to get and set the 'Interval' content -of a data structure. It also includes functions for getting the endpoints of the -'Interval' via @'begin'@ and @'end'@. +{- | 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) @@ -342,23 +260,29 @@ >>> end (Interval (0, 10)) 10 -} -class (Ord a) => Intervallic i a where +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 a -> i a + setInterval :: i a -> Interval b -> i b -- | Access the endpoints of an @i a@ . -begin, end :: Intervallic i a => i a -> a +begin, end :: (Intervallic i) => i a -> a begin = intervalBegin . getInterval end = intervalEnd . getInterval -{- | -The 'IntervalRelation' type and the associated predicate functions enumerate +{- | This *unexported* function is an internal convenience function for cases in +which @f@ is known to be strictly monotone. +-} +imapStrictMonotone :: (Intervallic i) => (a -> b) -> i a -> i b +imapStrictMonotone f i = setInterval i (op f (getInterval i)) + where op f (Interval (b, e)) = Interval (f b, f e) + +{- | The 'IntervalRelation' type and the associated predicate functions enumerate the thirteen possible ways that two @'Interval'@ objects may 'relate' according -to Allen's interval algebra. Constructors are shown with their corresponding +to Allen's interval algebra. Constructors are shown with their corresponding predicate function. -} data IntervalRelation = @@ -384,58 +308,236 @@ instance Ord IntervalRelation where compare x y = compare (fromEnum x) (fromEnum y) --- | Does x `meets` y? Is x metBy 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Eq a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) meets x y = end x == begin y metBy = flip meets --- | Is x before y? Is x after y? + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) before x y = end x < begin y after = flip before precedes = before precededBy = after --- | Does x overlap y? Is x overlapped by y? + + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) overlaps x y = begin x < begin y && end x < end y && end x > begin y overlappedBy = flip overlaps --- | Does x start y? Is x started by y? + +{-| 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) starts x y = begin x == begin y && end x < end y startedBy = flip starts --- | Does x finish y? Is x finished by y? + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) finishes x y = begin x > begin y && end x == end y finishedBy = flip finishes --- | Is x during y? Does x contain y? + +{-| 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) during x y = begin x > begin y && end x < end y contains = flip during --- | Does x equal y? + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) equals x y = begin x == begin y && end x == end y -- | Operator for composing the union of two predicates (<|>) - :: (Intervallic i0 a, Intervallic i1 a) + :: (Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) -> ComparativePredicateOf2 (i0 a) (i1 a) -> ComparativePredicateOf2 (i0 a) (i1 a) @@ -453,33 +555,275 @@ strictWithinRelations :: Data.Set.Set IntervalRelation strictWithinRelations = Data.Set.difference withinRelations (toSet [Equals]) --- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')? + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => 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'. + +{-| Does x `concur` with y? Is x `notDisjoint` with y?); This is +the 'complement' of 'disjoint'. + +Example data with corresponding diagram: + +>>> x = bi 3 0 +>>> y = bi 3 4 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +--- <- [x] + --- <- [y] +======= + +Examples: + +>>> x `notDisjoint` y +False +>>> y `concur` x +False + +Example data with corresponding diagram: + +>>> x = bi 3 0 +>>> y = bi 3 3 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +--- <- [x] + --- <- [y] +====== + +Examples: + +>>> x `notDisjoint` y +False +>>> y `concur` x +False + +Example data with corresponding diagram: + +>>> x = bi 6 0 +>>> y = bi 3 3 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] +------ <- [x] + --- <- [y] +====== + +Examples: + +>>> x `notDisjoint` y +True +>>> y `concur` x +True +-} notDisjoint, concur - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => 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'? + +{- | 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => 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) + +{- | Does x `encloses` y? That is, is y 'within' x? + +Example data with corresponding diagram: + +>>> x = bi 6 4 +>>> y = bi 6 4 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] + ------ <- [x] + ------ <- [y] +========== + +Examples: + +>>> x `encloses` y +True + +>>> y `encloses` x +True + +Example data with corresponding diagram: + +>>> x = bi 6 4 +>>> y = bi 5 4 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] + ------ <- [x] + ----- <- [y] +========== + +Examples: + +>>> x `encloses` y +True + +>>> y `encloses` x +False + +Example data with corresponding diagram: + +>>> x = bi 6 4 +>>> y = bi 4 5 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] + ------ <- [x] + ---- <- [y] +========== + +Examples: + +>>> x `encloses` y +True + +>>> y `encloses` x +False + +Example data with corresponding diagram: + +>>> x = bi 2 7 +>>> y = bi 1 5 +>>> pretty $ standardExampleDiagram [(x, "x"), (y, "y")] [] + -- <- [x] + - <- [y] +========= + +Examples: + +>>> x `encloses` y +False + +>>> y `encloses` x +False +-} +encloses + :: (Ord a, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) -enclose = flip enclosedBy +encloses = flip enclosedBy -- | The 'Data.Set.Set' of all 'IntervalRelation's. intervalRelations :: Data.Set.Set IntervalRelation @@ -495,7 +839,7 @@ toSet = Data.Set.fromList -- | Compose a list of interval relations with _or_ to create a new --- @'ComparativePredicateOf1' i a@. For example, +-- @'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 @@ -503,7 +847,7 @@ -- | Maps an 'IntervalRelation' to its corresponding predicate function. toPredicate - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => IntervalRelation -> ComparativePredicateOf2 (i0 a) (i1 a) toPredicate r = case r of @@ -521,17 +865,17 @@ MetBy -> metBy After -> after --- | Given a set of 'IntervalRelation's return a list of 'predicate' functions +-- | Given a set of 'IntervalRelation's return a list of 'predicate' functions -- corresponding to each relation. predicates - :: (Intervallic i0 a, Intervallic i1 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 - :: (Intervallic i0 a, Intervallic i1 a) + :: (Ord a, Intervallic i0, Intervallic i1) => Data.Set.Set IntervalRelation -> ComparativePredicateOf2 (i0 a) (i1 a) predicate = unionPredicates . predicates @@ -582,16 +926,16 @@ 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 --- +{- | 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 + :: (Ord a, Intervallic i0, Intervallic i1) => i0 a -> i1 a -> IntervalRelation relate x y | x `before` y = Before | x `after` y = After | x `meets` y = Meets @@ -606,9 +950,10 @@ | x `contains` y = Contains | otherwise = Equals --- | Compose two interval relations according to the rules of the algebra. --- The rules are enumerated according to --- . +{- | 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) @@ -631,13 +976,12 @@ -> Data.Set.Set IntervalRelation union = Data.Set.union --- | Find the converse of a @'Data.Set.Set' 'IntervalRelation'@. +-- | 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'. +{- | 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 @@ -646,29 +990,41 @@ moment = 1 -- | Determine the duration of an @'i a'@. - duration :: Intervallic i a => i a -> b + duration :: (Intervallic i) => i a -> b duration x = diff (end x) (begin x) - -- | Shifts an @a@. Most often, the @b@ will be the same type as @a@. + -- | 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) --- +{- | Resize an @i a@ to by expanding to "left" by @l@ and to the "right" by @r@. +In the case that @l@ or @r@ are less than a 'moment' the respective endpoints +are unchanged. + +>>> iv2to4 = safeInterval (2::Int, 4::Int) +>>> iv2to4' = expand 0 0 iv2to4 +>>> iv1to5 = expand 1 1 iv2to4 + +>>> iv2to4 +(2, 4) + +>>> iv2to4' +(2, 4) + +>>> iv1to5 +(1, 5) + +>>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv1to5, "iv1to5")] [] + -- <- [iv2to4] + ---- <- [iv1to5] +===== +-} expand :: forall i a b - . (IntervalSizeable a b, Intervallic i a) + . (IntervalSizeable a b, Intervallic i) => b -- ^ duration to subtract from the 'begin' -> b -- ^ duration to add to the 'end' -> i a @@ -679,38 +1035,60 @@ e = if r < moment @a 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 +{- | Expands an @i a@ to the "left". + +>>> iv2to4 = (safeInterval (2::Int, 4::Int)) +>>> iv0to4 = expandl 2 iv2to4 + +>>> iv2to4 +(2, 4) + +>>> iv0to4 +(0, 4) + +>>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv0to4, "iv0to4")] [] + -- <- [iv2to4] +---- <- [iv0to4] +==== +-} +expandl :: (IntervalSizeable a b, Intervallic i) => b -> i a -> i a expandl i = expand i 0 --- | Expands an @i a@ to "right". --- --- >>> expandr 2 (Interval (0::Int, 2::Int)) --- (0, 4) --- -expandr :: (IntervalSizeable a b, Intervallic i a) => b -> i a -> i a +{- | Expands an @i a@ to the "right". + +>>> iv2to4 = (safeInterval (2::Int, 4::Int)) +>>> iv2to6 = expandr 2 iv2to4 + +>>> iv2to4 +(2, 4) + +>>> iv2to6 +(2, 6) + +>>> pretty $ standardExampleDiagram [(iv2to4, "iv2to4"), (iv2to6, "iv2to6")] [] + -- <- [iv2to4] + ---- <- [iv2to6] +====== +-} +expandr :: (IntervalSizeable a b, Intervallic i) => b -> i a -> i a expandr = expand 0 --- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding --- @max 'moment' dur@ to @x@ as the 'end'. --- --- >>> beginerval (0::Int) (0::Int) --- (0, 1) --- --- >>> beginerval (1::Int) (0::Int) --- (0, 1) --- --- >>> beginerval (2::Int) (0::Int) --- (0, 2) --- +{- | Safely creates an 'Interval a' using @x@ as the 'begin' and adding @max +'moment' dur@ to @x@ as the 'end'. + +>>> beginerval (0::Int) (0::Int) +(0, 1) + +>>> beginerval (1::Int) (0::Int) +(0, 1) + +>>> beginerval (2::Int) (0::Int) +(0, 2) +-} beginerval :: forall a b . (IntervalSizeable a b) - => b -- ^ @dur@ation to add to the 'begin' + => b -- ^ @dur@ation to add to the 'begin' -> a -- ^ the 'begin' point of the 'Interval' -> Interval a beginerval dur x = Interval (x, y) @@ -723,28 +1101,28 @@ -- | A synonym for `beginerval` bi :: (IntervalSizeable a b) - => b -- ^ @dur@ation to add to the 'begin' + => b -- ^ @dur@ation to add to the 'begin' -> a -- ^ the 'begin' point of the 'Interval' -> Interval a bi = beginerval --- | Safely creates an 'Interval a' using @x@ as the 'end' and adding --- @negate max 'moment' dur@ to @x@ as the 'begin'. --- --- >>> enderval (0::Int) (0::Int) --- (-1, 0) --- --- >>> enderval (1::Int) (0::Int) --- (-1, 0) --- --- >>> enderval (2::Int) (0::Int) --- (-2, 0) --- +{- | Safely creates an 'Interval a' using @x@ as the 'end' and adding @negate max +'moment' dur@ to @x@ as the 'begin'. + +>>> enderval (0::Int) (0::Int) +(-1, 0) + +>>> enderval (1::Int) (0::Int) +(-1, 0) + +>>> enderval (2::Int) (0::Int) +(-2, 0) +-} enderval :: forall a b . (IntervalSizeable a b) - => b -- ^ @dur@ation to subtract from the 'end' + => b -- ^ @dur@ation to subtract from the 'end' -> a -- ^ the 'end' point of the 'Interval' -> Interval a enderval dur x = Interval (add (negate $ max (moment @a) dur) x, x) @@ -754,14 +1132,14 @@ -- | A synonym for `enderval` ei :: (IntervalSizeable a b) - => b -- ^ @dur@ation to subtract from the 'end' + => b -- ^ @dur@ation to subtract from the 'end' -> a -- ^ the 'end' point of the 'Interval' -> Interval a ei = enderval -- | Safely creates an @'Interval'@ from a pair of endpoints. --- IMPORTANT: This function uses 'beginerval', +-- IMPORTANT: This function uses 'beginerval', -- thus if the second element of the pair is `<=` the first element, -- the duration will be an @"Interval"@ of 'moment' duration. -- @@ -779,93 +1157,158 @@ -- | 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' + :: (IntervalSizeable a b, Intervallic i) + => b -- ^ @dur@ation to add to the 'end' -> i a -- ^ the @i a@ from which to get the 'end' -> Interval a beginervalFromEnd d i = beginerval d (end i) -- | Creates a new Interval from the 'begin' of an @i a@. endervalFromBegin - :: (IntervalSizeable a b, Intervallic i a) - => b -- ^ @dur@ation to subtract from the 'begin' + :: (IntervalSizeable a b, Intervallic i) + => b -- ^ @dur@ation to subtract from the 'begin' -> i a -- ^ the @i a@ from which to get the 'begin' -> Interval a endervalFromBegin d i = enderval d (begin i) --- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@ --- --- >>> beginervalMoment (10 :: Int) --- (10, 11) --- +{- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@ + +>>> beginervalMoment (10 :: Int) +(10, 11) +-} beginervalMoment :: forall a b . (IntervalSizeable a b) => a -> Interval a beginervalMoment x = beginerval (moment @a) x where i = Interval (x, x) --- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ --- --- >>> endervalMoment (10 :: Int) --- (9, 10) --- +{- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ + +>>> endervalMoment (10 :: Int) +(9, 10) +-} endervalMoment :: forall a b . (IntervalSizeable a b) => a -> Interval a endervalMoment x = enderval (moment @a) x where i = Interval (x, x) --- | Creates a new @Interval@ spanning the extent x and y. --- --- >>> extenterval (Interval (0, 1)) (Interval (9, 10)) --- (0, 10) --- -extenterval :: Intervallic i a => i a -> i a -> Interval a +{- | Creates a new @Interval@ spanning the extent x and y. + +>>> extenterval (Interval (0, 1)) (Interval (9, 10)) +(0, 10) +-} +extenterval :: (Ord a, Intervallic i) => i a -> i a -> Interval a extenterval x y = Interval (s, e) where s = min (begin x) (begin y) e = max (end x) (end y) --- | Modifies the endpoints of second argument's interval by taking the difference --- from the first's input's 'begin'. --- >>> shiftFromBegin (Interval ((5::Int), 6)) (Interval (10, 15)) --- (5, 10) --- --- >>> shiftFromBegin (Interval ((1::Int), 2)) (Interval (3, 15)) --- (2, 14) --- +{- | Modifies the endpoints of second argument's interval by taking the difference +from the first's input's 'begin'. + +Example data with corresponding diagram: + +>>> a = bi 3 2 :: Interval Int +>>> a +(2, 5) +>>> x = bi 3 7 :: Interval Int +>>> x +(7, 10) +>>> y = bi 4 9 :: Interval Int +>>> y +(9, 13) +>>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] + --- <- [a] + --- <- [x] + ---- <- [y] +============= + +Examples: + +>>> x' = shiftFromBegin a x +>>> x' +(5, 8) +>>> y' = shiftFromBegin a y +>>> y' +(7, 11) +>>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] + --- <- [x'] + ---- <- [y'] +=========== +-} shiftFromBegin - :: (IntervalSizeable a b, Functor i1, Intervallic i0 a) + :: (IntervalSizeable a b, Intervallic i1, Intervallic i0) => i0 a -> i1 a -> i1 b -shiftFromBegin i = fmap (`diff` begin i) +shiftFromBegin i = imapStrictMonotone (`diff` begin i) --- | Modifies the endpoints of second argument's interval by taking the difference --- from the first's input's 'end'. --- >>> shiftFromEnd (Interval ((5::Int), 6)) (Interval (10, 15)) --- (4, 9) --- --- >>> shiftFromEnd (Interval ((1::Int), 2)) (Interval (3, 15)) --- (1, 13) --- +{- | Modifies the endpoints of second argument's interval by taking the difference +from the first's input's 'end'. + +Example data with corresponding diagram: + +>>> a = bi 3 2 :: Interval Int +>>> a +(2, 5) +>>> x = bi 3 7 :: Interval Int +>>> x +(7, 10) +>>> y = bi 4 9 :: Interval Int +>>> y +(9, 13) +>>> pretty $ standardExampleDiagram [(a, "a"), (x, "x"), (y, "y")] [] + --- <- [a] + --- <- [x] + ---- <- [y] +============= + +Examples: + +>>> x' = shiftFromEnd a x +>>> x' +(2, 5) +>>> y' = shiftFromEnd a y +>>> y' +(4, 8) +>>> pretty $ standardExampleDiagram [(x', "x'"), (y', "y'")] [] + --- <- [x'] + ---- <- [y'] +======== +-} shiftFromEnd - :: (IntervalSizeable a b, Functor i1, Intervallic i0 a) + :: (IntervalSizeable a b, Intervallic i1, Intervallic i0) => i0 a -> i1 a -> i1 b -shiftFromEnd i = fmap (`diff` end i) +shiftFromEnd i = imapStrictMonotone (`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) --- +-- | Converts an @i a@ to an @i Int@ via @fromEnum@. This assumes the provided +-- @fromEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@ with values @x, y@, then @x < y@ implies @fromEnum x < fromEnum y@, so +-- long as the latter is well-defined. +fromEnumInterval :: (Enum a, Intervallic i) => i a -> i Int +fromEnumInterval = imapStrictMonotone fromEnum + +-- | Converts an @i Int@ to an @i a@ via @toEnum@. This assumes the provided +-- @toEnum@ method is strictly monotone increasing: For @a@ types that are +-- @Ord@, then for @Int@ values @x, y@ it holds that @x < y@ implies @toEnum x +-- < toEnum y@. +toEnumInterval :: (Enum a, Intervallic i) => i Int -> i a +toEnumInterval = imapStrictMonotone toEnum + + + +{- | Changes the duration of an 'Intervallic' value to a moment starting at the +'begin' of the interval. + +>>> momentize (Interval (6, 10)) +(6, 7) +-} momentize - :: forall i a b . (IntervalSizeable a b, Intervallic i a) => i a -> i a + :: forall i a b . (IntervalSizeable a b, Intervallic i) => i a -> i a momentize i = setInterval i (beginerval (moment @a) (begin i)) -{- | -The @'IntervalCombinable'@ typeclass provides methods for (possibly) combining -two @i a@s to form a @'Maybe' i a@, or in case of @><@, a possibly different -@Intervallic@ type. +{- | 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 +class (Ord a, Intervallic i) => IntervalCombinable i a where -- | Maybe form a new @i a@ by the union of two @i a@s that 'meets'. (.+.) :: i a -> i a -> Maybe (i a) @@ -876,20 +1319,20 @@ e = end y {-# INLINABLE (.+.) #-} - -- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the + -- | 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 + -- | If @x@ is 'before' @y@, return @f x@ appended to @f y@. Otherwise, + -- return 'extenterval' of @x@ and @y@ (wrapped in @f@). This is useful for + -- (left) folding over an *ordered* container of @Interval@s and combining -- intervals when @x@ is *not* 'before' @y@. (<+>):: ( Semigroup (f (i a)), Applicative f) => i a -> i a -> f (i a) - +{-# DEPRECATED (<+>) "A specialized function without clear use-cases." #-} {- Misc @@ -905,7 +1348,7 @@ -- Instances -- -} --- | Imposes a total ordering on @'Interval' a@ based on first ordering the +-- | 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 @@ -915,7 +1358,7 @@ | begin x == begin y = end x < end y | otherwise = False -instance (Ord a) => Intervallic Interval a where +instance Intervallic Interval where getInterval = id setInterval _ x = x diff --git a/src/IntervalAlgebra/IntervalDiagram.hs b/src/IntervalAlgebra/IntervalDiagram.hs --- a/src/IntervalAlgebra/IntervalDiagram.hs +++ b/src/IntervalAlgebra/IntervalDiagram.hs @@ -11,7 +11,6 @@ ------ ============================== ->>> import Data.Time >>> let ref = bi 30 (fromGregorian 2022 5 6) >>> let ivs = [ bi 2 (fromGregorian 2022 5 6), bi 5 (fromGregorian 2022 5 10)] >>> pretty $ simpleIntervalDiagram ref ivs @@ -49,6 +48,7 @@ -} parseIntervalDiagram , simpleIntervalDiagram + , standardExampleDiagram -- * Diagram options , IntervalDiagramOptions(..) @@ -64,6 +64,9 @@ , AxisParseError(..) , IntervalDiagramOptionsError(..) , IntervalDiagramParseError(..) + + -- * Re-exports + , Prettyprinter.Pretty(..) ) where import Data.Foldable ( Foldable(toList) ) @@ -73,13 +76,26 @@ import Data.Maybe ( fromMaybe , isNothing ) -import Data.Text ( Text ) +import Data.Text ( Text + , pack + ) import IntervalAlgebra.Core +import IntervalAlgebra.IntervalUtilities + ( rangeInterval ) +import IntervalAlgebra.PairedInterval ( PairedInterval + , getPairData + , makePairedInterval + ) import Prettyprinter import Witch ( From(..) , into ) +-- $setup +-- >>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings +-- >>> import IntervalAlgebra.IntervalUtilities (gapsWithin) +-- >>> import Data.Time + {- The key Type in this module is the IntervalDiagram, which has several components. @@ -103,36 +119,35 @@ Moreover, the type @b@ should be castable to @Int@, using its @'Witch.From' b Int@ instance. ->>> import Prettyprinter (pretty) ->>> import IntervalAlgebra (beginerval) ->>> pretty $ MkIntervalText '-' (beginerval 5 (0::Int)) +>>> pretty $ makeIntervalText '-' (beginerval 5 (0::Int)) ----- ->>> pretty $ MkIntervalText '*' (beginerval 10 (0::Int)) +>>> pretty $ makeIntervalText '*' (beginerval 10 (0::Int)) ********** -} --- NOTE: This type *could* be a PairedInterval, --- but I didn't do that in order to reduce depeendencies. -data IntervalText a = MkIntervalText Char (Interval a) - deriving (Eq, Show) -instance (Ord a) => Intervallic IntervalText a where - getInterval (MkIntervalText _ x) = x - setInterval (MkIntervalText c _) = MkIntervalText c +newtype IntervalText a = MkIntervalText (PairedInterval Char a) deriving (Eq, Show) -instance Functor IntervalText where - fmap f (MkIntervalText c i) = MkIntervalText c (fmap f i) +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 b, IntervalSizeable a b) => Pretty (IntervalText a) where - pretty (MkIntervalText c i) = pretty $ replicate (fromEnum (duration i)) c + pretty (MkIntervalText x) = pretty $ replicate (fromEnum (duration i)) c + where + c = getPairData x + i = getInterval x instance From (Char, Interval a) (IntervalText a) where - from = uncurry MkIntervalText + from = uncurry makeIntervalText instance From (IntervalText a) Char where - from (MkIntervalText c _) = c + from (MkIntervalText x) = getPairData x instance From (IntervalText a) (Interval a) where - from (MkIntervalText _ i) = i + from = getInterval {------------------------------------------------------------------------------- IntervalTextLine @@ -147,39 +162,39 @@ which checks that the inputs are parsed correctly to form intervals that will be pretty-printed correctly. ->>> let i1 = MkIntervalText '*' (beginerval 10 (5::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 2 (1::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 10 (5::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 2 (1::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x UnsortedIntervals ->>> let i1 = MkIntervalText '*' (beginerval 10 (5::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 2 (10::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 10 (5::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x ConcurringIntervals ->>> let i1 = MkIntervalText '*' (beginerval 10 ((-1)::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 2 (10::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 10 ((-1)::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x BeginsLessThanZero ->>> let i1 = MkIntervalText '*' (beginerval 5 (0::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 2 (10::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 5 (0::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x ***** -- ->>> let i1 = MkIntervalText '*' (beginerval 5 (5::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 2 (10::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 5 (5::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x *****-- ->>> let i1 = MkIntervalText '*' (beginerval 1 (5::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 1 (7::Int)) +>>> let i1 = makeIntervalText '*' (beginerval 1 (5::Int)) +>>> let i2 = makeIntervalText '-' (beginerval 1 (7::Int)) >>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x * - ->>> let i1 = MkIntervalText '*' (beginerval 3 (5::Int)) ->>> let i2 = MkIntervalText '-' (beginerval 5 (10::Int)) ->>> let i3 = MkIntervalText '#' (beginerval 1 17) +>>> 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] *** ----- # -} @@ -311,7 +326,7 @@ Use 'parseAxis' for construction. ->>> let ref = MkIntervalText '=' (beginerval 10 (0::Int)) +>>> let ref = makeIntervalText '=' (beginerval 10 (0::Int)) >>> let b = parseAxis [] (Just Top) ref @@ -563,7 +578,6 @@ Here's a basic diagram that shows how to put more than one interval interval on a line: ->>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings >>> let mkIntrvl c d b = into @(IntervalText Int) (c, bi d (b :: Int)) >>> let x = mkIntrvl '=' 20 0 >>> let l1 = [ mkIntrvl '-' 1 4 ] @@ -575,6 +589,7 @@ ## ==================== + We can put the axis on the top: >>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Top) x [ (l1, []), (l2, []), (l3, []) ] @@ -584,7 +599,6 @@ ## - We can annotate the axis: >>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [(5, 'a')] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ] @@ -672,7 +686,7 @@ 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 = fmap (fromEnum . (`diff` begin x)) + rereference x = fromEnumInterval . shiftFromBegin x rereferenceL x = fmap (rereference x) {-| @@ -680,8 +694,6 @@ produces an 'IntervalDiagram' with one line per interval, using the 'defaultIntervalDiagramOptions'. ->>> import Data.Maybe (fromMaybe) ->>> import IntervalAlgebra.IntervalUtilities (gapsWithin) >>> pretty $ simpleIntervalDiagram (bi 10 (0 :: Int)) (fmap (bi 1) [0..9]) - - @@ -711,7 +723,7 @@ -} simpleIntervalDiagram - :: (Ord a, IntervalSizeable a b, Intervallic i a, Enum b) + :: (Ord a, IntervalSizeable a b, Intervallic i, Enum b) => i a -- ^ The axis interval -> [i a] -- ^ List of intervals to be printed one per line -> Either IntervalDiagramParseError (IntervalDiagram a) @@ -719,5 +731,66 @@ defaultIntervalDiagramOptions [] (Just Bottom) - (MkIntervalText '=' (getInterval ref)) - (fmap (\x -> (pure $ MkIntervalText '-' $ getInterval x, [])) ivs) + (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 = si (1, 5) +>>> x2 = si (7, 10) +>>> x3 = si (13, 15) +>>> ivs = [x1, x2, x3] +>>> gaps = [si (5, 7), si (10, 13)] +>>> :{ +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, Ord a, Enum b, IntervalSizeable a b) + => [(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 @@ -12,7 +12,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} - +{-# LANGUAGE ScopedTypeVariables #-} module IntervalAlgebra.IntervalUtilities ( @@ -20,6 +20,8 @@ -- * Fold over sequential intervals combineIntervals , combineIntervalsL + , combineIntervalsFromSorted + , combineIntervalsFromSortedL , rangeInterval , gaps , gapsL @@ -55,7 +57,7 @@ , filterNotDisjoint , filterConcur , filterWithin - , filterEnclose + , filterEncloses , filterEnclosedBy -- * Functions for manipulating intervals @@ -90,7 +92,12 @@ , (||) ) import safe Data.Eq ( Eq((==)) ) -import safe Data.Foldable ( Foldable(foldl', null, toList) +import safe Data.Foldable ( Foldable + ( foldl' + , foldr + , null + , toList + ) , all , any , or @@ -99,6 +106,10 @@ , (.) , flip ) +import safe Data.List ( map + , reverse + , sortOn + ) import safe Data.Maybe ( Maybe(..) , maybe , maybeToList @@ -119,10 +130,7 @@ , ComparativePredicateOf1 , ComparativePredicateOf2 , Interval - , IntervalCombinable - ( (<+>) - , (><) - ) + , IntervalCombinable((><)) , IntervalRelation(..) , IntervalSizeable ( diff @@ -134,12 +142,13 @@ , begin , beginerval , beginervalFromEnd + , bi , concur , contains , disjoint , during - , enclose , enclosedBy + , encloses , end , enderval , endervalFromBegin @@ -173,15 +182,16 @@ , mapMaybe ) +{- $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) @@ -201,7 +211,7 @@ , Applicative t , Witherable.Witherable t , IntervalSizeable a b - , Intervallic i0 a + , Intervallic i0 , IntervalCombinable i1 a ) => ((b -> Bool) -> t b -> Bool) @@ -213,7 +223,7 @@ -- | Gets the durations of gaps (via 'IntervalAlgebra.(><)') between all pairs -- of the input. pairGaps - :: (Intervallic i a, IntervalSizeable a b, IntervalCombinable i a) + :: (Intervallic i, IntervalSizeable a b, IntervalCombinable i a) => [i a] -> [Maybe b] pairGaps es = fmap (fmap duration . uncurry (><)) (pairs es) @@ -233,7 +243,7 @@ -- >>> lookback 4 (beginerval 10 (1 :: Int)) -- (-3, 1) lookback - :: (Intervallic i a, IntervalSizeable a b) + :: (Intervallic i, IntervalSizeable a b) => b -- ^ lookback duration -> i a -> Interval a @@ -245,7 +255,7 @@ -- >>> lookahead 4 (beginerval 1 (1 :: Int)) -- (2, 6) lookahead - :: (Intervallic i a, IntervalSizeable a b) + :: (Intervallic i, IntervalSizeable a b) => b -- ^ lookahead duration -> i a -> Interval a @@ -255,7 +265,7 @@ -- specified duration among the input intervals? anyGapsWithinAtLeastDuration :: ( IntervalSizeable a b - , Intervallic i0 a + , Intervallic i0 , IntervalCombinable i1 a , Monoid (t (Interval a)) , Monoid (t (Maybe (Interval a))) @@ -275,7 +285,7 @@ -- True allGapsWithinLessThanDuration :: ( IntervalSizeable a b - , Intervallic i0 a + , Intervallic i0 , IntervalCombinable i1 a , Monoid (t (Interval a)) , Monoid (t (Maybe (Interval a))) @@ -304,21 +314,27 @@ -- | Returns a list of the 'IntervalRelation' between each consecutive pair -- of intervals. This is just a specialized 'relations' which returns a list. -- --- >>> relationsL [iv 1 0, iv 1 1] +-- >>> relationsL [bi 1 0, bi 1 1] -- [Meets] -- -relationsL :: (Foldable f, Intervallic i a) => f (i a) -> [IntervalRelation] +relationsL + :: (Foldable f, Ord a, Intervallic i) => f (i a) -> [IntervalRelation] relationsL = relations -- | A generic form of 'relations' which can output any 'Applicative' and -- 'Monoid' structure. -- --- >>> (relations [iv 1 0,iv 1 1]) :: [IntervalRelation] +-- >>> (relations [bi 1 0,bi 1 1]) :: [IntervalRelation] -- [Meets] -- -- relations - :: (Foldable f, Applicative m, Intervallic i a, Monoid (m IntervalRelation)) + :: ( Foldable f + , Applicative m + , Ord a + , Intervallic i + , Monoid (m IntervalRelation) + ) => f (i a) -> m IntervalRelation relations = L.fold (makeFolder relate) @@ -327,11 +343,11 @@ -- | Forms a 'Just' new interval from the intersection of two intervals, -- provided the intervals are not disjoint. -- --- >>> intersect (iv 5 0) (iv 2 3) +-- >>> intersect (bi 5 0) (bi 2 3) -- Just (3, 5) -- intersect - :: (Intervallic i a, IntervalSizeable a b) => i a -> i a -> Maybe (Interval a) + :: (Intervallic i, 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 @@ -351,13 +367,45 @@ gapsM = L.fold (makeFolder (\i j -> getInterval i >< getInterval j)) {-# INLINABLE gapsM #-} --- | Returns a @Maybe@ container of intervals consisting of the gaps --- between intervals in the input. *To work properly, the input should be --- sorted*. See 'gapsL' for a version that always returns a list. --- --- >>> gaps [iv 4 1, iv 4 8, iv 3 11] --- Nothing --- +{- | 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. + +>>> 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 +Nothing +>>> pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [] + ---- <- [x1] + ---- <- [x2] + --- <- [x3] +============== + +>>> x1 = bi 4 1 +>>> x2 = bi 3 7 +>>> x3 = bi 2 13 +>>> ivs = [x1, x2, x3] +>>> ivs +[(1, 5),(7, 10),(13, 15)] +>>> gapIvs = gaps ivs +>>> gapIvs +Just [(5, 7),(10, 13)] +>>> :{ +case gapIvs of + Nothing -> pretty "" + (Just x) -> pretty $ + standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(x, "gapIvs")] +:} + ---- <- [x1] + --- <- [x2] + -- <- [x3] + -- --- <- [gapIvs] +=============== +-} gaps :: ( IntervalCombinable i a , Traversable f @@ -369,10 +417,47 @@ gaps = sequenceA . gapsM {-# INLINABLE gaps #-} --- | Returns a (possibly empty) list of intervals consisting of the gaps between --- intervals in the input container. *To work properly, the input should be --- sorted*. This version outputs a list. See 'gaps' for a version that lifts --- the result to same input structure @f@. +{- | Returns a (possibly empty) list of intervals consisting of the gaps between +intervals in the input container. +__To work properly, the input should be sorted.__ This version outputs a list. +See 'gaps' for a version that lifts the result to same input structure @f@. + +>>> x1 = bi 4 1 +>>> x2 = bi 4 8 +>>> x3 = bi 3 11 +>>> ivs = [x1, x2, x3] +>>> ivs +[(1, 5),(8, 12),(11, 14)] +>>> gapIvs = gapsL ivs +>>> gapIvs +[] +>>> :{ +pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [] +:} + ---- <- [x1] + ---- <- [x2] + --- <- [x3] +============== + +>>> x1 = bi 4 1 +>>> x2 = bi 3 7 +>>> x3 = bi 2 13 +>>> ivs = [x1, x2, x3] +>>> ivs +[(1, 5),(7, 10),(13, 15)] +>>> gapIvs = gapsL ivs +>>> gapIvs +[(5, 7),(10, 13)] +>>> :{ +pretty $ + standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gapIvs, "gapIvs")] +:} + ---- <- [x1] + --- <- [x2] + -- <- [x3] + -- --- <- [gapIvs] +=============== +-} gapsL :: ( IntervalCombinable i a , Applicative f @@ -386,23 +471,22 @@ -- | 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 :: (Functor f, Intervallic i, IntervalSizeable a b) => f (i a) -> f b durations = fmap duration -- | 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) + :: (Intervallic i0, Intervallic i1, IntervalSizeable a b) => i0 a -> i1 a -> Maybe (Interval a) @@ -417,14 +501,14 @@ jx = starts <|> during <|> finishes {-# INLINABLE clip #-} --- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are *not* disjoint +-- | 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. +-- @Just mempty@ (e.g. @Just []@) is returned. -- --- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] +-- >>> gapsWithin (bi 9 1) [bi 5 0, bi 2 7, bi 3 12] -- Just [(5, 7),(9, 10)] -- gapsWithin @@ -433,7 +517,7 @@ , Monoid (f (Interval a)) , Monoid (f (Maybe (Interval a))) , IntervalSizeable a b - , Intervallic i0 a + , Intervallic i0 , IntervalCombinable i1 a ) => i0 a -- ^ i @@ -448,72 +532,153 @@ 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] } +{- | Returns a container of intervals where any intervals that meet or share +support are combined into one interval. This functions sorts the input intervals +first. See @combineIntervalsL@ for a version that works only on lists. If you +know the input intervals are sorted, use @combineIntervalsFromSorted@ instead. -packIntervalBoxes :: (Intervallic i a) => [i a] -> [Box (Interval a)] -packIntervalBoxes = fmap (\z -> Box [getInterval z]) +>>> x1 = bi 10 0 +>>> x2 = bi 5 2 +>>> x3 = bi 2 10 +>>> x4 = bi 2 13 +>>> ivs = [x1, x2, x3, x4] +>>> ivs +[(0, 10),(2, 7),(10, 12),(13, 15)] +>>> xComb = combineIntervals ivs +>>> xComb +[(0, 12),(13, 15)] +>>> :{ +pretty $ + standardExampleDiagram + (zip ivs ["x1", "x2", "x3", "x4"]) + [(xComb, "xComb")] +:} +---------- <- [x1] + ----- <- [x2] + -- <- [x3] + -- <- [x4] +------------ -- <- [xComb] +=============== +-} +combineIntervals + :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) + => f (i a) + -> f (Interval a) +combineIntervals = combineIntervalsWith combineIntervalsL -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. The condition is applied cumulatively, +from left to right, so +__to work properly, the input list should be sorted in increasing order__. See +@combineIntervalsLFromSorted@ for a version that works only on lists. --- | 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 - ) +>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 2 10, bi 2 13] +[(0, 12),(13, 15)] +-} +combineIntervalsFromSorted + :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) => f (i a) -> f (Interval a) -combineIntervals x = - foldl' (\x y -> x <> pure y) mempty (combineIntervalsL $ toList x) - -- TODO: surely combineIntervals and combineIntervalsL could be combined -{-# INLINABLE combineIntervals #-} +combineIntervalsFromSorted = combineIntervalsWith combineIntervalsFromSortedL --- | 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 #-} +-- | Unexported helper +combineIntervalsWith + :: (Applicative f, Ord a, Intervallic i, Monoid (f (Interval a)), Foldable f) + => ([i a] -> [Interval a]) + -> f (i a) + -> f (Interval a) +combineIntervalsWith f x = foldl' (\x y -> x <> pure y) mempty (f $ toList x) --- | --- 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@. --- --- >>> rangeInterval [beginerval 0 0, beginerval 0 (-1)] --- Just (-1, 1) --- >>> rangeInterval ([] :: [Interval Int]) --- Nothing --- >>> rangeInterval (Just (beginerval 0 0)) --- Just (0, 1) +{- | 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@. + +>>> 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 = combineIntervalsL ivs +>>> xComb +[(0, 12),(13, 15)] +>>> :{ +pretty $ + standardExampleDiagram + (zip ivs ["x1", "x2", "x3", "x4"]) + [(xComb, "xComb")] +:} +---------- <- [x1] + ----- <- [x2] + -- <- [x3] + -- <- [x4] +------------ -- <- [xComb] +=============== +-} +combineIntervalsL :: (Intervallic i, Ord a) => [i a] -> [Interval a] +combineIntervalsL = combineIntervalsFromSortedL . sortOn getInterval + +{- | Returns a list of intervals where any intervals that meet or share support +are combined into one interval. The operation is applied cumulatively, from left +to right, so +__to work properly, the input list should be sorted in increasing order__. + +>>> combineIntervalsFromSortedL [bi 10 0, bi 5 2, bi 2 10, bi 2 13] +[(0, 12),(13, 15)] + +>>> combineIntervalsFromSortedL [bi 10 0, bi 5 2, bi 0 8] +[(0, 10)] +-} +combineIntervalsFromSortedL + :: forall a i . (Ord a, Intervallic i) => [i a] -> [Interval a] +combineIntervalsFromSortedL = reverse . foldl' op [] + 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 + +{- | @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@. + +>>> rangeInterval ([] :: [Interval Int]) +Nothing + +>>> 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] +=========== + +>>> rangeInterval Nothing +Nothing +>>> rangeInterval (Just (bi 1 0)) +Just (0, 1) +-} rangeInterval :: (Ord a, L.Foldable t) => t (Interval a) -> Maybe (Interval a) rangeInterval = L.fold (liftA2 extenterval <$> L.minimum <*> L.maximum) --- 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. @@ -532,12 +697,12 @@ -- 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] +-- >>> nothingIfNone (starts (bi 2 3)) [bi 1 3, bi 1 5] -- Nothing -- -- In the following, (3, 5) 'starts' (3, 6), so 'Just' the input is returned. -- --- >>> nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5] +-- >>> nothingIfNone (starts (bi 2 3)) [bi 3 3, bi 1 5] -- Just [(3, 6),(5, 6)] -- nothingIfNone @@ -549,10 +714,10 @@ -- | Returns 'Nothing' if *any* of the element of input satisfy the predicate condition. -- --- >>> nothingIfAny (startedBy (iv 2 3)) [iv 3 3, iv 1 5] +-- >>> nothingIfAny (startedBy (bi 2 3)) [bi 3 3, bi 1 5] -- Just [(3, 6),(5, 6)] -- --- >>> nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] +-- >>> nothingIfAny (starts (bi 2 3)) [bi 3 3, bi 1 5] -- Nothing -- nothingIfAny @@ -564,7 +729,7 @@ -- | Returns 'Nothing' if *all* of the element of input satisfy the predicate condition. -- --- >>> nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] +-- >>> nothingIfAll (starts (bi 2 3)) [bi 3 3, bi 4 3] -- Nothing -- nothingIfAll @@ -577,7 +742,7 @@ -- | 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) + :: (Filterable f, Intervallic i0, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) -> i0 a -> (f (i1 a) -> f (i1 a)) @@ -588,8 +753,8 @@ a (potentially different) 'Intervallic' type using the corresponding interval predicate function. -} -filterOverlaps, filterOverlappedBy, filterBefore, filterAfter, filterStarts, filterStartedBy, filterFinishes, filterFinishedBy, filterMeets, filterMetBy, filterDuring, filterContains, filterEquals, filterDisjoint, filterNotDisjoint, filterConcur, filterWithin, filterEnclose, filterEnclosedBy - :: (Filterable f, Intervallic i0 a, Intervallic i1 a) +filterOverlaps, filterOverlappedBy, filterBefore, filterAfter, filterStarts, filterStartedBy, filterFinishes, filterFinishedBy, filterMeets, filterMetBy, filterDuring, filterContains, filterEquals, filterDisjoint, filterNotDisjoint, filterConcur, filterWithin, filterEncloses, filterEnclosedBy + :: (Filterable f, Ord a, Intervallic i0, Intervallic i1) => i0 a -> f (i1 a) -> f (i1 a) @@ -610,7 +775,7 @@ filterNotDisjoint = makeFilter notDisjoint filterConcur = makeFilter concur filterWithin = makeFilter within -filterEnclose = makeFilter enclose +filterEncloses = makeFilter encloses filterEnclosedBy = makeFilter enclosedBy -- | Folds over a list of Paired Intervals and in the case that the 'getPairData' @@ -644,7 +809,7 @@ 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 :: (Ord a, Intervallic i) => [i a] -> Maybe (Meeting [i a]) parseMeeting x | all (== Meets) (relationsL x) = Just $ Meeting x | otherwise = Nothing @@ -658,7 +823,7 @@ -- A general function for combining any two @Meeting [i a]@ by 'listCombiner'. joinMeeting - :: Intervallic i a + :: (Ord a, Intervallic i) => ComparativePredicateOf1 (i a) -> Meeting [i a] -> Meeting [i a] @@ -669,7 +834,7 @@ -- 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 + :: (Ord a, Intervallic i) => ComparativePredicateOf1 (i a) -> Maybe (i a) -> Maybe (i a) @@ -789,4 +954,3 @@ hasEqData :: (Eq b) => [PairedInterval b a] -> Bool hasEqData x = or (L.fold (makeFolder (==)) (fmap getPairData x) :: [Bool]) - diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -25,12 +25,12 @@ import safe Control.Applicative ( liftA2 ) import safe Control.DeepSeq ( NFData ) -import safe Data.Bifunctor ( Bifunctor(bimap) ) import safe Data.Binary ( Binary ) import safe GHC.Generics ( Generic ) import safe IntervalAlgebra.Core ( ComparativePredicateOf1 , Interval , IntervalCombinable(..) + , IntervalSizeable , Intervallic(..) , before , extenterval @@ -42,15 +42,9 @@ newtype PairedInterval b a = PairedInterval (Interval a, b) deriving (Eq, Generic) -instance (Ord a) => Intervallic (PairedInterval b) a where +instance Intervallic (PairedInterval b) where getInterval (PairedInterval x) = fst x setInterval (PairedInterval (x, y)) i = PairedInterval (i, y) - -instance Functor (PairedInterval b) where - fmap f (PairedInterval (x, y)) = PairedInterval (fmap f x, 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) diff --git a/src/IntervalAlgebra/RelationProperties.hs b/src/IntervalAlgebra/RelationProperties.hs --- a/src/IntervalAlgebra/RelationProperties.hs +++ b/src/IntervalAlgebra/RelationProperties.hs @@ -145,11 +145,11 @@ -> Property prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy - prop_enclose_predicate :: (Ord a) => + prop_encloses_predicate :: (Ord a) => Interval a -> Interval a -> Property - prop_enclose_predicate = prop_predicate_unions (converse withinRelations) enclose + prop_encloses_predicate = prop_predicate_unions (converse withinRelations) encloses instance IntervalRelationProperties Int Int instance IntervalRelationProperties Day Integer diff --git a/test-relation-properties/RelationPropertiesSpec.hs b/test-relation-properties/RelationPropertiesSpec.hs --- a/test-relation-properties/RelationPropertiesSpec.hs +++ b/test-relation-properties/RelationPropertiesSpec.hs @@ -32,7 +32,7 @@ it "during" $ property (prop_IAduring @Int) it "disjoint" $ property (prop_disjoint_predicate @Int) it "within" $ property (prop_within_predicate @Int) - it "enclose" $ property (prop_enclose_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) @@ -47,7 +47,7 @@ it "during" $ property (prop_IAduring @Day) it "disjoint" $ property (prop_disjoint_predicate @Day) it "within" $ property (prop_within_predicate @Day) - it "enclose" $ property (prop_enclose_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) @@ -62,7 +62,7 @@ it "during" $ property (prop_IAduring @UTCTime) it "disjoint" $ property (prop_disjoint_predicate @UTCTime) it "within" $ property (prop_within_predicate @UTCTime) - it "enclose" $ property (prop_enclose_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) diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -45,6 +45,7 @@ import IntervalAlgebra.IntervalUtilities ( clip , combineIntervals + , combineIntervalsFromSorted , durations , filterAfter , filterBefore @@ -52,8 +53,8 @@ , filterContains , filterDisjoint , filterDuring - , filterEnclose , filterEnclosedBy + , filterEncloses , filterEquals , filterFinishedBy , filterFinishes @@ -172,7 +173,7 @@ pure $ IntervalReferenced refIv rels iv -- Testing functions -checkSeqStates :: (Intervallic i Int) => [i Int] -> Bool +checkSeqStates :: (Intervallic i) => [i Int] -> Bool checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x) -- Creation functions @@ -438,10 +439,10 @@ -> Property prop_filterEnclosedBy = prop_filtration filterEnclosedBy withinRelations - prop_filterEnclose :: Interval a + prop_filterEncloses :: Interval a -> [Interval a] -> Property - prop_filterEnclose = prop_filtration filterEnclose (converse withinRelations) + prop_filterEncloses = prop_filtration filterEncloses (converse withinRelations) prop_filterConcur :: Interval a -> [Interval a] @@ -568,7 +569,7 @@ 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 "filterEncloses property" $ property (prop_filterEncloses @Int) it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int) describe "nothingIf unit tests" $ do @@ -656,8 +657,14 @@ it "combineIntervals [] should be []" $ combineIntervals ([] :: [Interval Int]) `shouldBe` [] - it "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]" + 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 "combineIntervals property tests" $ modifyMaxSuccess (* 10) $ do diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -2,7 +2,6 @@ ( spec ) where -import Data.Bifunctor ( Bifunctor(bimap) ) import Data.Bool import Data.Time ( Day(ModifiedJulianDay) , fromGregorian @@ -12,6 +11,7 @@ , before , beginerval , equals + , toEnumInterval ) import IntervalAlgebra.PairedInterval ( Empty(..) , PairedInterval @@ -43,15 +43,11 @@ 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)) + -- 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 "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\"}" diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -120,9 +120,12 @@ $ 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) + -- 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) @@ -332,4 +335,3 @@ it "concur matches notDisjoint" $ concur (beginerval 1 0) (beginerval 10 (0 :: Int)) `shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int)) - diff --git a/tutorial/TutorialMain.hs b/tutorial/TutorialMain.hs new file mode 100644 --- /dev/null +++ b/tutorial/TutorialMain.hs @@ -0,0 +1,823 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# 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.Time + ( addDays, fromGregorian, secondsToDiffTime, Day, UTCTime(..) ) +import Witch ( into ) +import Data.Set ( fromList, difference, Set ) +-- end::import-declarations[] + +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 (safeInterval (4, 9) :: Interval Integer)\n---> " + print $ setInterval pairListstringInteger (safeInterval (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[]" + + + -- IntervalSizeable instance examples ------------------------------------------------------ + + putStrLn "-- tag::intervalsizeable-instance-print[]" + + putStr "\nprint ivDay\n---> " + print ivDay + + putStr "\nprint $ moment @Day\n---> " + print $ moment @Day + + putStr "\nprint $ duration ivDay\n---> " + print $ duration ivDay + + putStr "\nprint $ add 15 (begin ivDay)\n---> " + print $ add 15 (begin ivDay) + + putStr "\nprint $ diff (add 15 (begin ivDay)) (begin ivDay)\n---> " + print $ diff (add 15 (begin ivDay)) (begin ivDay) + + putStrLn "-- end::intervalsizeable-instance-print[]" + + + -- IntervalCombineable Interval 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[]" + + + -- IntervalCombineable 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 ivDay\n---> " + print ivDay + + putStr "\nprint $ shiftFromBegin iv2to4 iv5to8\n---> " + print $ shiftFromBegin iv2to4 iv5to8 + + putStr "\nprint $ shiftFromBegin ivDay ivDay\n---> " + print $ shiftFromBegin ivDay ivDay + + putStr "\nprint $ shiftFromEnd iv2to4 iv5to8\n---> " + print $ shiftFromEnd iv2to4 iv5to8 + + putStr "\nprint $ shiftFromEnd ivDay ivDay\n---> " + print $ shiftFromEnd ivDay ivDay + + putStrLn "-- end::shifting-intervals-print[]" + + + -- 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::safeinterval-examples[] +ivInteger :: Interval Integer +ivInteger = safeInterval (2, 6) + +ivMinDurInteger :: Interval Integer +ivMinDurInteger = safeInterval (2, 2) + +ivDay :: Interval Day +ivDay = safeInterval (fromGregorian 1967 01 18, fromGregorian 1967 01 24) + +ivUTC :: Interval UTCTime +ivUTC = safeInterval + ( UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 32400) + , UTCTime (fromGregorian 1967 01 18) (secondsToDiffTime 33200) + ) +-- end::safeinterval-examples[] + + +-- tag::ivXtoY-examples[] ---------------- + +iv0to2, iv2to4, iv2to5, iv4to5, iv5to8, iv6to8, iv3to6 :: Interval Integer +iv0to2 = safeInterval (0, 2) +iv2to4 = safeInterval (2, 4) +iv2to5 = safeInterval (2, 5) +iv3to6 = safeInterval (3, 6) +iv4to5 = safeInterval (4, 5) +iv5to8 = safeInterval (5, 8) +iv6to8 = safeInterval (6, 8) + +-- 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 + :: (Ord a, Intervallic i0, Intervallic i1) + => ComparativePredicateOf2 (i0 a) (i1 a) +endedPrior = predicate (fromList [Before, Meets]) + +-- We can also construct a predicate function directly from a list of predicate +-- functions +endedPrior' + :: (Ord a, Intervallic i0, Intervallic i1) + => 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'' + :: (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 + :: (IntervalSizeable a b, Intervallic i0, Intervallic i1) + => Maybe (i0 a) + -> Maybe (i1 a) + -> Maybe b +calcDiff (Just y) (Just x) = Just $ diff (begin y) (end x) +calcDiff _ _ = Nothing + +-- Calculate the difference between the end endpoint of the first Intervallic +-- and the start endpoint of the second Intervallic +calcAtRisk + :: (IntervalSizeable a b, Intervallic i0, Intervallic i1) + => Maybe (i0 a) + -> Maybe (i1 a) + -> Maybe b +calcAtRisk (Just y) (Just x) = Just $ diff (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 = parseIntervalDiagram + defaultIntervalDiagramOptions + [] + (Just Bottom) + (into @(IntervalText Integer) ('=', safeInterval (0, 12 :: Integer))) + [ ([deftIT iv0to2], ["iv0to2"]) + , ([deftIT iv2to4], ["iv2to4"]) + , ([deftIT iv2to5], ["iv2to5"]) + , ([deftIT iv3to6], ["iv3to6"]) + , ([deftIT iv4to5], ["iv4to5"]) + , ([deftIT iv6to8], ["iv6to8"]) + , ([deftIT iv5to8], ["iv5to8"]) + ] + +intoIntervalText :: Interval Integer -> IntervalText Integer +intoIntervalText x = into @(IntervalText Integer) ('-', x) + +deftIT :: Interval Integer -> IntervalText Integer +deftIT = intoIntervalText