packages feed

interval-patterns 0.7.2 → 0.8.0

raw patch · 6 files changed

+177/−78 lines, 6 filesdep +parsecdep +textdep ~containers

Dependencies added: parsec, text

Dependency ranges changed: containers

Files

CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for interval-patterns +## 0.8.0++* `newtype Shrink x = Shrink {getShrink :: Borel x}`, the monoid formed by `Borel.intersection` and `whole`+* `landAbove :: (Ord x, Ord y) => y -> Layers x y -> Borel x` above "sea level"+* `land :: (Ord x, Monoid y, Ord y) => Layers x y -> Borel x` above a "sea level" of `mempty`+* remove unnecessary `Lattice` constraints on the endpoints of `Borel` sets+* fix `Constr` definitions having an extra `-` character+* fix bug in `difference` conflating the cases `Finishes` and `FinishedBy`+ ## 0.7.2  * fix sign of result in `Data.Timeframe.duration`
interval-patterns.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               interval-patterns-version:            0.7.2+version:            0.8.0 author:             Melanie Brown synopsis:           Intervals, and monoids thereof category:           Algebra, Charts, Data Structures, Math, Statistics@@ -10,14 +10,14 @@ homepage:           https://github.com/mixphix/interval-patterns bug-reports:        https://github.com/mixphix/interval-patterns/issues extra-source-files: CHANGELOG.md-copyright:          2023 Melanie Brown+copyright:          2023-2024 Melanie Brown description:   Please see the README at https://github.com/mixphix/interval-patterns  common interval-patterns   build-depends:     , base         >=4.11    && <5-    , containers   >=0.6.7   && <0.7+    , containers   >=0.6.7   && <0.8     , deepseq      >=1.4.8   && <1.6     , groups       >=0.5.3   && <0.6     , hashable     >=1.4.2   && <1.5@@ -63,4 +63,6 @@   build-depends:     , hspec     , interval-patterns+    , parsec     , QuickCheck+    , text
src/Data/Interval.hs view
@@ -514,7 +514,7 @@ intervalOpenOpenConstr =   mkConstr     intervalDataType-    ":<--->:"+    ":<-->:"     []     Infix @@ -522,7 +522,7 @@ intervalClosedOpenConstr =   mkConstr     intervalDataType-    ":|--->:"+    ":|-->:"     []     Infix @@ -530,7 +530,7 @@ intervalOpenClosedConstr =   mkConstr     intervalDataType-    ":<---|:"+    ":<--|:"     []     Infix @@ -538,7 +538,7 @@ intervalClosedClosedConstr =   mkConstr     intervalDataType-    ":|---|:"+    ":|--|:"     []     Infix @@ -1010,7 +1010,7 @@     _ -> i : unionsAsc (j : is)   x -> x --- | Take the complement of the interval, as possibly 'OneOrTwo'.+-- | Take the complement of the interval, as possibly 'OneOrTwo'. See also 'Data.Interval.Borel.complement'. -- -- @ -- >>> complement (3 :<>: 4)@@ -1073,9 +1073,9 @@   Overlaps i _ _ -> Just $ One i   Starts{} -> Nothing   During{} -> Nothing-  Finishes{} -> Nothing+  Finishes i _ -> Just $ One i   Identical{} -> Nothing-  FinishedBy i _ -> Just $ One i+  FinishedBy{} -> Nothing   Contains i _ k -> Just $ Two i k   StartedBy _ j -> Just $ One j   OverlappedBy _ _ k -> Just $ One k
src/Data/Interval/Borel.hs view
@@ -1,5 +1,5 @@ module Data.Interval.Borel (-  Borel,+  Borel (Borel),   borel,   intervalSet,   Data.Interval.Borel.empty,@@ -22,6 +22,7 @@   intersections,   hull,   isSubsetOf,+  Shrink (..), ) where  import Algebra.Heyting (Heyting ((==>)))@@ -55,7 +56,7 @@ -- 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'.+-- To keep track of this data, use 'Data.Interval.Layers.Layers'. newtype Borel x = Borel (Set (Interval x))   deriving (Eq, Ord, Show, Generic, Typeable, Data) @@ -67,40 +68,40 @@   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+instance (Ord x) => Lattice (Borel x) where+  (\/) :: (Ord x) => Borel x -> Borel x -> Borel x   (\/) = union -  (/\) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x+  (/\) :: (Ord x) => Borel x -> Borel x -> Borel x   (/\) = intersection -instance (Ord x, Lattice x) => BoundedMeetSemiLattice (Borel x) where-  top :: (Ord x, Lattice x) => Borel x+instance (Ord x) => BoundedMeetSemiLattice (Borel x) where+  top :: (Ord x) => Borel x   top = whole -instance (Ord x, Lattice x) => BoundedJoinSemiLattice (Borel x) where-  bottom :: (Ord x, Lattice x) => Borel x+instance (Ord x) => BoundedJoinSemiLattice (Borel x) where+  bottom :: (Ord x) => Borel x   bottom = mempty -instance (Ord x, Lattice x) => Heyting (Borel x) where-  (==>) :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x+instance (Ord x) => Heyting (Borel x) where+  (==>) :: (Ord 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+instance (Ord x) => Semiring (Borel x) where+  plus :: (Ord x) => Borel x -> Borel x -> Borel x   plus = symmetricDifference -  times :: (Ord x, Lattice x) => Borel x -> Borel x -> Borel x+  times :: (Ord x) => Borel x -> Borel x -> Borel x   times = intersection -  zero :: (Ord x, Lattice x) => Borel x+  zero :: (Ord x) => Borel x   zero = mempty -  one :: (Ord x, Lattice x) => Borel x+  one :: (Ord x) => Borel x   one = whole -instance (Ord x, Lattice x) => Ring (Borel x) where-  negate :: (Ord x, Lattice x) => Borel x -> Borel x+instance (Ord x) => Ring (Borel x) where+  negate :: (Ord x) => Borel x -> Borel x   negate = complement  -- | Consider the 'Borel' set identified by a list of 'Interval's.@@ -191,9 +192,7 @@  -- | 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)+intersections = getShrink . foldMap Shrink  -- | Take the smallest spanning 'Interval' of a 'Borel' set, -- provided that it is not the empty set.@@ -202,3 +201,15 @@  isSubsetOf :: (Ord x) => Borel x -> Borel x -> Bool isSubsetOf is js = null $ difference is js++-- | Newtype wrapper for the monoid under 'intersection'.+newtype Shrink x = Shrink {getShrink :: Borel x}+  deriving (Eq, Ord, Show, Generic, Typeable, Data)++instance (Ord x) => Semigroup (Shrink x) where+  (<>) :: (Ord x) => Shrink x -> Shrink x -> Shrink x+  Shrink x <> Shrink y = Shrink (intersection x y)++instance (Ord x) => Monoid (Shrink x) where+  mempty :: (Ord x) => Shrink x+  mempty = Shrink whole
src/Data/Interval/Layers.hs view
@@ -1,5 +1,5 @@ module Data.Interval.Layers (-  Layers,+  Layers (Layers),   Data.Interval.Layers.fromList,   Data.Interval.Layers.toList,   empty,@@ -7,6 +7,8 @@   insert,   pile,   squash,+  land,+  landAbove,   thickness,   thickest,   dig,@@ -83,11 +85,28 @@ 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'+-- | Ignore the 'Layers' and focus only on whether points are 'Data.Interval.within' -- any contained 'Interval' or not. squash :: (Ord x) => Layers x y -> Borel x squash (Layers s) = foldMap Borel.singleton (Map.keys s) +-- | Treating 'mempty' as sea level, consider the 'Borel' set of a provided+-- 'Layers' that is "land".+--+-- An improvement over 'squash' in that it will not return 'I.Whole'+-- if 'baseline' or some involved interval calculations have been used.+land :: (Ord x, Monoid y, Ord y) => Layers x y -> Borel x+land = landAbove mempty++-- | Given a "sea level", consider the 'Borel' set of a provided 'Layers'+-- that is "land".+--+-- An improvement over 'squash' in that it will not return 'I.Whole'+-- if 'baseline' or some involved interval calculations have been used.+landAbove :: (Ord x, Ord y) => y -> Layers x y -> Borel x+landAbove sea (Layers s) = flip Map.foldMapWithKey s \i y ->+  if y > sea then Borel.singleton i else Borel.empty+ -- | @insert ix y l@ draws over @l@ a rectangle with base @ix@ of thickness @y@. insert ::   (Ord x, Ord y, Semigroup y) =>@@ -209,38 +228,30 @@     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 do+        Heap.fromList [(i, iy), (j, iy <> jy), (k, jy)] <> js     Starts i j ->-      nestingsAsc-        $ Heap.fromList [(i, iy <> jy), (j, jy)]-        <> js+      nestingsAsc do+        Heap.fromList [(i, iy <> jy), (j, jy)] <> js     During i j k ->-      nestingsAsc-        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)]-        <> js+      nestingsAsc do+        Heap.fromList [(i, jy), (j, iy <> jy), (k, jy)] <> js     Finishes i j ->-      nestingsAsc-        $ Heap.fromList [(i, iy), (j, iy <> jy)]-        <> js+      nestingsAsc do+        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 do+        Heap.fromList [(i, iy), (j, iy <> jy)] <> js     Contains i j k ->-      nestingsAsc-        $ Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)]-        <> js+      nestingsAsc do+        Heap.fromList [(i, iy), (j, iy <> jy), (k, iy)] <> js     StartedBy i j ->-      nestingsAsc-        $ Heap.fromList [(i, iy <> jy), (j, iy)]-        <> js+      nestingsAsc do+        Heap.fromList [(i, iy <> jy), (j, iy)] <> js     OverlappedBy i j k ->-      nestingsAsc-        $ Heap.fromList [(i, jy), (j, iy <> jy), (k, iy)]-        <> js+      nestingsAsc do+        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)
tests/Main.hs view
@@ -2,7 +2,10 @@  module Main where +import Algebra.Lattice (Lattice (..)) import Algebra.Lattice.Levitated (Levitated (..))+import Control.Applicative+import Control.Monad import Data.Interval (   Interval,   pattern (:<->:),@@ -14,12 +17,18 @@   pattern (:|>:),   pattern (:||:),  )+import Data.Interval qualified as Interval+import Data.Interval.Borel (Borel) 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+import Text.Parsec (sepBy, try)+import Text.Parsec.Char (char, digit, spaces, string)+import Text.Parsec.Text (Parser)+import Text.ParserCombinators.Parsec (choice)  type family Ints (n :: Nat) x where   Ints 0 x = x@@ -29,26 +38,15 @@ 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)-            (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)+      property @(Ints 2 _) \x y -> when (x > y) 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 "orient infinite intervals" do       (Top :<->: Bottom) `shouldBe` (Bottom :<->: Top :: Interval Int)@@ -57,7 +55,7 @@       (Top :|-|: Bottom) `shouldBe` (Bottom :|-|: Top :: Interval Int)      it "close point intervals" do-      property @(Int -> _) $ \x -> do+      property @(Int -> _) \x -> do         (x :<>: x) `shouldBe` (x :||: x)         (x :|>: x) `shouldBe` (x :||: x)         (x :<|: x) `shouldBe` (x :||: x)@@ -87,3 +85,71 @@             cdy = Layers.singleton (c :||: d) (Sum y)             efz = Layers.singleton (e :<>: f) (Sum z)         (abx <> cdy) <> efz `shouldBe` abx <> (cdy <> efz)++newtype Version = Version [Int]+  deriving (Eq, Ord, Show)++version :: Parser Version+version = Version <$> sepBy (read <$> many digit) (char '.')++data Tk+  = TkAnd+  | TkOr+  | TkBorel (Borel Version)+  | TkOpen+  | TkClose++tk :: Parser Tk+tk =+  choice+    [ try tkAnd+    , try tkOr+    , try do liftM2 ((TkBorel . Borel.singleton) .) tkCmp tkVersion+    , try tkOpen+    , try tkClose+    ]+ where+  tkAnd = TkAnd <$ (spaces *> string "&&" <* spaces)+  tkOr = TkOr <$ (spaces *> string "||" <* spaces)+  tkVersion = spaces *> version <* spaces+  tkCmp =+    choice+      [ (Bottom :<-|:) . Levitate <$ try do string "<="+      , (Bottom :<->:) . Levitate <$ try do string "<"+      , (:|->: Top) . Levitate <$ try do string ">="+      , (:<->: Top) . Levitate <$ try do string ">"+      , Interval.point <$ try do string "=="+      ]+  tkOpen = TkOpen <$ (spaces *> string "(" <* spaces)+  tkClose = TkClose <$ (spaces *> string ")" <* spaces)++foldTk :: [Tk] -> Borel Version+foldTk = \case+  [TkBorel b] -> b+  TkOpen : TkBorel b0 : TkAnd : TkBorel b1 : TkClose : rest ->+    foldTk do TkBorel (b0 /\ b1) : rest+  TkOpen : TkBorel b0 : TkOr : TkBorel b1 : TkClose : rest ->+    foldTk do TkBorel (b0 \/ b1) : rest+  TkBorel b0 : TkAnd : TkOpen : rest ->+    foldTk do TkBorel b0 : TkAnd : [TkBorel (foldTk (TkOpen : rest))]+  TkBorel b0 : TkOr : TkOpen : rest ->+    foldTk do TkBorel b0 : TkOr : [TkBorel (foldTk (TkOpen : rest))]+  TkBorel b0 : TkAnd : TkBorel b1 : rest -> foldTk do TkBorel (b0 /\ b1) : rest+  TkBorel b0 : TkOr : TkBorel b1 : rest -> foldTk do TkBorel (b0 \/ b1) : rest+  TkOpen : TkBorel b : TkClose : rest -> foldTk do TkBorel b : rest+  _ -> error "malformed bounds"++versionBounds :: Parser (Borel Version)+versionBounds = foldTk <$> many tk++-- >>> Text.Parsec.parse versionBounds "" ">= 2.0.0 && <3"+-- Right (Borel (fromList [(Version [2,0,0] :|>: Version [3])]))++-- >>> Text.Parsec.parse versionBounds "" ">= 4"+-- Right (Borel (fromList [(Levitate (Version [4]) :|->: Top)]))++-- >>> Text.Parsec.parse versionBounds "" "(>= 1.2 && <3) || (>= 4.0 && < 5)"+-- Right (Borel (fromList [(Version [1,2] :|>: Version [3]),(Version [4,0] :|>: Version [5])]))++-- >>> Text.Parsec.parse versionBounds "" "(>= 1.2 && <3) || (>= 2.0 && < 5)"+-- Right (Borel (fromList [(Version [1,2] :|>: Version [5])]))