packages feed

interval-patterns (empty) → 0.1.0.0

raw patch · 9 files changed

+1680/−0 lines, 9 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, groups, hspec, interval-patterns, lattices, relude, semirings, time, time-compat

Files

+ CHANGELOG.md view
@@ -0,0 +1,111 @@+# Revision history for interval-patterns++## 0.1.0.0 - 2022-05-19++* constructors behave more intuitively+  * if the endpoints are equal, it becomes a closed interval+  * when endpoints are reversed, using a smart constructor preserves the declared endpoint boundaries+    (e.g. `6 :|>: 4` becomes `4 :<|: 6`)+* tests++## 0.0.11.0 - 2022-03-08++* drop `Data.Suspension` entirely in favour of `Algebra.Lattice.Levitated`+* rename `Data.Interval.{Set => Borel}` and add Lattice/Ring/Heyting instances+* explicit exports for `Data.OneOrTwo`++## 0.0.10.2 -- 2022-02-22++* fix `Enum` for `Suspension`++## 0.0.10.1 -- 2022-02-15++* add `Layers.remove` and `Layers.baseline`++## 0.0.10.0 -- 2022-02-15++* add dependency `group-theory`+* `instance Monoid Suspension` now lifts monoids only+* add `instance Group x => Group (Suspension x)`+* `Data.Interval.unions` now sorts the list first; add `unionsAsc`+* `Covering.unionsSet` uses `from/toAscList` and `unionsAsc`+* `instance Group y => Group (Layers x y)`+* `instance Functor Layers`+* `nesting` now sorts the list first; add `nestingAsc`+* `Semigroup Layers` uses `nestingAsc`++## 0.0.9.0 -- 2022-02-15++* `Layers` is now a two-parameter type, and `nestings` supports arbitrary+  semigroups instead of the previous restriction to `Int`.+* drop `multiset` dependency as a result+* `type Event = Layers UTCTime (Sum Int)`++## 0.0.8.0 -- 2022-02-15++* switch definitions of `lower` and `lowerBound`, `upper` and `upperBound`+* universal `Bounded` and lifted `Enum` for Suspension+* `(Data.Interval.\\)`+* change names from `IntervalSet -> Covering` and `IntervalLayer -> Layers`+* rename `Covering.intervals` to `Covering.covering` ("smart constructor")++## 0.0.7.1 -- 2022-02-13++* `imapS` and `itraverseS`++## 0.0.7.0 -- 2022-02-13++* introduce strictness annotations for `Suspension`, `Interval`, and `Adjacency`++## 0.0.6.1 -- 2022-02-13++* fix `Num` instance for `Suspension`++## 0.0.6.0 -- 2022-02-13++* remove `AdjacencyRepr` (don't need a type parameter you're just gonna hide)+* amalgamate `split` into `adjacency`+* no need for weird import chain, define everything in `Data.Interval`++## 0.0.5.0 -- 2022-02-12++* `Data.Interval.Layered` provides a monoid like `IntervalSet`, but+  that will keep track of the number of times a particular interval+  has been added to the structure. This is useful for determining, e.g.,+  how many clones you need to attend all today's meetings on time.++## 0.0.4.0 -- 2022-02-12++* Rename project++# Revision history for timeframes++## 0.0.3.0 -- 2022-02-12++* Drop `orient`, putting `Ord` constraints on the constructors of `Interval`+  and leaving the ordering to the smart constructors+* Rewrite `intersection`, `union`, and `difference` using `split`+* Settle on changelog format+* move `withBounds` to `Data.Interval`++## 0.0.2.0 -- 2022-02-12++* Drop `UpToThree` in favour of a more dependently-typed model of adjacency+* `Overlap` is changed to `Adjacency` where it occurs+* `split` now returns `SomeAdjacency`, which can be pattern-matched to yield+  the exact (one, two, or three) intervals into which the two have been cleaved+* `Interval` moved into `Data.Interval.Types` to avoid a cyclic dependency+  between `Data.Interval` and `Data.Interval.Adjacency`++## 0.0.1.0 -- 2022-02-08++Types and functions for working with intervals and their monoid under union.++* `Data.Suspension` provides the two-point extension of a type,+  used for marking the endpoints of intervals.+* `Data.Interval` defines the `Interval` type, along with type- and value-level+  structures for working with closed and open endpoints.+* `overlap` calculates the relationship between intervals+  according to Allen`s interval algebra.+* `split` separates two intervals into one, two, or three parts,+  depending on their overlap.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2022 Melanie Brown++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ interval-patterns.cabal view
@@ -0,0 +1,85 @@+cabal-version: 3.0+name: interval-patterns+version: 0.1.0.0+author: Melanie Brown+description: A library for easy manipulation of intervals according to their overlap.+maintainer: brown.m@pm.me+license: BSD-3-Clause+license-file: LICENSE+homepage: https://github.com/cigsender/interval-patterns+bug-reports: https://github.com/cigsender/interval-patterns/issues+extra-source-files: CHANGELOG.md+copyright: 2022 Melanie Brown++common interval-patterns+  build-depends:+    , base >= 4.11 && < 5+    , containers+    , groups >= 0.2.2+    , lattices >= 2.0.3 && < 2.1+    , semirings >= 0.6 && < 0.7+    , relude >= 1.0.0.1 && < 1.1+    , time+    , time-compat >= 1.9.6.1 && < 1.10+  default-extensions:+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    EmptyCase+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    OverloadedStrings+    PatternSynonyms+    PolyKinds+    QuasiQuotes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    StandaloneKindSignatures+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns+  default-language: Haskell2010+  ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors+  mixins:+    base hiding (Prelude)+    , relude (Relude as Prelude)+    , relude++library+  import: interval-patterns+  hs-source-dirs: src+  exposed-modules:+    Data.Interval+    Data.Interval.Layers+    Data.Interval.Borel+    Data.OneOrTwo+    Data.Timeframe++test-suite tests+  import: interval-patterns+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Main.hs+  build-depends:+    , hspec+    , interval-patterns+    , QuickCheck
+ src/Data/Interval.hs view
@@ -0,0 +1,968 @@+-- |+-- Module       : Data.Interval+-- Copyright    : (c) Melanie Brown 2022+-- License:     : BSD3 (see the file LICENSE)+--+-- Intervals over types and their operations.+module Data.Interval (+  Extremum (..),+  opposite,+  Bound (..),+  unBound,+  Bounding (..),+  compareBounds,+  SomeBound (..),+  unSomeBound,+  oppose,+  Interval (..),+  imap,+  imapS,+  itraverse,+  itraverseS,+  pattern (:<->:),+  pattern (:<-|:),+  pattern (:|->:),+  pattern (:|-|:),+  pattern (:<>:),+  pattern (:<|:),+  pattern (:|>:),+  pattern (:||:),+  pattern Whole,+  bounds,+  lower,+  lowerBound,+  upper,+  upperBound,+  interval,+  imin,+  iinf,+  isup,+  imax,+  hull,+  hulls,+  within,+  point,+  open,+  close,+  openclosed,+  closedopen,+  openLower,+  closedLower,+  openUpper,+  closedUpper,+  setLower,+  setUpper,+  Adjacency (..),+  converseAdjacency,+  adjacency,+  intersect,+  union,+  unions,+  unionsAsc,+  complement,+  difference,+  (\\),+  symmetricDifference,+  measure,+  measuring,+  hausdorff,+  (+/-),+) where++import Algebra.Lattice.Levitated+import Data.Data (Data)+import Data.OneOrTwo (OneOrTwo (..))+import GHC.Show qualified (show)++-- | The kinds of extremum an interval can have.+data Extremum+  = Minimum+  | Infimum+  | Supremum+  | Maximum+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable)++-- | The 'opposite' of an extremum is how it would be viewed+-- from the other "direction" of how it is currently.+--+-- c.f. 'opposeBound'.+opposite :: Extremum -> Extremum+opposite = \case+  Minimum -> Supremum+  Infimum -> Maximum+  Supremum -> Minimum+  Maximum -> Infimum++-- | A 'Bound' is an endpoint of an 'Interval'.+type Bound :: Extremum -> Type -> Type+data Bound ext x where+  Min :: !x -> Bound Minimum x+  Inf :: !x -> Bound Infimum x+  Sup :: !x -> Bound Supremum x+  Max :: !x -> Bound Maximum x++-- | Extract the term from a 'Bound'.+unBound :: Bound ext x -> x+unBound = \case+  Min x -> x+  Inf x -> x+  Sup x -> x+  Max x -> x++instance Functor (Bound ext) where+  fmap f = \case+    Min x -> Min (f x)+    Inf x -> Inf (f x)+    Sup x -> Sup (f x)+    Max x -> Max (f x)++instance Foldable (Bound ext) where+  foldMap f = \case+    Min x -> f x+    Inf x -> f x+    Sup x -> f x+    Max x -> f x++instance Traversable (Bound ext) where+  traverse f = \case+    Min x -> Min <$> f x+    Inf x -> Inf <$> f x+    Sup x -> Sup <$> f x+    Max x -> Max <$> f x++instance (Eq x) => Eq (Bound ext x) where+  Min x == Min y = x == y+  Inf x == Inf y = x == y+  Sup x == Sup y = x == y+  Max x == Max y = x == y++instance (Ord x) => Ord (Bound ext (Levitated x)) where+  compare = compareBounds++-- | A type class for inverting 'Bound's.+type Bounding :: Extremum -> Constraint+class+  ( Opposite (Opposite ext) ~ ext+  ) =>+  Bounding ext+  where+  type Opposite ext :: Extremum+  bound :: x -> Bound ext x++  -- | c.f. 'opposite'.+  opposeBound :: Bound ext x -> Bound (Opposite ext) x++instance Bounding Minimum where+  type Opposite Minimum = Supremum+  bound = Min+  opposeBound (Min x) = Sup x++instance Bounding Infimum where+  type Opposite Infimum = Maximum+  bound = Inf+  opposeBound (Inf x) = Max x++instance Bounding Supremum where+  type Opposite Supremum = Minimum+  bound = Sup+  opposeBound (Sup x) = Min x++instance Bounding Maximum where+  type Opposite Maximum = Infimum+  bound = Max+  opposeBound (Max x) = Inf x++-- | 'Bound's have special comparison rules for identical points.+--+-- - minima are lesser than infima+-- - suprema are lesser than maxima+-- - infima and minima are both lesser than suprema and maxima+compareBounds ::+  (Ord x) =>+  Bound ext1 (Levitated x) ->+  Bound ext2 (Levitated x) ->+  Ordering+compareBounds (Min l) = \case+  Min ll -> compare l ll+  Inf ll -> compare l ll <> LT+  Sup u -> compare l u <> GT+  Max u -> compare l u+compareBounds (Inf l) = \case+  Min ll -> compare l ll <> GT+  Inf ll -> compare l ll+  Sup u -> compare l u <> GT+  Max u -> compare l u <> GT+compareBounds (Sup u) = \case+  Min l -> compare l u <> LT+  Inf l -> compare l u <> LT+  Sup uu -> compare u uu+  Max uu -> compare u uu <> LT+compareBounds (Max u) = \case+  Min l -> compare l u+  Inf l -> compare l u <> LT+  Sup uu -> compare u uu <> GT+  Max uu -> compare u uu++data SomeBound x+  = forall ext.+    (Bounding ext, Bounding (Opposite ext)) =>+    SomeBound !(Bound ext x)++instance (Eq x) => Eq (SomeBound (Levitated x)) where+  SomeBound (Min a) == SomeBound (Min b) = a == b+  SomeBound (Max a) == SomeBound (Max b) = a == b+  SomeBound (Inf a) == SomeBound (Inf b) = a == b+  SomeBound (Sup a) == SomeBound (Sup b) = a == b+  _ == _ = False++instance (Ord x) => Ord (SomeBound (Levitated x)) where+  SomeBound b0 `compare` SomeBound b1 = compareBounds b0 b1++oppose :: SomeBound x -> SomeBound x+oppose (SomeBound b) = SomeBound (opposeBound b)++unSomeBound :: (Ord x) => SomeBound x -> x+unSomeBound (SomeBound b) = unBound b++infix 5 :<-->:++infix 5 :<--|:++infix 5 :|-->:++infix 5 :|--|:++type Interval :: Type -> Type+data Interval x where+  -- Open-open interval. You probably want '(:<->:)' or '(:<>:)'.+  (:<-->:) ::+    (Ord x) =>+    !(Bound Infimum (Levitated x)) ->+    !(Bound Supremum (Levitated x)) ->+    Interval x+  -- Open-closed interval. You probably want '(:<-|:)' or '(:<|:)'.+  (:<--|:) ::+    (Ord x) =>+    !(Bound Infimum (Levitated x)) ->+    !(Bound Maximum (Levitated x)) ->+    Interval x+  -- Closed-open interval. You probably want '(:|->:)' or '(:|>:)'.+  (:|-->:) ::+    (Ord x) =>+    !(Bound Minimum (Levitated x)) ->+    !(Bound Supremum (Levitated x)) ->+    Interval x+  -- Closed-closed interval. You probably want '(:|-|:)' or '(:||:)'.+  (:|--|:) ::+    (Ord x) =>+    !(Bound Minimum (Levitated x)) ->+    !(Bound Maximum (Levitated x)) ->+    Interval x++deriving instance (Ord x) => Eq (Interval x)++instance (Ord x, Show x) => Show (Interval x) where+  show = \case+    l :<->: u -> "(" <> show l <> " :<->: " <> show u <> ")"+    l :|->: u -> "(" <> show l <> " :|->: " <> show u <> ")"+    l :<-|: u -> "(" <> show l <> " :<-|: " <> show u <> ")"+    l :|-|: u -> "(" <> show l <> " :|-|: " <> show u <> ")"++instance (Ord x) => Ord (Interval x) where+  compare i1 i2 = on compare lower i1 i2 <> on compare upper i1 i2++-- | Since the 'Ord' constraints on the constructors for 'Interval'+-- prevent it from being a 'Functor', this will have to suffice.+imap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y+imap f = \case+  l :<->: u -> fmap f l :<->: fmap f u+  l :|->: u -> fmap f l :|->: fmap f u+  l :<-|: u -> fmap f l :<-|: fmap f u+  l :|-|: u -> fmap f l :|-|: fmap f u++-- | Same as 'imap' but on the 'Levitated' of the underlying type.+imapS ::+  (Ord x, Ord y) =>+  (Levitated x -> Levitated y) ->+  Interval x ->+  Interval y+imapS f = \case+  l :<->: u -> f l :<->: f u+  l :|->: u -> f l :|->: f u+  l :<-|: u -> f l :<-|: f u+  l :|-|: u -> f l :|-|: f u++-- | Since the 'Ord' constraints on the constructors for 'Interval'+-- prevent it from being 'Traversable', this will have to suffice.+itraverse ::+  (Ord x, Ord y, Applicative f) =>+  (x -> f y) ->+  Interval x ->+  f (Interval y)+itraverse f = \case+  l :<->: u -> liftA2 (:<->:) (traverse f l) (traverse f u)+  l :|->: u -> liftA2 (:|->:) (traverse f l) (traverse f u)+  l :<-|: u -> liftA2 (:<-|:) (traverse f l) (traverse f u)+  l :|-|: u -> liftA2 (:|-|:) (traverse f l) (traverse f u)++-- | Same as 'itraverse' but on the 'Levitated' of the underlying type.+itraverseS ::+  (Ord x, Ord y, Applicative f) =>+  (Levitated x -> f (Levitated y)) ->+  Interval x ->+  f (Interval y)+itraverseS f = \case+  l :<->: u -> liftA2 (:<->:) (f l) (f u)+  l :|->: u -> liftA2 (:|->:) (f l) (f u)+  l :<-|: u -> liftA2 (:<-|:) (f l) (f u)+  l :|-|: u -> liftA2 (:|-|:) (f l) (f u)++infix 5 :<->:++infix 5 :<-|:++infix 5 :|->:++infix 5 :|-|:++-- | A pattern synonym matching open intervals.+pattern (:<->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x+pattern l :<->: u <-+  Inf l :<-->: Sup u+  where+    b1 :<->: b2 =+      let inf = min b1 b2+          sup = max b1 b2+       in case compare b1 b2 of+            EQ -> Min inf :|--|: Max sup+            _ -> Inf inf :<-->: Sup sup++-- | A pattern synonym matching open-closed intervals.+pattern (:<-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x+pattern l :<-|: u <-+  Inf l :<--|: Max u+  where+    b1 :<-|: b2 =+      let inf = min b1 b2+          sup = max b1 b2+       in case compare b1 b2 of+            LT -> Inf inf :<--|: Max sup+            EQ -> Min inf :|--|: Max sup+            GT -> Min inf :|-->: Sup sup++-- | A pattern synonym matching closed-open intervals.+pattern (:|->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x+pattern l :|->: u <-+  Min l :|-->: Sup u+  where+    b1 :|->: b2 =+      let inf = min b1 b2+          sup = max b1 b2+       in case compare b1 b2 of+            LT -> Min inf :|-->: Sup sup+            EQ -> Min inf :|--|: Max sup+            GT -> Inf inf :<--|: Max sup++-- | A pattern synonym matching closed intervals.+pattern (:|-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x+pattern l :|-|: u <-+  Min l :|--|: Max u+  where+    b1 :|-|: b2 = Min (min b1 b2) :|--|: Max (max b1 b2)++{-# COMPLETE (:<->:), (:<-|:), (:|->:), (:|-|:) #-}++infix 5 :<>:++infix 5 :<|:++infix 5 :|>:++infix 5 :||:++-- | A pattern synonym matching finite open intervals.+pattern (:<>:) :: forall x. (Ord x) => x -> x -> Interval x+pattern l :<>: u <- -- Levitate l :<->: Levitate u+  Levitate l :<->: Levitate u+  where+    b1 :<>: b2 =+      let inf = Levitate (min b1 b2)+          sup = Levitate (max b1 b2)+       in case compare inf sup of+            EQ -> Min inf :|--|: Max sup+            _ -> Inf inf :<-->: Sup sup++-- | A pattern synonym matching finite open-closed intervals.+pattern (:<|:) :: forall x. (Ord x) => x -> x -> Interval x+pattern l :<|: u <- -- Levitate l :<-|: Levitate u+  Levitate l :<-|: Levitate u+  where+    b1 :<|: b2 =+      let inf = Levitate (min b1 b2)+          sup = Levitate (max b1 b2)+       in case compare inf sup of+            EQ -> Min inf :|--|: Max sup+            _ -> Inf inf :<--|: Max sup++-- | A pattern synonym matching finite closed-open intervals.+pattern (:|>:) :: forall x. (Ord x) => x -> x -> Interval x+pattern l :|>: u <- -- Levitate l :|->: Levitate u+  Levitate l :|->: Levitate u+  where+    b1 :|>: b2 =+      let inf = Levitate (min b1 b2)+          sup = Levitate (max b1 b2)+       in case compare inf sup of+            EQ -> Min inf :|--|: Max sup+            _ -> Inf inf :<--|: Max sup++-- | A pattern synonym matching finite closed intervals.+pattern (:||:) :: forall x. (Ord x) => x -> x -> Interval x+pattern l :||: u <- -- Levitate l :|-|: Levitate u+  Levitate l :|-|: Levitate u+  where+    b1 :||: b2 = Min (Levitate $ min b1 b2) :|--|: Max (Levitate $ max b1 b2)++-- | The whole interval.+pattern Whole :: (Ord x) => Interval x+pattern Whole = Bottom :|-|: Top++-- | Get the @(lower, upper)@ 'bounds' of an 'Interval'.+--+-- c.f. 'lower', 'upper'.+bounds :: Interval x -> (SomeBound (Levitated x), SomeBound (Levitated x))+bounds = \case+  l :<-->: u -> (SomeBound l, SomeBound u)+  l :<--|: u -> (SomeBound l, SomeBound u)+  l :|-->: u -> (SomeBound l, SomeBound u)+  l :|--|: u -> (SomeBound l, SomeBound u)++-- | Get the lower bound of an interval.+--+-- > lower = fst . bounds+lower :: (Ord x) => Interval x -> SomeBound (Levitated x)+lower = fst . bounds++-- | Get the upper bound of an interval.+--+-- > upper = snd . bounds+upper :: (Ord x) => Interval x -> SomeBound (Levitated x)+upper = snd . bounds++-- | Get the lower bound of an interval+-- (with the bound expressed at the term level).+lowerBound :: (Ord x) => Interval x -> (Levitated x, Extremum)+lowerBound = \case+  l :<->: _ -> (l, Infimum)+  l :<-|: _ -> (l, Infimum)+  l :|->: _ -> (l, Minimum)+  l :|-|: _ -> (l, Minimum)++-- | Get the upper bound of an interval+-- (with the bound expressed at the term level).+upperBound :: (Ord x) => Interval x -> (Levitated x, Extremum)+upperBound = \case+  _ :<->: u -> (u, Supremum)+  _ :<-|: u -> (u, Maximum)+  _ :|->: u -> (u, Supremum)+  _ :|-|: u -> (u, Maximum)++-- | Given 'SomeBound's, try to make an interval.+interval ::+  (Ord x) =>+  SomeBound (Levitated x) ->+  SomeBound (Levitated x) ->+  Interval x+interval (SomeBound b1) (SomeBound b2) = case (b1, b2) of+  (Min l, Sup u) -> l :|->: u+  (Min l, Max u) -> l :|-|: u+  (Inf l, Sup u) -> l :<->: u+  (Inf l, Max u) -> l :<-|: u+  (Sup u, Min l) -> l :|->: u+  (Sup u, Inf l) -> l :<->: u+  (Max u, Min l) -> l :|-|: u+  (Max u, Inf l) -> l :<-|: u+  _ -> error "cannot make an interval with the given bounds"++-- | According to+-- [Allen](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra),+-- two intervals can be "adjacent" in 13 different ways,+-- into at most 3 distinct intervals. In this package,+-- this quality is called the 'Adjacency' of the intervals.+data Adjacency x+  = Before !(Interval x) !(Interval x)+  | Meets !(Interval x) !(Interval x) !(Interval x)+  | Overlaps !(Interval x) !(Interval x) !(Interval x)+  | Starts !(Interval x) !(Interval x)+  | During !(Interval x) !(Interval x) !(Interval x)+  | Finishes !(Interval x) !(Interval x)+  | Identical !(Interval x)+  | FinishedBy !(Interval x) !(Interval x)+  | Contains !(Interval x) !(Interval x) !(Interval x)+  | StartedBy !(Interval x) !(Interval x)+  | OverlappedBy !(Interval x) !(Interval x) !(Interval x)+  | MetBy !(Interval x) !(Interval x) !(Interval x)+  | After !(Interval x) !(Interval x)+  deriving (Eq, Ord, Show, Generic, Typeable)++-- | The result of having compared the same two intervals in reverse order.+converseAdjacency :: Adjacency x -> Adjacency x+converseAdjacency = \case+  Before i j -> After i j+  Meets i j k -> MetBy i j k+  Overlaps i j k -> OverlappedBy i j k+  Starts i j -> StartedBy i j+  During i j k -> Contains i j k+  Finishes i j -> FinishedBy i j+  Identical i -> Identical i+  FinishedBy i j -> Finishes i j+  Contains i j k -> During i j k+  StartedBy i j -> Starts i j+  OverlappedBy i j k -> Overlaps i j k+  MetBy i j k -> Meets i j k+  After i j -> Before i j++-- | Get the convex hull of two intervals.+--+-- >>> hull (7 :|>: 8) (3 :|>: 4)+-- (Levitate 3 :|->: Levitate 8)+--+-- >>> hull (Bottom :<-|: 3) (3 :<|: 4)+-- (Bottom :<-|: Levitate 4)+hull :: (Ord x) => Interval x -> Interval x -> Interval x+hull i1 i2 = case (lower (min i1 i2), upper (max i1 i2)) of+  (SomeBound l@(Inf _), SomeBound u@(Sup _)) -> l :<-->: u+  (SomeBound l@(Inf _), SomeBound u@(Max _)) -> l :<--|: u+  (SomeBound l@(Min _), SomeBound u@(Sup _)) -> l :|-->: u+  (SomeBound l@(Min _), SomeBound u@(Max _)) -> l :|--|: u+  _ -> error "Invalid lower/upper bounds"++-- | Get the convex hull of a non-empty list of intervals.+hulls :: (Ord x) => NonEmpty (Interval x) -> Interval x+hulls (i :| []) = i+hulls (i :| j : is) = hulls $ hull i j :| is++-- | Test whether a point is contained in the interval.+within :: (Ord x) => x -> Interval x -> Bool+within (Levitate -> x) = \case+  l :<->: u -> l < x && x < u+  l :<-|: u -> l < x && x <= u+  l :|->: u -> l <= x && x < u+  l :|-|: u -> l <= x && x <= u++-- | Create the closed-closed interval at a given point.+point :: (Ord x) => x -> Interval x+point = join (:||:)++-- | Get the minimum of an interval, if it exists.+imin :: (Ord x) => Interval x -> Maybe (Bound Minimum (Levitated x))+imin = \case+  (_ :<-->: _) -> Nothing+  (_ :<--|: _) -> Nothing+  (x :|-->: _) -> Just x+  (x :|--|: _) -> Just x++-- | Get the infimum of an interval, weakening if necessary.+iinf :: (Ord x) => Interval x -> Bound Infimum (Levitated x)+iinf = \case+  (x :<->: _) -> Inf x+  (x :<-|: _) -> Inf x+  (x :|->: _) -> Inf x+  (x :|-|: _) -> Inf x++-- | Get the supremum of an interval, weakening if necessary.+isup :: (Ord x) => Interval x -> Bound Supremum (Levitated x)+isup = \case+  (_ :<->: x) -> Sup x+  (_ :<-|: x) -> Sup x+  (_ :|->: x) -> Sup x+  (_ :|-|: x) -> Sup x++-- | Get the maximum of an interval if it exists.+imax :: (Ord x) => Interval x -> Maybe (Bound Maximum (Levitated x))+imax = \case+  (_ :<-->: _) -> Nothing+  (_ :<--|: x) -> Just x+  (_ :|-->: _) -> Nothing+  (_ :|--|: x) -> Just x++-- | Open both bounds of the given interval.+open :: (Ord x) => Interval x -> Interval x+open = \case+  l :<->: u -> l :<->: u+  l :<-|: u -> l :<->: u+  l :|->: u -> l :<->: u+  l :|-|: u -> l :<->: u++-- | Close both bounds of the given interval.+close :: (Ord x) => Interval x -> Interval x+close = \case+  l :<->: u -> l :|-|: u+  l :<-|: u -> l :|-|: u+  l :|->: u -> l :|-|: u+  l :|-|: u -> l :|-|: u++-- | Make the interval open-closed, leaving the endpoints unchanged.+openclosed :: (Ord x) => Interval x -> Interval x+openclosed = \case+  l :<->: u -> l :<->: u+  l :<-|: u -> l :<->: u+  l :|->: u -> l :<->: u+  l :|-|: u -> l :<->: u++-- | Make the interval closed-open, leaving the endpoints unchanged.+closedopen :: (Ord x) => Interval x -> Interval x+closedopen = \case+  l :<->: u -> l :|-|: u+  l :<-|: u -> l :|-|: u+  l :|->: u -> l :|-|: u+  l :|-|: u -> l :|-|: u++-- | Make the lower bound open, leaving the endpoints unchanged.+openLower :: (Ord x) => Interval x -> Interval x+openLower = \case+  l :<->: u -> l :<->: u+  l :<-|: u -> l :<-|: u+  l :|->: u -> l :<->: u+  l :|-|: u -> l :<-|: u++-- | Make the lower bound closed, leaving the endpoints unchanged.+closedLower :: (Ord x) => Interval x -> Interval x+closedLower = \case+  l :<->: u -> l :|->: u+  l :<-|: u -> l :|-|: u+  l :|->: u -> l :|->: u+  l :|-|: u -> l :|-|: u++-- | Make the upper bound open, leaving the endpoints unchanged.+openUpper :: (Ord x) => Interval x -> Interval x+openUpper = \case+  l :<->: u -> l :<->: u+  l :<-|: u -> l :<->: u+  l :|->: u -> l :|->: u+  l :|-|: u -> l :|->: u++-- | Make the upper bound closed, leaving the endpoints unchanged.+closedUpper :: (Ord x) => Interval x -> Interval x+closedUpper = \case+  l :<->: u -> l :<-|: u+  l :<-|: u -> l :<-|: u+  l :|->: u -> l :|-|: u+  l :|-|: u -> l :|-|: u++setLower :: (Ord x) => Levitated x -> Interval x -> Interval x+setLower x = \case+  _ :<->: u -> x :<->: u+  _ :<-|: u -> x :<-|: u+  _ :|->: u -> x :|->: u+  _ :|-|: u -> x :|-|: u++setUpper :: (Ord x) => Levitated x -> Interval x -> Interval x+setUpper x = \case+  l :<->: _ -> l :<->: x+  l :<-|: _ -> l :<-|: x+  l :|->: _ -> l :|->: x+  l :|-|: _ -> l :|-|: x++-- | Calculate the 'Adjacency' between two intervals, according to+-- [Allen](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra).+adjacency :: (Ord x) => Interval x -> Interval x -> Adjacency x+adjacency i1 i2 = case (comparing lower i1 i2, comparing upper i1 i2) of+  (LT, LT) -> case unSomeBound ub1 `compare` unSomeBound lb2 of+    LT -> Before i1 i2+    EQ -> case (ub1, lb2) of+      (SomeBound (Max _), SomeBound (Min _)) ->+        Meets+          (openUpper i1)+          (interval lb2 ub1)+          (openLower i2)+      _ -> Before i1 i2+    GT ->+      Overlaps+        (interval lb1 (oppose lb2))+        (interval lb2 ub1)+        (interval (oppose ub1) ub2)+  (LT, EQ) ->+    Finishes+      (interval lb1 (oppose lb2))+      i2+  (LT, GT) ->+    Contains+      (interval lb1 (oppose lb2))+      (interval lb2 ub2)+      (interval (oppose ub2) ub1)+  (EQ, LT) ->+    Starts+      i1+      (interval (oppose ub1) ub2)+  (EQ, EQ) -> Identical i1+  (EQ, GT) ->+    StartedBy+      i2+      (interval (oppose ub2) ub1)+  (GT, LT) ->+    During+      (interval lb2 (oppose lb1))+      (interval lb1 ub1)+      (interval (oppose ub1) ub2)+  (GT, EQ) ->+    FinishedBy+      (interval lb2 (oppose lb1))+      i1+  (GT, GT) -> case unSomeBound ub2 `compare` unSomeBound lb1 of+    GT ->+      OverlappedBy+        (interval lb2 (oppose lb1))+        (interval lb1 ub2)+        (interval (oppose ub2) ub1)+    EQ -> case (ub2, lb1) of+      (SomeBound (Max _), SomeBound (Min _)) ->+        MetBy+          (openUpper i2)+          (interval lb1 ub2)+          (openLower i1)+      _ -> After i2 i1+    LT -> After i2 i1+ where+  (lb1, ub1) = bounds i1+  (lb2, ub2) = bounds i2++-- | Calculate the intersection of two intervals, if it exists.+--+-- @+--+-- >>> intersect (2 :<>: 4) (3 :||: 5)+-- Just (Levitate 3 :|->: Levitate 4)+--+-- >>> intersect (2 :<>: 4) (4 :||: 5)+-- Nothing+--+-- >>> intersect (1 :<>: 4) (2 :||: 3)+-- Just (Levitate 2 :|-|: Levitate 3)+--+-- @+intersect ::+  forall x.+  (Ord x) =>+  Interval x ->+  Interval x ->+  Maybe (Interval x)+intersect i1 i2 = case adjacency i1 i2 of+  Before _ _ -> Nothing+  Meets _ j _ -> Just j+  Overlaps _ j _ -> Just j+  Starts i _ -> Just i+  During _ j _ -> Just j+  Finishes _ j -> Just j+  Identical i -> Just i+  FinishedBy _ j -> Just j+  Contains _ j _ -> Just j+  StartedBy i _ -> Just i+  OverlappedBy _ j _ -> Just j+  MetBy _ j _ -> Just j+  After _ _ -> Nothing++-- | Get the union of two intervals, as either 'OneOrTwo'.+--+-- @+--+-- >>> union (2 :||: 5) (5 :<>: 7)+-- One (Levitate 2 :|->: Levitate 7)+--+-- >>> union (2 :||: 4) (5 :<>: 7)+-- Two (Levitate 2 :|-|: Levitate 4) (Levitate 5 :<->: Levitate 7)+--+-- @+union ::+  forall x.+  (Ord x) =>+  Interval x ->+  Interval x ->+  OneOrTwo (Interval x)+union i1 i2 = case adjacency i1 i2 of+  Before i j+    | fst (upperBound i) == fst (lowerBound j) -> One $ hull i j+    | otherwise -> Two i j+  Meets i j k -> One $ hulls (k :| [hull i j])+  Overlaps i j k -> One $ hulls (i :| [j, k])+  Starts i j -> One $ hulls (i :| [j])+  During i j k -> One $ hulls (i :| [j, k])+  Finishes i j -> One $ hulls (i :| [j])+  Identical i -> One i+  FinishedBy i j -> One $ hulls (i :| [j])+  Contains i j k -> One $ hulls (i :| [j, k])+  StartedBy i j -> One $ hulls (i :| [j])+  OverlappedBy i j k -> One $ hulls (i :| [j, k])+  MetBy i j k -> One $ hulls (k :| [hull i j])+  After i j+    | fst (upperBound i) == fst (lowerBound j) -> One $ hull i j+    | otherwise -> Two i j++-- | /O(n log n)/. Get the union of a list of intervals.+--+-- This function uses 'sort'. See also 'unionsAsc'.+unions :: forall x. (Ord x) => [Interval x] -> [Interval x]+unions = unionsAsc . sort++-- | /O(n)/. Get the union of a sorted list of intervals.+--+-- NOTE: The input condition is not checked. Use with care.+unionsAsc :: forall x. (Ord x) => [Interval x] -> [Interval x]+unionsAsc = \case+  i : j : is -> case i `union` j of+    One k -> unions (k : is)+    _ -> i : unions (j : is)+  x -> x++-- | Take the complement of the interval, as possibly 'OneOrTwo'.+--+-- @+--+-- >>> complement (3 :<>: 4)+-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))+--+-- @+complement :: forall x. (Ord x) => Interval x -> Maybe (OneOrTwo (Interval x))+complement = \case+  Whole -> Nothing+  Bottom :|-|: u -> Just (One (u :<-|: Top))+  Bottom :|->: u -> Just (One (u :|-|: Top))+  Bottom :<-|: u -> Just (Two (Bottom :|-|: Bottom) (u :<-|: Top))+  Bottom :<->: u -> Just (Two (Bottom :|-|: Bottom) (u :|-|: Top))+  --+  l :|-|: Top -> Just (One (Bottom :|->: l))+  l :<-|: Top -> Just (One (Bottom :|-|: l))+  l :|->: Top -> Just (Two (Bottom :|->: l) (Top :|-|: Top))+  l :<->: Top -> Just (Two (Bottom :|-|: l) (Top :|-|: Top))+  --+  l :|-|: u -> Just (Two (Bottom :|->: l) (u :<-|: Top))+  l :|->: u -> Just (Two (Bottom :|->: l) (u :|-|: Top))+  l :<-|: u -> Just (Two (Bottom :|-|: l) (u :<-|: Top))+  l :<->: u -> Just (Two (Bottom :|-|: l) (u :|-|: Top))++-- | Remove all points of the second interval from the first.+--+-- @+--+-- >>> difference Whole (3 :<>: 4)+-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))+--+-- >>> difference (1 :<>: 4) (2 :||: 3)+-- Just (Two (Levitate 1 :<->: Levitate 2) (Levitate 3 :<->: Levitate 4))+--+-- @+difference ::+  forall x.+  (Ord x) =>+  Interval x ->+  Interval x ->+  Maybe (OneOrTwo (Interval x))+difference i1 i2 = case adjacency i1 i2 of+  -- not commutative!!+  Before i _ -> Just $ One i+  Meets i _ _ -> Just $ One i+  Overlaps i _ _ -> Just $ One i+  Starts{} -> Nothing+  During{} -> Nothing+  Finishes{} -> Nothing+  Identical{} -> Nothing+  FinishedBy i _ -> Just $ One i+  Contains i _ k -> Just $ Two i k+  StartedBy _ j -> Just $ One j+  OverlappedBy _ _ k -> Just $ One k+  MetBy i _ _ -> Just $ One i+  After i _ -> Just $ One i++-- | Infix synonym for 'difference'+(\\) ::+  forall x.+  (Ord x) =>+  Interval x ->+  Interval x ->+  Maybe (OneOrTwo (Interval x))+(\\) = difference++-- | The difference of the union and intersection of two intervals.+--+-- @+--+-- >>> symmetricDifference Whole (3 :<>: 4)+-- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top))+--+-- >>> symmetricDifference (1 :<>: 4) (2 :||: 3)+-- Just (Two (Levitate 1 :<->: Levitate 2) (Levitate 3 :<->: Levitate 4))+--+-- @+symmetricDifference ::+  forall x.+  (Ord x) =>+  Interval x ->+  Interval x ->+  Maybe (OneOrTwo (Interval x))+symmetricDifference i1 i2 = case i1 `union` i2 of+  Two j1 j2 -> Just (Two j1 j2)+  One u -> case i1 `intersect` i2 of+    Nothing -> Just (One u)+    Just i -> difference u i++-- | Get the measure of an interval.+--+-- @+--+-- >>> measure (-1 :<>: 1)+-- Just 2+--+-- >>> measure (Bottom :<->: Levitate 1)+-- Nothing+--+-- @+measure :: forall x. (Ord x, Num x) => Interval x -> Maybe x+measure = measuring subtract++-- | Apply a function to the lower, then upper, endpoint of an interval.+--+-- @+--+-- >>> measuring max (-1 :<>: 1)+-- Just 1+--+-- >>> measuring min (-1 :<>: 1)+-- Just (-1)+--+-- @+measuring ::+  forall y x. (Ord x, Num y) => (x -> x -> y) -> Interval x -> Maybe y+measuring f = \case+  Levitate l :|-|: Levitate u -> Just (f l u)+  Levitate l :|->: Levitate u -> Just (f l u)+  Levitate l :<-|: Levitate u -> Just (f l u)+  Levitate l :<->: Levitate u -> Just (f l u)+  l :|-|: u -> if l == u then Just 0 else Nothing+  l :|->: u -> if l == u then Just 0 else Nothing+  l :<-|: u -> if l == u then Just 0 else Nothing+  l :<->: u -> if l == u then Just 0 else Nothing++-- | Get the distance between two intervals, or 0 if they adjacency.+--+-- @+--+-- >>> hausdorff (3 :<>: 5) (6 :<>: 7)+-- Just 1+--+-- >>> hausdorff (3 :<>: 5) Whole+-- Just 0+--+-- @+hausdorff :: (Ord x, Num x) => Interval x -> Interval x -> Maybe x+hausdorff i1 i2 = case adjacency i1 i2 of+  Before i j ->+    foldLevitated Nothing Just Nothing $ on (liftA2 (-)) unSomeBound (lower j) (upper i)+  After i j ->+    foldLevitated Nothing Just Nothing $ on (liftA2 (-)) unSomeBound (lower j) (upper i)+  _ -> Just 0++-- | @m '+/-' r@ creates the closed interval centred at @m@ with radius @r@.+--+-- For the open interval, simply write @'open' (x '+/-' y)@.+(+/-) :: (Ord x, Num x) => x -> x -> Interval x+m +/- r = m - r :||: m + r
+ src/Data/Interval/Borel.hs view
@@ -0,0 +1,166 @@+module Data.Interval.Borel (+  Borel,+  borel,+  intervalSet,+  Data.Interval.Borel.empty,+  singleton,+  Data.Interval.Borel.null,+  insert,+  whole,+  cutout,+  member,+  notMember,+  union,+  unions,+  difference,+  symmetricDifference,+  complement,+  intersection,+  intersections,+  hull,+) where++import Algebra.Heyting+import Algebra.Lattice+import Data.Interval (Interval)+import Data.Interval qualified as I+import Data.OneOrTwo (OneOrTwo (..))+import Data.Semiring (Ring, Semiring)+import Data.Semiring qualified as Semiring+import Data.Set qualified as Set++-- | The 'Borel' sets on a type are the sets generated by its open intervals.+-- It forms a 'Heyting' algebra with 'union' as join and 'intersection' as meet,+-- and a 'Ring' with 'symmetricDifference' as addition and 'intersection' as+-- multiplication (and 'complement' as negation). In fact the algebra is Boolean+-- as the operation @x '==>' y = 'complement' x '\/' y@.+--+-- It is a monoid that is convenient for agglomerating+-- groups of intervals, such as for calculating the overall timespan+-- of a group of events. However, it is agnostic of+-- how many times each given point has been covered.+-- To keep track of this data, use 'Data.Interval.Layers'.+newtype Borel x = Borel (Set (Interval x))+  deriving (Eq, Ord, Show, Generic, Typeable)++instance (Ord x) => One (Borel x) where+  type OneItem _ = Interval x+  one = singleton++instance (Ord x) => Semigroup (Borel x) where+  Borel is <> Borel js = Borel (unionsSet (is <> js))++instance (Ord x) => Monoid (Borel x) where mempty = Borel mempty++instance (Ord x, Lattice x) => Lattice (Borel x) where+  (\/) = union+  (/\) = intersection++instance (Ord x, Lattice x) => BoundedMeetSemiLattice (Borel x) where+  top = whole++instance (Ord x, Lattice x) => BoundedJoinSemiLattice (Borel x) where+  bottom = mempty++instance (Ord x, Lattice x) => Heyting (Borel x) where+  x ==> y = complement x \/ y++instance (Ord x, Lattice x) => Semiring (Borel x) where+  plus = symmetricDifference+  times = intersection+  zero = mempty+  one = whole++instance (Ord x, Lattice x) => Ring (Borel x) where+  negate = complement++-- | Consider the 'Borel' set identified by a list of 'Interval's.+borel :: (Ord x) => [Interval x] -> Borel x+borel = Borel . Set.fromList . I.unions++-- | Turn a 'Borel' set into a 'Set.Set' of 'Interval's.+intervalSet :: (Ord x) => Borel x -> Set (Interval x)+intervalSet (Borel is) = unionsSet is++unionsSet :: (Ord x) => Set (Interval x) -> Set (Interval x)+unionsSet = Set.fromAscList . I.unionsAsc . Set.toAscList++-- | The empty 'Borel' set.+empty :: (Ord x) => Borel x+empty = Borel Set.empty++-- | The 'Borel' set consisting of a single 'Interval'.+singleton :: (Ord x) => Interval x -> Borel x+singleton x = Borel (Set.singleton x)++-- | Is this 'Borel' set empty?+null :: Borel x -> Bool+null (Borel is) = Set.null is++-- | Insert an 'Interval' into a 'Borel' set, agglomerating along the way.+insert :: (Ord x) => Interval x -> Borel x -> Borel x+insert i (Borel is) = Borel (unionsSet (Set.insert i is))++-- | The maximal 'Borel' set, that covers the entire range.+whole :: (Ord x) => Borel x+whole = Borel (Prelude.one I.Whole)++-- | Completely remove an 'Interval' from a 'Borel' set.+cutout :: (Ord x) => Interval x -> Borel x -> Borel x+cutout i (Borel is) =+  flip foldMap is $+    (I.\\ i) >>> \case+      Nothing -> mempty+      Just (One j) -> borel [j]+      Just (Two j k) -> borel [j, k]++-- | Is this point 'I.within' any connected component of the 'Borel' set?+member :: (Ord x) => x -> Borel x -> Bool+member x (Borel is) = any (I.within x) is++-- | Is this point not 'I.within' any connected component of the 'Borel' set?+notMember :: (Ord x) => x -> Borel x -> Bool+notMember x = not . member x++-- | A synonym for '(<>)'.+union :: (Ord x) => Borel x -> Borel x -> Borel x+union = (<>)++-- | A synonym for 'fold'.+unions :: (Ord x) => [Borel x] -> Borel x+unions = fold++-- | Remove all intervals of the second set from the first.+difference :: (Ord x) => Borel x -> Borel x -> Borel x+difference is (Borel js) = foldr cutout is js++-- | Take the symmetric difference of two 'Borel' sets.+symmetricDifference :: (Ord x) => Borel x -> Borel x -> Borel x+symmetricDifference is js = difference is js <> difference js is++-- | Take the 'Borel' set consisting of each point not in the given one.+complement :: (Ord x) => Borel x -> Borel x+complement = difference whole++-- | Given an 'Interval' @i@, @'clip' i@ will trim a 'Borel' set+-- so that its 'hull' is contained in @i@.+clip :: (Ord x) => Interval x -> Borel x -> Borel x+clip i (Borel js) =+  foldr ((<>) . maybe mempty one . I.intersect i) mempty js++-- | Take the intersection of two 'Borel' sets.+intersection :: (Ord x) => Borel x -> Borel x -> Borel x+intersection is (Borel js) = foldMap (`clip` is) js++-- | Take the intersection of a list of 'Borel' sets.+intersections :: (Ord x) => [Borel x] -> Borel x+intersections [] = mempty+intersections [i] = i+intersections (i : j : js) = intersection (intersection i j) (intersections js)++-- | Take the smallest spanning 'Interval' of a 'Borel' set,+-- provided that it is not the empty set.+hull :: (Ord x) => Borel x -> Maybe (Interval x)+hull (Borel is)+  | Set.null is = Nothing+  | otherwise = Just $ uncurry (foldr I.hull) (Set.deleteFindMin is)
+ src/Data/Interval/Layers.hs view
@@ -0,0 +1,158 @@+module Data.Interval.Layers (+  Layers,+  Data.Interval.Layers.fromList,+  Data.Interval.Layers.toList,+  empty,+  singleton,+  insert,+  squash,+  thickness,+  thickest,+  remove,+  baseline,++  -- ** Helper functions+  nestings,+  nestingsAsc,+) where++import Data.Group (Group (..))+import Data.Interval (Adjacency (..), Interval, pattern Whole, pattern (:<>:))+import Data.Interval qualified as I+import Data.Interval.Borel (Borel)+import Data.Interval.Borel qualified as Borel+import Data.Map.Strict qualified as Map+import Prelude hiding (empty)++-- The 'Layers' of an ordered type @x@ are like the 'Borel' sets,+-- but that keeps track of how far each point has been "raised" in @y@.+newtype Layers x y = Layers (Map (Interval x) y)+  deriving+    ( Eq+    , Ord+    , Show+    , Functor+    , Generic+    , Typeable+    )++instance (Ord x, Semigroup y) => Semigroup (Layers x y) where+  Layers s1 <> Layers s2 =+    let s = Map.toAscList $ Map.unionWith (<>) s1 s2+     in Layers $ Map.fromAscList (nestingsAsc s)++instance (Ord x, Semigroup y) => Monoid (Layers x y) where+  mempty = Layers mempty++instance (Ord x, Group y) => Group (Layers x y) where+  invert (Layers s) = Layers (fmap invert s)++-- | A blank canvas.+empty :: Layers x y+empty = Layers Map.empty++-- | @singleton ix y@ is the rectangle with base @ix@ of thickness @y@.+singleton :: (Ord x) => Interval x -> y -> Layers x y+singleton ix y = Layers (Map.singleton ix y)++-- | Draw the 'Layers' of specified bases and thicknesses.+fromList :: (Ord x, Semigroup y) => [(Interval x, y)] -> Layers x y+fromList = foldMap (uncurry singleton)++-- | Get all of the bases and thicknesses in the 'Layers'.+toList :: (Ord x) => Layers x y -> [(Interval x, y)]+toList (Layers s) = Map.toList s++-- | Ignore the 'Layers' and focus only on whether points are 'within'+-- any contained 'Interval' or not.+squash :: (Ord x) => Layers x y -> Borel x+squash (Layers s) = foldMap Borel.singleton (Map.keys s)++-- | Get the thickness of the 'Layers' at a point.+thickness :: (Ord x, Monoid y) => x -> Layers x y -> y+thickness x (Layers s) = case Map.lookupLE (x :<>: x) s of+  Just (ix, y) | x `I.within` ix -> y+  _ -> mempty++-- | Where and how thick is the thickest 'Interval'?+thickest :: (Ord x, Ord y) => Layers x y -> Maybe (Interval x, y)+thickest (Layers s) =+  Map.foldlWithKey'+    ( \acc ix y -> Just $ case acc of+        Nothing -> (ix, y)+        Just (ix', y') -> if y > y' then (ix, y) else (ix', y')+    )+    Nothing+    s++-- | @insert ix y l@ draws over @l@ a rectangle with base @ix@ of thickness @y@.+insert ::+  (Ord x, Semigroup y) =>+  Interval x ->+  y ->+  Layers x y ->+  Layers x y+insert ix y = mappend (singleton ix y)++nestings ::+  (Ord x, Semigroup y) =>+  [(Interval x, y)] ->+  [(Interval x, y)]+nestings = nestingsAsc . sortOn fst++nestingsAsc ::+  (Ord x, Semigroup y) =>+  [(Interval x, y)] ->+  [(Interval x, y)]+nestingsAsc = \case+  (i', iy) : (j', jy) : js -> case I.adjacency i' j' of+    Before i j -> (i, iy) : nestingsAsc ((j, jy) : js)+    Meets i j k -> (i, iy) : nestingsAsc ((j, iy <> jy) : (k, jy) : js)+    Overlaps i j k ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) :+        (k, jy) : js+    Starts i j ->+      nestingsAsc $+        (i, iy <> jy) :+        (j, jy) : js+    During i j k ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) :+        (k, jy) : js+    Finishes i j ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) : js+    Identical i -> (i, iy <> jy) : nestingsAsc js+    FinishedBy i j ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) : js+    Contains i j k ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) :+        (k, jy) : js+    StartedBy i j ->+      nestingsAsc $+        (i, iy <> jy) :+        (j, jy) : js+    OverlappedBy i j k ->+      nestingsAsc $+        (i, iy) :+        (j, iy <> jy) :+        (k, jy) : js+    MetBy i j k -> (i, iy) : nestingsAsc ((j, iy <> jy) : (k, jy) : js)+    After i j -> (i, iy) : nestingsAsc ((j, jy) : js)+  x -> x++-- | Take away a thickness over a given base from the 'Layers'.+remove :: (Ord x, Group y) => y -> Interval x -> Layers x y -> Layers x y+remove y ix = insert ix (invert y)++-- | Add the given thickness to every point.+baseline :: (Ord x, Semigroup y) => y -> Layers x y -> Layers x y+baseline = insert Whole
+ src/Data/OneOrTwo.hs view
@@ -0,0 +1,32 @@+module Data.OneOrTwo (+  OneOrTwo (..),+  oneOrTwo,+) where++import Data.Data (Data)++-- | Either one of something, or two of it.+--+-- Use 'oneOrTwo' to deconstruct.+data OneOrTwo x+  = One !x+  | Two !x !x+  deriving+    ( Eq+    , Ord+    , Show+    , Read+    , Generic+    , Data+    , Typeable+    , Functor+    , Foldable+    , Traversable+    )++-- | Apply a 'oneOrTwo' argument function appropriately.+oneOrTwo :: (x -> a) -> (x -> x -> a) -> OneOrTwo x -> a+oneOrTwo f g = \case+  One x -> f x+  Two x y -> g x y+{-# INLINE oneOrTwo #-}
+ src/Data/Timeframe.hs view
@@ -0,0 +1,77 @@+module Data.Timeframe (+  Timeframe,+  module Data.Interval,+  localTimeframeAt,+  localTimeframe,+  pureLocalTimeframe,+  duration,+  Event,+  event,+  Calendar (..),+  singleton,+  calendar,+  addEvent,+  totalDuration,+) where++import Data.Interval+import Data.Interval.Layers (Layers)+import Data.Interval.Layers qualified as Layers+import Data.Map.Strict qualified as Map+import Data.Time.Compat+import GHC.IO (unsafePerformIO)++-- | > type Timeframe = Interval UTCTime+type Timeframe = Interval UTCTime++localTimeframeAt :: TimeZone -> LocalTime -> LocalTime -> Timeframe+localTimeframeAt = on (:||:) . localTimeToUTC++localTimeframe :: (MonadIO io) => LocalTime -> LocalTime -> io Timeframe+localTimeframe t1 t2 =+  liftIO getCurrentTimeZone <&> \tz -> localTimeframeAt tz t1 t2++pureLocalTimeframe :: LocalTime -> LocalTime -> Timeframe+pureLocalTimeframe t1 t2 =+  let tz = unsafePerformIO getCurrentTimeZone+   in localTimeframeAt tz t1 t2++duration :: Timeframe -> Maybe NominalDiffTime+duration = measuring diffUTCTime++-- | An 'Event' is something that happens for a period of time.+--+-- > type Event = Layers UTCTime+type Event = Layers UTCTime (Sum Int)++event :: Timeframe -> Event+event = (`Layers.singleton` 1)++newtype Calendar ev = Calendar {getCalendar :: Map ev Event}+  deriving (Eq, Ord, Show, Typeable)++instance (Ord ev) => Semigroup (Calendar ev) where+  Calendar a <> Calendar b = Calendar (Map.unionWith (<>) a b)++instance (Ord ev) => Monoid (Calendar ev) where+  mempty = Calendar mempty++singleton :: (Ord ev) => ev -> Event -> Calendar ev+singleton ev cvg = Calendar (Map.singleton ev cvg)++calendar :: (Ord ev) => ev -> Timeframe -> Calendar ev+calendar ev tf = singleton ev (Layers.singleton tf 1)++addEvent :: (Ord ev) => ev -> Event -> Calendar ev -> Calendar ev+addEvent ev cvg (Calendar c) = Calendar (Map.insertWith (<>) ev cvg c)++totalDuration :: (Ord ev) => ev -> Calendar ev -> Maybe NominalDiffTime+totalDuration ev (Calendar c) = case c Map.!? ev of+  Nothing -> Just 0+  Just is -> foldr f (Just 0) (Layers.toList is)+ where+  f :: (Timeframe, Sum Int) -> Maybe NominalDiffTime -> Maybe NominalDiffTime+  f _ Nothing = Nothing+  f (tf, Sum n) (Just x) = case (fromIntegral n *) <$> duration tf of+    Nothing -> Nothing+    Just y -> Just (x + y)
+ tests/Main.hs view
@@ -0,0 +1,72 @@+module Main where++import Algebra.Lattice.Levitated (Levitated (..))+import Data.Interval (+  Interval,+  pattern (:<->:),+  pattern (:<-|:),+  pattern (:<>:),+  pattern (:<|:),+  pattern (:|->:),+  pattern (:|-|:),+  pattern (:|>:),+  pattern (:||:),+ )+import Data.Interval.Borel qualified as Borel+import Test.Hspec+import Test.QuickCheck++main :: IO ()+main = hspec $ do+  describe "smart constructors" $ do+    it "orients finite intervals" $ do+      property @(Int -> Int -> _) $ \x y -> do+        if x <= y+          then do+            (x :<>: y) `shouldBe` (x :<>: y)+            (x :|>: y) `shouldBe` (x :|>: y)+            (x :<|: y) `shouldBe` (x :<|: y)+            (x :||: y) `shouldBe` (x :||: y)+            (Levitate x :<->: Levitate y) `shouldBe` (Levitate x :<->: Levitate y)+            (Levitate x :|->: Levitate y) `shouldBe` (Levitate x :|->: Levitate y)+            (Levitate x :<-|: Levitate y) `shouldBe` (Levitate x :<-|: Levitate y)+            (Levitate x :|-|: Levitate y) `shouldBe` (Levitate x :|-|: Levitate y)+          else do+            (x :<>: y) `shouldBe` (y :<>: x)+            (x :|>: y) `shouldBe` (y :<|: x)+            (x :<|: y) `shouldBe` (y :|>: x)+            (x :||: y) `shouldBe` (y :||: x)+            (Levitate x :<->: Levitate y) `shouldBe` (Levitate y :<->: Levitate x)+            (Levitate x :|->: Levitate y) `shouldBe` (Levitate y :<-|: Levitate x)+            (Levitate x :<-|: Levitate y) `shouldBe` (Levitate y :|->: Levitate x)+            (Levitate x :|-|: Levitate y) `shouldBe` (Levitate y :|-|: Levitate x)++    it "orients infinite intervals" $ do+      (Top :<->: Bottom) `shouldBe` (Bottom :<->: Top :: Interval Int)+      (Top :|->: Bottom) `shouldBe` (Bottom :<-|: Top :: Interval Int)+      (Top :<-|: Bottom) `shouldBe` (Bottom :|->: Top :: Interval Int)+      (Top :|-|: Bottom) `shouldBe` (Bottom :|-|: Top :: Interval Int)++    it "closes point intervals" $ do+      property @(Int -> _) $ \x -> do+        (x :<>: x) `shouldBe` (x :||: x)+        (x :|>: x) `shouldBe` (x :||: x)+        (x :<|: x) `shouldBe` (x :||: x)+        (x :||: x) `shouldBe` (x :||: x)+        (Levitate x :<->: Levitate x) `shouldBe` (Levitate x :|-|: Levitate x)+        (Levitate x :|->: Levitate x) `shouldBe` (Levitate x :|-|: Levitate x)+        (Levitate x :<-|: Levitate x) `shouldBe` (Levitate x :|-|: Levitate x)+        (Levitate x :|-|: Levitate x) `shouldBe` (Levitate x :|-|: Levitate x)++  describe "Borel intervals" $ do+    it "(<>) is commutative" $ do+      property @(Int -> Int -> Int -> Int -> _) $ \a b x y -> do+        let abxy = Borel.singleton (a :<>: b) <> Borel.singleton (x :<>: y)+            xyab = Borel.singleton (x :<>: y) <> Borel.singleton (a :<>: b)+        abxy `shouldBe` xyab+    it "(<>) is associative" $ do+      property @(Int -> Int -> Int -> Int -> Int -> Int -> _) $ \a b m n x y -> do+        let ab = Borel.singleton (a :<>: b)+            mn = Borel.singleton (m :<>: n)+            xy = Borel.singleton (x :<>: y)+        (ab <> mn) <> xy `shouldBe` ab <> (mn <> xy)