packages feed

interval-patterns 0.7.0.3 → 0.7.2

raw patch · 8 files changed

+166/−92 lines, 8 filesdep +deepseqdep +hashabledep ~containersdep ~time

Dependencies added: deepseq, hashable

Dependency ranges changed: containers, time

Files

CHANGELOG.md view
@@ -1,5 +1,15 @@ # Revision history for interval-patterns +## 0.7.2++* fix sign of result in `Data.Timeframe.duration`+* generalize `within` and `thickness` to Levitated++## 0.7.1++* instances `Hashable` and `NFData` for `Interval`+* relax constraint on `Data.Interval.Layers.thickness` to `Semigroup`+ ## 0.7.0.3  * update `lattice` version range to build on new stackage LTS
interval-patterns.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               interval-patterns-version:            0.7.0.3+version:            0.7.2 author:             Melanie Brown synopsis:           Intervals, and monoids thereof category:           Algebra, Charts, Data Structures, Math, Statistics@@ -17,12 +17,14 @@ common interval-patterns   build-depends:     , base         >=4.11    && <5-    , containers+    , containers   >=0.6.7   && <0.7+    , deepseq      >=1.4.8   && <1.6     , groups       >=0.5.3   && <0.6+    , hashable     >=1.4.2   && <1.5     , heaps        >=0.4     && <0.5     , lattices     >=2.1     && <3     , semirings    >=0.6     && <0.7-    , time+    , time         >=1.9.3   && <1.13     , time-compat  >=1.9.6.1 && <1.10    default-language:   GHC2021
src/Data/Calendar.hs view
@@ -16,7 +16,7 @@   totalDuration, ) where -import Control.Applicative (liftA2)+import Algebra.Lattice.Levitated (Levitated (..)) import Data.Data (Typeable) import Data.Foldable (fold) import Data.Interval qualified as I@@ -25,8 +25,8 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe)-import Data.Semigroup hiding (diff)-import Data.Time.Compat+import Data.Semigroup (Sum (..))+import Data.Time.Compat (NominalDiffTime, UTCTime, diffUTCTime) import Data.Timeframe  -- | An 'Event' is a collection of 'Timeframe's that keeps track of@@ -62,9 +62,12 @@   deriving (Eq, Ord, Show, Typeable)  instance (Ord ev, Ord n, Num n) => Semigroup (Calendar ev n) where+  (<>) ::+    (Ord ev, Ord n, Num n) => Calendar ev n -> Calendar ev n -> Calendar ev n   Calendar a <> Calendar b = Calendar (Map.unionWith (<>) a b)  instance (Ord ev, Ord n, Num n) => Monoid (Calendar ev n) where+  mempty :: (Ord ev, Ord n, Num n) => Calendar ev n   mempty = Data.Calendar.empty  -- | The empty 'Calendar'.@@ -80,7 +83,8 @@ calendar ev tf = singleton ev (Layers.singleton tf 1)  -- | Insert an 'Event' of the given sort into a 'Calendar'.-insert :: (Ord ev, Ord n, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n+insert ::+  (Ord ev, Ord n, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n insert ev cvg (Calendar c) = Calendar (Map.insertWith (<>) ev cvg c)  -- |@@ -95,7 +99,8 @@ (!) :: (Ord ev, Ord n, Num n) => Calendar ev n -> ev -> Event n Calendar c ! ev = fromMaybe mempty (c Map.!? ev) -toList :: (Ord ev, Ord n, Num n) => Calendar ev n -> [(ev, [(Interval UTCTime, n)])]+toList ::+  (Ord ev, Ord n, Num n) => Calendar ev n -> [(ev, [(Interval UTCTime, n)])] toList (Calendar c) = fmap (fmap (fmap getSum) . Layers.toList) <$> Map.assocs c  -- |@@ -103,12 +108,16 @@ -- at the given 'UTCTime' on this 'Calendar'? happeningAt :: (Ord ev, Ord n, 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]+  [ (ev, n)+  | (ev, ns) <- evs+  , (_, n) <- filter (within (Levitate time) . fst) ns+  ]  -- | Consider every kind of event the same, and observe the overall 'Layers'. coalesce :: (Ord ev, Ord n, Num n) => Calendar ev n -> Event n coalesce (Calendar c) = fold c +-- | Calculate the total length of a particular event across all occurrences. totalDuration ::   forall ev n.   (Ord ev, Real n) =>
src/Data/Interval.hs view
@@ -99,10 +99,12 @@  import Algebra.Lattice.Levitated (Levitated (..), foldLevitated) import Control.Applicative (liftA2)+import Control.DeepSeq import Control.Monad (join) import Data.Data import Data.Function (on) import Data.Functor.Const (Const (Const))+import Data.Hashable (Hashable (..)) import Data.Kind (Constraint, Type) import Data.List (sort) import Data.List.NonEmpty (NonEmpty ((:|)))@@ -567,6 +569,18 @@   to :: (Ord x, Generic x) => Rep (Interval x) x1 -> Interval x   to (Const l :*: Const u) = l ... u +instance (Ord x, Hashable x) => Hashable (Interval x) where+  hashWithSalt :: (Ord x, Hashable x) => Int -> Interval x -> Int+  hashWithSalt s = \case+    l :<->: u -> s `hashWithSalt` (1 :: Int) `hashWithSalt` l `hashWithSalt` u+    l :|->: u -> s `hashWithSalt` (2 :: Int) `hashWithSalt` l `hashWithSalt` u+    l :<-|: u -> s `hashWithSalt` (3 :: Int) `hashWithSalt` l `hashWithSalt` u+    l :|-|: u -> s `hashWithSalt` (4 :: Int) `hashWithSalt` l `hashWithSalt` u++instance (Ord x, NFData x) => NFData (Interval x) where+  rnf :: (Ord x, NFData x) => Interval x -> ()+  rnf (x :---: y) = x `seq` y `seq` ()+ -- | 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@@ -818,8 +832,8 @@ 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+within :: (Ord x) => Levitated x -> Interval x -> Bool+within x = \case   l :<->: u -> l < x && x < u   l :<-|: u -> l < x && x <= u   l :|->: u -> l <= x && x < u
src/Data/Interval/Borel.hs view
@@ -25,9 +25,13 @@ ) where  import Algebra.Heyting (Heyting ((==>)))-import Algebra.Lattice-import Control.Arrow ((>>>))-import Data.Data+import Algebra.Lattice (+  BoundedJoinSemiLattice (..),+  BoundedMeetSemiLattice (..),+  Lattice (..),+ )+import Algebra.Lattice.Levitated (Levitated (..))+import Data.Data (Data, Typeable) import Data.Foldable (fold) import Data.Functor ((<&>)) import Data.Interval (Interval)@@ -56,31 +60,47 @@   deriving (Eq, Ord, Show, Generic, Typeable, Data)  instance (Ord x) => Semigroup (Borel x) where+  (<>) :: (Ord x) => Borel x -> Borel x -> Borel x   Borel is <> Borel js = Borel (unionsSet (is <> js))  instance (Ord x) => Monoid (Borel x) where+  mempty :: (Ord x) => Borel x   mempty = Borel mempty  instance (Ord x, Lattice x) => Lattice (Borel x) where+  (\/) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x   (\/) = union++  (/\) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x   (/\) = intersection  instance (Ord x, Lattice x) => BoundedMeetSemiLattice (Borel x) where+  top :: (Ord x, Lattice x) => Borel x   top = whole  instance (Ord x, Lattice x) => BoundedJoinSemiLattice (Borel x) where+  bottom :: (Ord x, Lattice x) => Borel x   bottom = mempty  instance (Ord x, Lattice x) => Heyting (Borel x) where+  (==>) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x   x ==> y = complement x \/ y  instance (Ord x, Lattice x) => Semiring (Borel x) where+  plus :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x   plus = symmetricDifference++  times :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x   times = intersection++  zero :: (Ord x, Lattice x) => Borel x   zero = mempty++  one :: (Ord x, Lattice x) => Borel x   one = whole  instance (Ord x, Lattice x) => Ring (Borel x) where+  negate :: (Ord x, Lattice x) => Borel x -> Borel x   negate = complement  -- | Consider the 'Borel' set identified by a list of 'Interval's.@@ -118,12 +138,10 @@ -- 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]+remove i (Borel is) = flip foldMap is $ flip (.) (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@@ -131,7 +149,7 @@  -- | 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+member x (Borel is) = any (I.within (Levitate x)) is  -- | Is this point not 'I.within' any connected component of the 'Borel' set? notMember :: (Ord x) => x -> Borel x -> Bool
src/Data/Interval/Layers.hs view
@@ -29,8 +29,15 @@ import Data.Group (Group (..)) import Data.Heap (Heap) import Data.Heap qualified as Heap-import Data.Interval (Adjacency (..), Interval, OneOrTwo (..), pattern Whole, pattern (:---:), pattern (:<>:))-import Data.Interval qualified as I+import Data.Interval (+  Adjacency (..),+  Interval,+  OneOrTwo (..),+  pattern Whole,+  pattern (:---:),+  pattern (:|-|:),+ )+import Data.Interval qualified as Interval import Data.Interval.Borel (Borel) import Data.Interval.Borel qualified as Borel import Data.Map.Strict (Map)@@ -44,14 +51,20 @@   deriving (Eq, Ord, Show, Functor, Generic, Typeable, Data)  instance (Ord x, Ord y, Semigroup y) => Semigroup (Layers x y) where+  (<>) :: (Ord x, Ord y, Semigroup y) => Layers x y -> Layers x y -> Layers x y   Layers s1 <> Layers s2 =-    let s = Map.toAscList $ Map.unionWith (<>) s1 s2-     in Layers $ Map.fromList (nestingsAsc $ Heap.fromList s)+    Layers+      . Map.fromAscList+      . nestingsAsc+      . Heap.fromList+      $ Map.toAscList (Map.unionWith (<>) s1 s2)  instance (Ord x, Ord y, Semigroup y) => Monoid (Layers x y) where+  mempty :: (Ord x, Ord y, Semigroup y) => Layers x y   mempty = Layers mempty  instance (Ord x, Ord y, Group y) => Group (Layers x y) where+  invert :: (Ord x, Ord y, Group y) => Layers x y -> Layers x y   invert (Layers s) = Layers (fmap invert s)  -- | A blank canvas.@@ -101,15 +114,11 @@  -- | Completely remove an 'Interval' from the 'Layers'. remove :: (Ord x, Ord y, 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+remove ix (Layers s) = flip (`Map.foldlWithKey'` empty) s \acc jx y ->+  acc <> case jx Interval.\\ ix of+    Nothing -> mempty+    Just (One kx) -> singleton kx y+    Just (Two kx lx) -> fromList [(kx, y), (lx, y)]  -- | Fliped infix version of 'remove'. (\-) :: (Ord x, Ord y, Semigroup y) => Layers x y -> Interval x -> Layers x y@@ -125,15 +134,11 @@   foldr (uncurry (flip dig)) layers (Map.toAscList s)  -- | Restrict the range of the 'Layers' to the given 'Interval'.-truncate :: (Ord x, Ord y, Semigroup y) => Interval x -> Layers x y -> Layers x y+truncate ::+  (Ord x, Ord y, 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-        Just x -> insert x y acc-    )-    empty-    s+  flip (`Map.foldlWithKey'` empty) s \acc jx y ->+    maybe id (`insert` y) (Interval.intersect ix jx) acc  -- | Flipped infix version of 'truncate'. (\=) :: (Ord x, Ord y, Semigroup y) => Layers x y -> Interval x -> Layers x y@@ -154,40 +159,38 @@   let Layers (Map.assocs -> s) = layers \= ix       f (jx, y) maccum = do         acc <- maccum-        d <- I.measuring diff jx+        d <- Interval.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-thickness x (Layers s) = case Map.lookupLE (x :<>: x) s of-  Just (ix, y) | x `I.within` ix -> y-  _ -> mempty+thickness :: (Ord x, Semigroup y) => Levitated x -> Layers x y -> Maybe y+thickness x (Layers s) = case Map.lookupLE (x :|-|: x) s of+  Just (ix, y) | x `Interval.within` ix -> Just y+  _ -> Nothing  -- | 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+  flip (`Map.foldlWithKey'` Nothing) s \acc ix y -> Just case acc of+    Nothing -> (ix, y)+    Just (_, y') | y > y' -> (ix, y)+    Just (ix', y') -> (ix', y')  -- | Convert the 'Layers' into a list of beginning-points and heights, -- that define a step function piecewise. toStepFunction :: (Ord x, Ord y, Monoid y) => Layers x y -> [(Levitated x, y)]-toStepFunction s = g (Data.Interval.Layers.toList $ baseline mempty s)+toStepFunction = go . Data.Interval.Layers.toList  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)]+  go = \case+    [(il :---: iu, iy), (j@(jl :---: Top), jy)]+      | iu == jl -> (il, iy) : go [(j, jy)]+      | otherwise -> (il, iy) : (iu, mempty) : go [(j, jy)]+    (il :---: iu, iy) : (j@(jl :---: _), jy) : is+      | iu == jl -> (il, iy) : go ((j, jy) : is)+      | otherwise -> (il, iy) : (iu, mempty) : go ((j, jy) : is)+    [(il :---: iu, iy)] -> [(il, iy), (iu, mempty)]+    [] -> []  nestings ::   (Ord x, Ord y, Semigroup y) =>@@ -201,35 +204,43 @@   [(Interval x, y)] nestingsAsc heap = case firstTwo of   Nothing -> Foldable.toList heap-  Just ((i', iy), (j', jy), js) -> case I.adjacency i' j' of+  Just ((i', iy), (j', jy), js) -> case Interval.adjacency i' j' of     Before i j -> (i, iy) : nestingsAsc (Heap.insert (j, jy) js)     Meets i j k ->       (i, iy) : nestingsAsc (Heap.fromList [(j, iy <> jy), (k, jy)] <> js)     Overlaps i j k ->-      nestingsAsc $-        Heap.fromList [(i, iy), (j, iy <> jy), (k, jy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy), (j, iy <> jy), (k, jy)]+        <> js     Starts i j ->-      nestingsAsc $-        Heap.fromList [(i, iy <> jy), (j, jy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy <> jy), (j, jy)]+        <> js     During i j k ->-      nestingsAsc $-        Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)]+        <> js     Finishes i j ->-      nestingsAsc $-        Heap.fromList [(i, iy), (j, iy <> jy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy), (j, iy <> jy)]+        <> js     Identical i -> nestingsAsc (Heap.insert (i, iy <> jy) js)     FinishedBy i j ->-      nestingsAsc $-        Heap.fromList [(i, iy), (j, iy <> jy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy), (j, iy <> jy)]+        <> js     Contains i j k ->-      nestingsAsc $-        Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)]+        <> js     StartedBy i j ->-      nestingsAsc $-        Heap.fromList [(i, iy <> jy), (j, iy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, iy <> jy), (j, iy)]+        <> js     OverlappedBy i j k ->-      nestingsAsc $-        Heap.fromList [(i, jy), (j, iy <> jy), (k, iy)] <> js+      nestingsAsc+        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, iy)]+        <> js     MetBy i j k ->       (i, jy) : nestingsAsc (Heap.fromList [(j, iy <> jy), (k, iy)] <> js)     After i j -> (i, jy) : nestingsAsc (Heap.insert (j, iy) js)
src/Data/Timeframe.hs view
@@ -30,4 +30,4 @@    in localTimeframeAt tz t1 t2  duration :: Timeframe -> Maybe NominalDiffTime-duration = measuring diffUTCTime+duration = measuring (flip diffUTCTime)
tests/Main.hs view
@@ -15,6 +15,8 @@   pattern (:||:),  ) import Data.Interval.Borel qualified as Borel+import Data.Interval.Layers qualified as Layers+import Data.Semigroup import GHC.TypeNats import Test.Hspec import Test.QuickCheck@@ -24,10 +26,10 @@   Ints n x = Int -> Ints (n - 1) x  main :: IO ()-main = hspec $ do-  describe "smart constructors" $ do-    it "orient finite intervals" $ do-      property @(Ints 2 _) $ \x y -> do+main = hspec do+  describe "smart constructors" do+    it "orient finite intervals" do+      property @(Ints 2 _) \x y -> do         if x <= y           then do             (x :<>: y) `shouldBe` (x :<>: y)@@ -48,13 +50,13 @@             (Levitate x :<-|: Levitate y) `shouldBe` (Levitate y :|->: Levitate x)             (Levitate x :|-|: Levitate y) `shouldBe` (Levitate y :|-|: Levitate x) -    it "orient 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 "close point intervals" $ do+    it "close point intervals" do       property @(Int -> _) $ \x -> do         (x :<>: x) `shouldBe` (x :||: x)         (x :|>: x) `shouldBe` (x :||: x)@@ -65,15 +67,23 @@         (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 @(Ints 4 _) $ \a b x y -> do+  describe "Borel intervals" do+    it "(<>) is commutative" 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 @(Ints 6 _) $ \a b m n x y -> do+    it "(<>) is associative" 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)         (ab <> mn) <> xy `shouldBe` ab <> (mn <> xy)++  describe "Layers" do+    it "(<>) is associative" do+      property @(Ints 9 _) \a b c d e f x y z -> do+        let abx = Layers.singleton (a :<>: b) (Sum x)+            cdy = Layers.singleton (c :||: d) (Sum y)+            efz = Layers.singleton (e :<>: f) (Sum z)+        (abx <> cdy) <> efz `shouldBe` abx <> (cdy <> efz)