interval-patterns 0.2.0.1 → 0.3.0.0

raw patch · 6 files changed

+151/−126 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• interval-patterns.cabal +1/−1
• src/Data/Interval.hs +80/−61
• src/Data/Interval/Borel.hs +4/−0
• src/Data/Interval/Layers.hs +51/−17
• src/Data/Timeframe.hs +0/−47

@@ -1,5 +1,20 @@ # Revision history for interval-patterns +## 0.3.0.0 - 2022-06-08++* new pattern synonym `(:---:) :: (Ord x) => Levitated x -> Levitated x -> Interval x`+  * only works as a pattern; cannot be used as an expression+  * disregards the open/closedness of the boundary+* fix `openclosed` and `closedopen`+* rename `imapS -> imapLev` and `itraverseS -> itraverseLev` following `Suspension -> Levitated`+* `(...)` as a value-level analogue to `interval`+* `Data.Interval.isSubsetOf`+* `Data.Interval.Borel.isSubsetOf`+* `Data.Interval.Layers.difference`+* `Data.Interval.Layers.clip`+* `Data.Interval.Layers.toStepFunction`+* `Data.Calendar.happeningAt`+ ## 0.2.0.1 - 2022-05-30  * export `clip` from `Data.Interval.Borel`

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: interval-patterns-version: 0.2.0.1+version: 0.3.0.0 author: Melanie Brown description: A library for easy manipulation of intervals according to their overlap. maintainer: brown.m@pm.me

@@ -16,18 +16,21 @@   oppose,   Interval (..),   imap,-  imapS,+  imapLev,   itraverse,-  itraverseS,+  itraverseLev,   pattern (:<->:),   pattern (:<-|:),   pattern (:|->:),   pattern (:|-|:),+  pattern (:---:),   pattern (:<>:),   pattern (:<|:),   pattern (:|>:),   pattern (:||:),   pattern Whole,+  (+/-),+  (...),   bounds,   lower,   lowerBound,@@ -66,7 +69,7 @@   measure,   measuring,   hausdorff,-  (+/-),+  isSubsetOf, ) where  import Algebra.Lattice.Levitated@@ -281,12 +284,12 @@   l :|-|: u -> fmap f l :|-|: fmap f u  -- | Same as 'imap' but on the 'Levitated' of the underlying type.-imapS ::+imapLev ::   (Ord x, Ord y) =>   (Levitated x -> Levitated y) ->   Interval x ->   Interval y-imapS f = \case+imapLev f = \case   l :<->: u -> f l :<->: f u   l :|->: u -> f l :|->: f u   l :<-|: u -> f l :<-|: f u@@ -306,12 +309,12 @@   l :|-|: u -> liftA2 (:|-|:) (traverse f l) (traverse f u)  -- | Same as 'itraverse' but on the 'Levitated' of the underlying type.-itraverseS ::+itraverseLev ::   (Ord x, Ord y, Applicative f) =>   (Levitated x -> f (Levitated y)) ->   Interval x ->   f (Interval y)-itraverseS f = \case+itraverseLev f = \case   l :<->: u -> liftA2 (:<->:) (f l) (f u)   l :|->: u -> liftA2 (:|->:) (f l) (f u)   l :<-|: u -> liftA2 (:<-|:) (f l) (f u)@@ -372,6 +375,11 @@  {-# COMPLETE (:<->:), (:<-|:), (:|->:), (:|-|:) #-} +pattern (:---:) :: forall x. (Ord x) => Levitated x -> Levitated x -> Interval x+pattern l :---: u <- (bounds -> (SomeBound (unBound -> l), SomeBound (unBound -> u)))++{-# COMPLETE (:---:) #-}+ infix 5 :<>:  infix 5 :<|:@@ -414,7 +422,7 @@           sup = Levitate (max b1 b2)        in case compare inf sup of             EQ -> Min inf :|--|: Max sup-            _ -> Inf inf :<--|: Max sup+            _ -> Min inf :|-->: Sup sup  -- | A pattern synonym matching finite closed intervals. pattern (:||:) :: forall x. (Ord x) => x -> x -> Interval x@@ -484,6 +492,26 @@   (Max u, Inf l) -> l :<-|: u   _ -> error "cannot make an interval with the given bounds" +-- | Given limits and 'Extremum's, try to make an interval.+(...) ::+  (Ord x) =>+  (Levitated x, Extremum) ->+  (Levitated x, Extremum) ->+  Interval x+(x, b1) ... (y, b2) = case (b1, b2) of+  (Minimum, Supremum) -> l :|->: u+  (Minimum, Maximum) -> l :|-|: u+  (Infimum, Supremum) -> l :<->: u+  (Infimum, Maximum) -> l :<-|: u+  (Supremum, Minimum) -> l :|->: u+  (Supremum, Infimum) -> l :<->: u+  (Maximum, Minimum) -> l :|-|: u+  (Maximum, Infimum) -> l :<-|: u+  _ -> error "cannot make an interval with the given bounds"+ where+  l = min x y+  u = max x y+ -- | According to -- [Allen](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra), -- two intervals can be "adjacent" in 13 different ways,@@ -544,79 +572,49 @@  -- | 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+within (Levitate -> x) (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+ -- | 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+  _ -> Nothing  -- | 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+  _ -> Nothing +-- | Get the supremum of an interval, weakening if necessary.+isup :: (Ord x) => Interval x -> Bound Supremum (Levitated x)+isup (_ :---: x) = Sup 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+open (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+close (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+openclosed (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+closedopen (l :---: u) = l :|->: u  -- | Make the lower bound open, leaving the endpoints unchanged. openLower :: (Ord x) => Interval x -> Interval x@@ -822,6 +820,16 @@ -- Just (Two (Bottom :|-|: Levitate 3) (Levitate 4 :|-|: Top)) -- -- @+--+-- Note that infinitely-open intervals will return the points at infinity+-- toward which they are infinite in their result:+--+-- @+--+-- >>> complement (Levitate 3 :<->: Top)+-- Just (Two (Bottom :|-|: Levitate 3) (Top :|-|: Top))+--+-- @ complement :: forall x. (Ord x) => Interval x -> Maybe (OneOrTwo (Interval x)) complement = \case   Whole -> Nothing@@ -933,14 +941,8 @@ 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+  Levitate l :---: Levitate u -> Just (f l u)+  l :---: u -> if l == u then Just 0 else Nothing  -- | Get the distance between two intervals, or 0 if they adjacency. --@@ -966,3 +968,20 @@ -- For the open interval, simply write @'open' (x '+/-' y)@. (+/-) :: (Ord x, Num x) => x -> x -> Interval x m +/- r = m - r :||: m + r++-- | Full containment.+isSubsetOf :: (Ord x) => Interval x -> Interval x -> Bool+isSubsetOf i j = case adjacency i j of+  Before{} -> False+  Meets{} -> False+  Overlaps{} -> False+  Starts{} -> True+  During{} -> True+  Finishes{} -> True+  Identical{} -> True+  FinishedBy{} -> False+  Contains{} -> False+  StartedBy{} -> False+  OverlappedBy{} -> False+  MetBy{} -> False+  After{} -> False

@@ -19,6 +19,7 @@   intersection,   intersections,   hull,+  isSubsetOf, ) where  import Algebra.Heyting@@ -165,3 +166,6 @@ hull (Borel is)   | Set.null is = Nothing   | otherwise = Just $ uncurry (foldr I.hull) (Set.deleteFindMin is)++isSubsetOf :: (Ord x) => Borel x -> Borel x -> Bool+isSubsetOf is js = difference is js == mempty

@@ -10,14 +10,18 @@   thickest,   remove,   baseline,+  difference,+  clip,+  toStepFunction,    -- ** Helper functions   nestings,   nestingsAsc, ) where +import Algebra.Lattice.Levitated import Data.Group (Group (..))-import Data.Interval (Adjacency (..), Interval, pattern Whole, pattern (:<>:))+import Data.Interval (Adjacency (..), Interval, pattern Whole, pattern (:---:), pattern (:<>:)) import Data.Interval qualified as I import Data.Interval.Borel (Borel) import Data.Interval.Borel qualified as Borel@@ -68,6 +72,39 @@ squash :: (Ord x) => Layers x y -> Borel x squash (Layers s) = foldMap Borel.singleton (Map.keys 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 = (<>) (singleton ix y)++-- | 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++-- | "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)++-- | 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) =+  Map.foldlWithKey'+    ( \acc jx y -> case I.intersect ix jx of+        Nothing -> acc+        Just x -> insert x y acc+    )+    empty+    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@@ -85,14 +122,19 @@     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)+-- | Convert the 'Layers' into a list of beginning-points and heights,+-- that define a step function piecewise.+toStepFunction :: (Ord x, Monoid y) => Layers x y -> [(Levitated x, y)]+toStepFunction s = g (Data.Interval.Layers.toList $ baseline mempty s)+ where+  g [(il :---: iu, iy), (j@(jl :---: Top), jy)]+    | iu == jl = (il, iy) : g [(j, jy)]+    | otherwise = (il, iy) : (iu, mempty) : g [(j, jy)]+  g ((il :---: iu, iy) : (j@(jl :---: _), jy) : is)+    | iu == jl = (il, iy) : g ((j, jy) : is)+    | otherwise = (il, iy) : (iu, mempty) : g ((j, jy) : is)+  g [] = []+  g [(il :---: iu, iy)] = [(il, iy), (iu, mempty)]  nestings ::   (Ord x, Semigroup y) =>@@ -148,11 +190,3 @@     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

@@ -5,19 +5,9 @@   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) @@ -38,40 +28,3 @@  duration :: Timeframe -> Maybe NominalDiffTime duration = measuring diffUTCTime---- | An 'Event' is something that happens for a period of time.------ > type Event n = Layers UTCTime (Sum n)-type Event n = Layers UTCTime (Sum n)--event :: (Num n) => Timeframe -> Event n-event = (`Layers.singleton` 1)--newtype Calendar ev n = Calendar {getCalendar :: Map ev (Event n)}-  deriving (Eq, Ord, Show, Typeable)--instance (Ord ev, Num n) => Semigroup (Calendar ev n) where-  Calendar a <> Calendar b = Calendar (Map.unionWith (<>) a b)--instance (Ord ev, Num n) => Monoid (Calendar ev n) where-  mempty = Calendar mempty--singleton :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n-singleton ev cvg = Calendar (Map.singleton ev cvg)--calendar :: (Ord ev, Num n) => ev -> Timeframe -> Calendar ev n-calendar ev tf = singleton ev (Layers.singleton tf 1)--addEvent :: (Ord ev, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n-addEvent ev cvg (Calendar c) = Calendar (Map.insertWith (<>) ev cvg c)--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)- where-  f :: (Timeframe, Sum n) -> Maybe NominalDiffTime -> Maybe NominalDiffTime-  f _ Nothing = Nothing-  f (tf, Sum n) (Just x) = case (realToFrac n *) <$> duration tf of-    Nothing -> Nothing-    Just y -> Just (x + y)