packages feed

interval-patterns 0.3.0.1 → 0.4.0.0

raw patch · 7 files changed

+433/−186 lines, 7 files

Files

CHANGELOG.md view
@@ -1,5 +1,36 @@ # Revision history for interval-patterns +## 0.4.0.0 - 2022-07-*++* New functions+  * unidirectional `pattern (:--:)` for matching finite intervals regardless of `Bound`+  * `Data.Interval.Layers.integrate` for calculating areas+  * `Data.Calendar.erlangs` for calculating carried load+  * `pile`, flipped synonym for `Data.Interval.Layers.insert`+  * rename `Data.Interval.Borel.cutout` to `remove`, flipped infix synonym `(\-)`+  * rename `Data.Interval.Borel.clip` to `truncate`, flipped infix synonym `(\=)`+  * rename previous `Data.Interval.Layers.remove` to `dig`+  * new function `Data.Interval.Layers.remove` akin to `Borel`, flipped infix synonym `(\-)`+  * rename `Data.Interval.Layers.clip` to `truncate`, flipped infix synonym `(\=)`+* New instances+  * `Data`, `Typeable`, `Generic` instances for `Interval`+  * `Data` instance for `Adjacency`+* Minor improvements+  * better implementation of `unions`+  * fix comparison order in `compareBounds`+  * removed `compareBounds`' forced restriction to `Levitated`+  * `imin`, `iinf`, `isup`, `imax` no longer return `Bound`s+  * fix `difference` in cases `MetBy` and `After`+  * fix regression in smart constructor ordering+  * fix `within` on boundaries+  * add example to `measuring`+  * improve implementation of `unionsAsc`+  * better `Show` instance for finite intervals++## 0.3.1.0 - 2022-07-13++* re-export `OneOrTwo` from `Data.Interval`+ ## 0.3.0.1 - 2022-06-08  * expose `Data.Calendar` lol
interval-patterns.cabal view
@@ -1,8 +1,10 @@ cabal-version: 3.0 name: interval-patterns-version: 0.3.0.1+version: 0.4.0.0 author: Melanie Brown-description: A library for easy manipulation of intervals according to their overlap.+synopsis: Intervals, and monoids thereof+description: Please see the README at https://github.com/mixphix/interval-patterns+category: Algebra, Charts, Data Structures, Math, Statistics maintainer: brown.m@pm.me license: BSD-3-Clause license-file: LICENSE
src/Data/Calendar.hs view
@@ -3,6 +3,7 @@   Event,   event,   eventSize,+  erlangs,   Calendar (..),   singleton,   calendar,@@ -15,6 +16,7 @@   totalDuration, ) where +import Data.Interval qualified as I import Data.Interval.Layers (Layers) import Data.Interval.Layers qualified as Layers import Data.Map.Strict qualified as Map@@ -37,6 +39,18 @@ eventSize :: (Num n) => n -> Timeframe -> Event n eventSize n = (`Layers.singleton` Sum n) +-- |+-- Measure the carried load of an 'Event' over a given 'Timeframe'.+-- In other words: how many copies of you would you need, in order to attend+-- all of the simultaneous happenings over a given span (on average)?+erlangs :: (Real n) => Timeframe -> Event n -> Maybe Rational+erlangs ix e =+  let diff = realToFrac <<$>> diffUTCTime+   in liftA2+        (/)+        (Layers.integrate diff (realToFrac . getSum) ix e)+        (I.measuring diff ix)+ -- | A 'Calendar' is a map from a given event type to durations. newtype Calendar ev n = Calendar {getCalendar :: Map ev (Event n)}   deriving (Eq, Ord, Show, Typeable)@@ -63,27 +77,38 @@ insert :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n insert ev cvg (Calendar c) = Calendar (Map.insertWith (<>) ev cvg c) --- | Get the 'Event' corresponding to a given key, or 'Nothing' if the key is not present.+-- |+-- Get the 'Event' corresponding to a given key,+-- or 'Nothing' if the key is not present. (!?) :: (Ord ev, Num n) => Calendar ev n -> ev -> Maybe (Event n) Calendar c !? ev = c Map.!? ev --- | Get the 'Event' corresponding to a given key, or 'mempty' if the key is not present.+-- |+-- Get the 'Event' corresponding to a given key,+-- or 'mempty' if the key is not present. (!) :: (Ord ev, Num n) => Calendar ev n -> ev -> Event n Calendar c ! ev = c Map.!? ev ?: mempty  toList :: (Ord ev, Num n) => Calendar ev n -> [(ev, [(Interval UTCTime, n)])] toList (Calendar c) = fmap getSum <<$>> Layers.toList <<$>> Map.assocs c --- | What any how many events are happening at the given 'UTCTime' on this 'Calendar'?+-- |+-- What, and how many events are happening+-- at the given 'UTCTime' on this 'Calendar'? happeningAt :: (Ord ev, Num n) => UTCTime -> Calendar ev n -> [(ev, n)] happeningAt time (Data.Calendar.toList -> evs) =   [(ev, n) | (ev, ns) <- evs, (_, n) <- filter (within time . fst) ns] --- | Consider every kind of event the same, and only observe the overall 'Layers'.+-- | Consider every kind of event the same, and observe the overall 'Layers'. coalesce :: (Ord ev, Num n) => Calendar ev n -> Event n coalesce (Calendar c) = fold c -totalDuration :: forall ev n. (Ord ev, Real n) => ev -> Calendar ev n -> Maybe NominalDiffTime+totalDuration ::+  forall ev n.+  (Ord ev, Real n) =>+  ev ->+  Calendar ev n ->+  Maybe NominalDiffTime totalDuration ev (Calendar c) = case c Map.!? ev of   Nothing -> Just 0   Just is -> foldr f (Just 0) (Layers.toList is)
src/Data/Interval.hs view
@@ -28,6 +28,7 @@   pattern (:<|:),   pattern (:|>:),   pattern (:||:),+  pattern (:--:),   pattern Whole,   (+/-),   (...),@@ -70,11 +71,13 @@   measuring,   hausdorff,   isSubsetOf,+  OneOrTwo (..), ) where  import Algebra.Lattice.Levitated-import Data.Data (Data)+import Data.Data import Data.OneOrTwo (OneOrTwo (..))+import GHC.Generics hiding (Infix) import GHC.Show qualified (show)  -- | The kinds of extremum an interval can have.@@ -85,8 +88,10 @@   | 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.+-- |+-- The 'opposite' of an 'Extremum' is its complementary analogue:+-- how the same point would be viewed from the complement of the+-- interval to which it belongs. -- -- c.f. 'opposeBound'. opposite :: Extremum -> Extremum@@ -144,11 +149,7 @@  -- | A type class for inverting 'Bound's. type Bounding :: Extremum -> Constraint-class-  ( Opposite (Opposite ext) ~ ext-  ) =>-  Bounding ext-  where+class (Opposite (Opposite ext) ~ ext) => Bounding ext where   type Opposite ext :: Extremum   bound :: x -> Bound ext x @@ -177,13 +178,20 @@  -- | '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 (Min (Levitate 5)) (Max (Levitate 5))+-- EQ+-- >>> compareBounds (Inf (Levitate 5)) (Sup (Levitate 5))+-- GT+-- >>> compareBounds (Max (Levitate 5)) (Sup (Levitate 5))+-- GT+-- >>> compareBounds (Inf (Levitate 5)) (Min (Levitate 5))+-- GT+-- >>> compareBounds (Max (Levitate 5)) (Inf (Levitate 5))+-- LT compareBounds ::   (Ord x) =>-  Bound ext1 (Levitated x) ->-  Bound ext2 (Levitated x) ->+  Bound ext1 x ->+  Bound ext2 x ->   Ordering compareBounds (Min l) = \case   Min ll -> compare l ll@@ -195,16 +203,16 @@   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+compareBounds (Sup l) = \case+  Min u -> compare l u <> LT+  Inf u -> compare l u <> LT+  Sup uu -> compare l uu+  Max uu -> compare l uu <> LT+compareBounds (Max l) = \case+  Min u -> compare l u+  Inf u -> compare l u <> LT+  Sup uu -> compare l uu <> GT+  Max uu -> compare l uu  data SomeBound x   = forall ext.@@ -262,64 +270,6 @@     !(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.-imapLev ::-  (Ord x, Ord y) =>-  (Levitated x -> Levitated y) ->-  Interval x ->-  Interval y-imapLev 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.-itraverseLev ::-  (Ord x, Ord y, Applicative f) =>-  (Levitated x -> f (Levitated y)) ->-  Interval x ->-  f (Interval y)-itraverseLev 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 :<-|:@@ -328,7 +278,7 @@  infix 5 :|-|: --- | A pattern synonym matching open intervals.+-- | A bidirectional pattern synonym matching open intervals. pattern (:<->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x pattern l :<->: u <-   Inf l :<-->: Sup u@@ -340,7 +290,7 @@             EQ -> Min inf :|--|: Max sup             _ -> Inf inf :<-->: Sup sup --- | A pattern synonym matching open-closed intervals.+-- | A bidirectional pattern synonym matching open-closed intervals. pattern (:<-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x pattern l :<-|: u <-   Inf l :<--|: Max u@@ -353,7 +303,7 @@             EQ -> Min inf :|--|: Max sup             GT -> Min inf :|-->: Sup sup --- | A pattern synonym matching closed-open intervals.+-- | A bidirectional pattern synonym matching closed-open intervals. pattern (:|->:) :: (Ord x) => Levitated x -> Levitated x -> Interval x pattern l :|->: u <-   Min l :|-->: Sup u@@ -366,7 +316,7 @@             EQ -> Min inf :|--|: Max sup             GT -> Inf inf :<--|: Max sup --- | A pattern synonym matching closed intervals.+-- | A bidirectional pattern synonym matching closed intervals. pattern (:|-|:) :: (Ord x) => Levitated x -> Levitated x -> Interval x pattern l :|-|: u <-   Min l :|--|: Max u@@ -375,8 +325,10 @@  {-# COMPLETE (:<->:), (:<-|:), (:|->:), (:|-|:) #-} +-- | A unidirectional pattern synonym ignoring the particular 'Bound's. pattern (:---:) :: forall x. (Ord x) => Levitated x -> Levitated x -> Interval x-pattern l :---: u <- (bounds -> (SomeBound (unBound -> l), SomeBound (unBound -> u)))+pattern l :---: u <-+  (bounds -> (SomeBound (unBound -> l), SomeBound (unBound -> u)))  {-# COMPLETE (:---:) #-} @@ -388,53 +340,198 @@  infix 5 :||: --- | A pattern synonym matching finite open intervals.+-- | A bidirectional pattern synonym matching finite open intervals. pattern (:<>:) :: forall x. (Ord x) => x -> x -> Interval x-pattern l :<>: u <- -- Levitate l :<->: Levitate u+pattern l :<>: 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+       in case compare b1 b2 of             EQ -> Min inf :|--|: Max sup             _ -> Inf inf :<-->: Sup sup --- | A pattern synonym matching finite open-closed intervals.+-- | A bidirectional pattern synonym matching finite open-closed intervals. pattern (:<|:) :: forall x. (Ord x) => x -> x -> Interval x-pattern l :<|: u <- -- Levitate l :<-|: Levitate u+pattern l :<|: 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+       in case compare b1 b2 of+            LT -> Inf inf :<--|: Max sup             EQ -> Min inf :|--|: Max sup-            _ -> Inf inf :<--|: Max sup+            GT -> Min inf :|-->: Sup sup --- | A pattern synonym matching finite closed-open intervals.+-- | A bidirectional pattern synonym matching finite closed-open intervals. pattern (:|>:) :: forall x. (Ord x) => x -> x -> Interval x-pattern l :|>: u <- -- Levitate l :|->: Levitate u+pattern l :|>: 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+       in case compare b1 b2 of+            LT -> Min inf :|-->: Sup sup             EQ -> Min inf :|--|: Max sup-            _ -> Min inf :|-->: Sup sup+            GT -> Inf inf :<--|: Max sup --- | A pattern synonym matching finite closed intervals.+-- | A bidirectional pattern synonym matching finite closed intervals. pattern (:||:) :: forall x. (Ord x) => x -> x -> Interval x-pattern l :||: u <- -- Levitate l :|-|: Levitate u+pattern l :||: u <-   Levitate l :|-|: Levitate u   where     b1 :||: b2 = Min (Levitate $ min b1 b2) :|--|: Max (Levitate $ max b1 b2) +-- |+-- A unidirectional pattern synonym matching finite intervals,+-- that ignores the particular 'Bound's.+pattern (:--:) :: forall x. (Ord x) => x -> x -> Interval x+pattern l :--: u <-+  ( bounds ->+      (SomeBound (unBound -> Levitate l), SomeBound (unBound -> Levitate u))+    )+ -- | The whole interval. pattern Whole :: (Ord x) => Interval x pattern Whole = Bottom :|-|: Top +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 <> ")"+    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++instance (Ord x, Data x) => Data (Interval x) where+  gfoldl (<^>) gpure = \case+    l :<->: u -> gpure (:<->:) <^> l <^> u+    l :|->: u -> gpure (:|->:) <^> l <^> u+    l :<-|: u -> gpure (:<-|:) <^> l <^> u+    l :|-|: u -> gpure (:|-|:) <^> l <^> u+  toConstr = \case+    _ :<->: _ -> intervalOpenOpenConstr+    _ :|->: _ -> intervalClosedOpenConstr+    _ :<-|: _ -> intervalOpenClosedConstr+    _ :|-|: _ -> intervalClosedClosedConstr+  dataTypeOf _ = intervalDataType+  gunfold k gpure constr = case constrIndex constr of+    0 -> k (k (gpure (:<->:)))+    1 -> k (k (gpure (:|->:)))+    2 -> k (k (gpure (:<-|:)))+    3 -> k (k (gpure (:|-|:)))+    _ -> error "gunfold"++intervalOpenOpenConstr :: Constr+intervalOpenOpenConstr =+  mkConstr+    intervalDataType+    ":<--->:"+    []+    Infix++intervalClosedOpenConstr :: Constr+intervalClosedOpenConstr =+  mkConstr+    intervalDataType+    ":|--->:"+    []+    Infix++intervalOpenClosedConstr :: Constr+intervalOpenClosedConstr =+  mkConstr+    intervalDataType+    ":<---|:"+    []+    Infix++intervalClosedClosedConstr :: Constr+intervalClosedClosedConstr =+  mkConstr+    intervalDataType+    ":|---|:"+    []+    Infix++intervalDataType :: DataType+intervalDataType =+  mkDataType+    "Data.Interval.Interval"+    [ intervalOpenOpenConstr+    , intervalClosedOpenConstr+    , intervalOpenClosedConstr+    , intervalClosedClosedConstr+    ]++deriving instance Typeable x => Typeable (Interval x)++instance (Ord x, Generic x) => Generic (Interval x) where+  type Rep (Interval x) = (Const (Levitated x, Extremum) :*: Const (Levitated x, Extremum))+  from = \case+    l :<->: u -> (Const (l, Infimum) :*: Const (u, Supremum))+    l :|->: u -> (Const (l, Minimum) :*: Const (u, Supremum))+    l :<-|: u -> (Const (l, Infimum) :*: Const (u, Maximum))+    l :|-|: u -> (Const (l, Minimum) :*: Const (u, Maximum))+  to (Const l :*: Const u) = l ... u++-- | 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.+imapLev ::+  (Ord x, Ord y) =>+  (Levitated x -> Levitated y) ->+  Interval x ->+  Interval y+imapLev 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.+itraverseLev ::+  (Ord x, Ord y, Applicative f) =>+  (Levitated x -> f (Levitated y)) ->+  Interval x ->+  f (Interval y)+itraverseLev 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)+ -- | Get the @(lower, upper)@ 'bounds' of an 'Interval'. -- -- c.f. 'lower', 'upper'.@@ -531,7 +628,7 @@   | 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)+  deriving (Eq, Ord, Show, Generic, Typeable, Data)  -- | The result of having compared the same two intervals in reverse order. converseAdjacency :: Adjacency x -> Adjacency x@@ -553,10 +650,10 @@ -- | Get the convex hull of two intervals. -- -- >>> hull (7 :|>: 8) (3 :|>: 4)--- (Levitate 3 :|->: Levitate 8)+-- (3 :|>: 8) ----- >>> hull (Bottom :<-|: 3) (3 :<|: 4)--- (Bottom :<-|: Levitate 4)+-- >>> hull (Bottom :<-|: Levitate 3) (4 :<>: 5)+-- (Bottom :<->: Levitate 5) 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@@ -572,33 +669,37 @@  -- | Test whether a point is contained in the interval. within :: (Ord x) => x -> Interval x -> Bool-within (Levitate -> x) (l :---: u) = l < x && x < u+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 infimum of an interval, weakening if necessary.-iinf :: (Ord x) => Interval x -> Bound Infimum (Levitated x)-iinf (x :---: _) = Inf x+iinf :: (Ord x) => Interval x -> Levitated x+iinf (x :---: _) = x  -- | Get the minimum of an interval, if it exists.-imin :: (Ord x) => Interval x -> Maybe (Bound Minimum (Levitated x))+imin :: (Ord x) => Interval x -> Maybe (Levitated x) imin = \case-  (x :|-->: _) -> Just x-  (x :|--|: _) -> Just x+  (x :|->: _) -> Just x+  (x :|-|: _) -> Just x   _ -> Nothing  -- | Get the maximum of an interval if it exists.-imax :: (Ord x) => Interval x -> Maybe (Bound Maximum (Levitated x))+imax :: (Ord x) => Interval x -> Maybe (Levitated x) imax = \case-  (_ :<--|: x) -> Just x-  (_ :|--|: x) -> Just x+  (_ :<-|: x) -> Just x+  (_ :|-|: x) -> Just x   _ -> Nothing  -- | Get the supremum of an interval, weakening if necessary.-isup :: (Ord x) => Interval x -> Bound Supremum (Levitated x)-isup (_ :---: x) = Sup x+isup :: (Ord x) => Interval x -> Levitated x+isup (_ :---: x) = x  -- | Open both bounds of the given interval. open :: (Ord x) => Interval x -> Interval x@@ -730,13 +831,13 @@ -- @ -- -- >>> intersect (2 :<>: 4) (3 :||: 5)--- Just (Levitate 3 :|->: Levitate 4)+-- Just (3 :|>: 4) -- -- >>> intersect (2 :<>: 4) (4 :||: 5) -- Nothing -- -- >>> intersect (1 :<>: 4) (2 :||: 3)--- Just (Levitate 2 :|-|: Levitate 3)+-- Just (2 :||: 3) -- -- @ intersect ::@@ -781,17 +882,17 @@   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])+  Meets i _ k -> One $ hull i k+  Overlaps i _ k -> One $ hull i k+  Starts i j -> One $ hull i j+  During i _ k -> One $ hull i k+  Finishes i j -> One $ hull 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])+  FinishedBy i j -> One $ hull i j+  Contains i _ k -> One $ hull i k+  StartedBy i j -> One $ hull i j+  OverlappedBy i _ k -> One $ hull i k+  MetBy i _ k -> One $ hull i k   After i j     | fst (upperBound i) == fst (lowerBound j) -> One $ hull i j     | otherwise -> Two i j@@ -808,8 +909,8 @@ 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)+    One k -> unionsAsc (k : is)+    _ -> i : unionsAsc (j : is)   x -> x  -- | Take the complement of the interval, as possibly 'OneOrTwo'.@@ -830,7 +931,11 @@ -- Just (Two (Bottom :|-|: Levitate 3) (Top :|-|: Top)) -- -- @-complement :: forall x. (Ord x) => Interval x -> Maybe (OneOrTwo (Interval x))+complement ::+  forall x.+  (Ord x) =>+  Interval x ->+  Maybe (OneOrTwo (Interval x)) complement = \case   Whole -> Nothing   Bottom :|-|: u -> Just (One (u :<-|: Top))@@ -856,8 +961,14 @@ -- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top)) -- -- >>> difference (1 :<>: 4) (2 :||: 3)--- Just (Two (Levitate 1 :<->: Levitate 2) (Levitate 3 :<->: Levitate 4))+-- Just (Two (1 :<>: 2) (3 :<>: 4)) --+-- >>> difference (1 :|>: 4) (0 :||: 1)+-- Just (One (1 :<>: 4))+--+-- >>> difference (1 :<>: 4) (0 :||: 1)+-- Just (One (1 :<>: 4))+-- -- @ difference ::   forall x.@@ -878,8 +989,8 @@   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+  MetBy _ _ k -> Just $ One k+  After _ j -> Just $ One j  -- | Infix synonym for 'difference' (\\) ::@@ -898,7 +1009,7 @@ -- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top)) -- -- >>> symmetricDifference (1 :<>: 4) (2 :||: 3)--- Just (Two (Levitate 1 :<->: Levitate 2) (Levitate 3 :<->: Levitate 4))+-- Just (Two (1 :<>: 2) (3 :<>: 4)) -- -- @ symmetricDifference ::@@ -937,12 +1048,21 @@ -- >>> measuring min (-1 :<>: 1) -- Just (-1) --+-- >>> measuring (*) (4 :<>: 6)+-- Just 24+-- -- @ measuring ::-  forall y x. (Ord x, Num y) => (x -> x -> y) -> Interval x -> Maybe y+  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)-  l :---: u -> if l == u then Just 0 else Nothing+  l :---: u+    | l == u -> Just 0+    | otherwise -> Nothing  -- | Get the distance between two intervals, or 0 if they adjacency. --@@ -957,11 +1077,11 @@ -- @ 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)+  Before (_ :---: a) (b :---: _) -> levMaybe $ liftA2 (-) b a+  After (_ :---: a) (b :---: _) -> levMaybe $ liftA2 (-) b a   _ -> Just 0+ where+  levMaybe = foldLevitated Nothing Just Nothing  -- | @m '+/-' r@ creates the closed interval centred at @m@ with radius @r@. --
src/Data/Interval/Borel.hs view
@@ -7,8 +7,10 @@   Data.Interval.Borel.null,   insert,   whole,-  cutout,-  clip,+  remove,+  (\-),+  truncate,+  (\=),   member,   notMember,   union,@@ -22,16 +24,18 @@   isSubsetOf, ) where -import Algebra.Heyting+import Algebra.Heyting (Heyting ((==>))) import Algebra.Lattice+import Data.Data 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+import Prelude hiding (null, truncate) --- | The 'Borel' sets on a type are the sets generated by its open intervals.+-- | The 'Borel' sets on a type are the sets generated by its 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@@ -43,7 +47,7 @@ -- 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)+  deriving (Eq, Ord, Show, Generic, Typeable, Data)  instance (Ord x) => One (Borel x) where   type OneItem _ = Interval x@@ -52,7 +56,8 @@ 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) => Monoid (Borel x) where+  mempty = Borel mempty  instance (Ord x, Lattice x) => Lattice (Borel x) where   (\/) = union@@ -107,15 +112,21 @@ 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) =+-- |+-- Completely remove an 'Interval' from a 'Borel' set.+-- Essentially the opposite of 'truncate'.+remove :: (Ord x) => Interval x -> Borel x -> Borel x+remove i (Borel is) =   flip foldMap is $     (I.\\ i) >>> \case       Nothing -> mempty       Just (One j) -> borel [j]       Just (Two j k) -> borel [j, k] +-- | Flipped infix version of 'remove'.+(\-) :: (Ord x) => Borel x -> Interval x -> Borel x+(\-) = flip remove+ -- | 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@@ -134,7 +145,7 @@  -- | 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+difference is (Borel js) = foldr remove is js  -- | Take the symmetric difference of two 'Borel' sets. symmetricDifference :: (Ord x) => Borel x -> Borel x -> Borel x@@ -144,15 +155,19 @@ complement :: (Ord x) => Borel x -> Borel x complement = difference whole --- | Given an 'Interval' @i@, @'clip' i@ will trim a 'Borel' set+-- | Given an 'Interval' @i@, @'truncate' 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) =+truncate :: (Ord x) => Interval x -> Borel x -> Borel x+truncate i (Borel js) =   foldr ((<>) . maybe mempty one . I.intersect i) mempty js +-- | Flipped infix version of 'truncate'.+(\=) :: (Ord x) => Borel x -> Interval x -> Borel x+(\=) = flip truncate+ -- | Take the intersection of two 'Borel' sets. intersection :: (Ord x) => Borel x -> Borel x -> Borel x-intersection is (Borel js) = foldMap (`clip` is) js+intersection is (Borel js) = foldMap (`truncate` is) js  -- | Take the intersection of a list of 'Borel' sets. intersections :: (Ord x) => [Borel x] -> Borel x@@ -163,9 +178,7 @@ -- | 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)+hull (Borel js) = Set.minView js <&> \(i, is) -> I.hulls (i :| Set.toAscList is)  isSubsetOf :: (Ord x) => Borel x -> Borel x -> Bool-isSubsetOf is js = difference is js == mempty+isSubsetOf is js = null $ difference is js
src/Data/Interval/Layers.hs view
@@ -5,14 +5,19 @@   empty,   singleton,   insert,+  pile,   squash,   thickness,   thickest,+  dig,   remove,+  (\-),   baseline,   difference,-  clip,+  truncate,+  (\=),   toStepFunction,+  integrate,    -- ** Helper functions   nestings,@@ -20,25 +25,19 @@ ) where  import Algebra.Lattice.Levitated+import Data.Data import Data.Group (Group (..))-import Data.Interval (Adjacency (..), Interval, pattern Whole, pattern (:---:), pattern (:<>:))+import Data.Interval (Adjacency (..), Interval, OneOrTwo (..), pattern Whole, pattern (:---:), 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)+import Prelude hiding (empty, fromList, truncate)  -- 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-    )+  deriving (Eq, Ord, Show, Functor, Generic, Typeable, Data)  instance (Ord x, Semigroup y) => Semigroup (Layers x y) where   Layers s1 <> Layers s2 =@@ -81,10 +80,37 @@   Layers x y insert ix y = (<>) (singleton ix y) +-- | Flipped synonym for 'insert'.+-- Mnemonic: "pile" this much onto the existing 'Layers'+-- over the given 'Interval'.+pile ::+  (Ord x, Semigroup y) =>+  y ->+  Interval x ->+  Layers x y ->+  Layers x y+pile = flip insert+ -- | 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)+dig :: (Ord x, Group y) => y -> Interval x -> Layers x y -> Layers x y+dig y ix = insert ix (invert y) +-- | Completely remove an 'Interval' from the 'Layers'.+remove :: (Ord x, Semigroup y) => Interval x -> Layers x y -> Layers x y+remove ix (Layers s) =+  Map.foldlWithKey'+    ( \acc jx y -> case jx I.\\ ix of+        Nothing -> acc+        Just (One kx) -> acc <> singleton kx y+        Just (Two kx lx) -> acc <> fromList [(kx, y), (lx, y)]+    )+    empty+    s++-- | Fliped infix version of 'remove'.+(\-) :: (Ord x, Semigroup y) => Layers x y -> Interval x -> Layers x y+(\-) = flip remove+ -- | Add the given thickness to every point. baseline :: (Ord x, Semigroup y) => y -> Layers x y -> Layers x y baseline = insert Whole@@ -92,11 +118,11 @@ -- | "Excavate" the second argument from the first. difference :: (Ord x, Group y) => Layers x y -> Layers x y -> Layers x y difference layers (Layers s) =-  foldr (uncurry (flip remove)) layers (Map.toAscList s)+  foldr (uncurry (flip dig)) layers (Map.toAscList s)  -- | Restrict the range of the 'Layers' to the given 'Interval'.-clip :: (Ord x, Semigroup y) => Interval x -> Layers x y -> Layers x y-clip ix (Layers s) =+truncate :: (Ord x, Semigroup y) => Interval x -> Layers x y -> Layers x y+truncate ix (Layers s) =   Map.foldlWithKey'     ( \acc jx y -> case I.intersect ix jx of         Nothing -> acc@@ -104,6 +130,29 @@     )     empty     s++-- | Flipped infix version of 'truncate'.+(\=) :: (Ord x, Semigroup y) => Layers x y -> Interval x -> Layers x y+(\=) = flip truncate++-- |+-- @'integrate' diff hgt ix l@ calculates the area under the 'Interval' @ix@+-- using the measure @diff@ of the interval multiplied by the height @hgt@+-- of the layers over each sub-interval in the layers.+integrate ::+  (Ord x, Semigroup y, Num z) =>+  (x -> x -> z) ->+  (y -> z) ->+  Interval x ->+  Layers x y ->+  Maybe z+integrate diff hgt ix layers =+  let Layers (Map.assocs -> s) = layers \= ix+      f (jx, y) maccum = do+        acc <- maccum+        d <- I.measuring diff jx+        pure $ acc + d * hgt y+   in foldr f (Just 0) s  -- | Get the thickness of the 'Layers' at a point. thickness :: (Ord x, Monoid y) => x -> Layers x y -> y
tests/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE UndecidableInstances #-}+ module Main where  import Algebra.Lattice.Levitated (Levitated (..))@@ -13,14 +15,19 @@   pattern (:||:),  ) import Data.Interval.Borel qualified as Borel+import GHC.TypeNats import Test.Hspec import Test.QuickCheck +type family Ints (n :: Nat) x where+  Ints 0 x = x+  Ints n x = Int -> Ints (n - 1) x+ main :: IO () main = hspec $ do   describe "smart constructors" $ do-    it "orients finite intervals" $ do-      property @(Int -> Int -> _) $ \x y -> do+    it "orient finite intervals" $ do+      property @(Ints 2 _) $ \x y -> do         if x <= y           then do             (x :<>: y) `shouldBe` (x :<>: y)@@ -41,13 +48,13 @@             (Levitate x :<-|: Levitate y) `shouldBe` (Levitate y :|->: Levitate x)             (Levitate x :|-|: Levitate y) `shouldBe` (Levitate y :|-|: Levitate x) -    it "orients infinite intervals" $ do+    it "orient 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+    it "close point intervals" $ do       property @(Int -> _) $ \x -> do         (x :<>: x) `shouldBe` (x :||: x)         (x :|>: x) `shouldBe` (x :||: x)@@ -60,12 +67,12 @@    describe "Borel intervals" $ do     it "(<>) is commutative" $ do-      property @(Int -> Int -> Int -> Int -> _) $ \a b x y -> do+      property @(Ints 4 _) $ \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+      property @(Ints 6 _) $ \a b m n x y -> do         let ab = Borel.singleton (a :<>: b)             mn = Borel.singleton (m :<>: n)             xy = Borel.singleton (x :<>: y)