diff --git a/.github/workflows/emulated.yml b/.github/workflows/emulated.yml index e753a51..30b71ad 100644 --- a/.github/workflows/emulated.yml +++ b/.github/workflows/emulated.yml @@ -33,7 +33,8 @@ jobs: githubToken: ${{ github.token }} install: | apt-get update -y - apt-get install -y ghc alex happy + apt-get install -y ghc alex happy cabal + cabal install Ranged-sets run: | (cd src/; alex -g Scan.x; happy -ag Parser.y) # Need to remove mention of the Cabal path module, and then substitutes @@ -45,7 +46,7 @@ jobs: sed -i "s/getDataDir/\(return \"$(pwd | sed 's/\//\\\//g')\\/data\"\)/g" src/Main.hs sed -i "s/version/undefined/g" src/Main.hs ghc -XHaskell2010 -XPatternSynonyms -XFlexibleContexts -XMagicHash -XCPP -XNondecreasingIndentation -XScopedTypeVariables -XTupleSections -XDeriveFunctor \ - -package array -package containers -package directory \ + -package array -package containers -package directory -package Ranged-sets \ -isrc src/Main.hs \ -o alex ./alex -g tests/simple.x diff --git a/NOTE.txt b/NOTE.txt deleted file mode 100644 index 6a92a0c..0000000 --- a/NOTE.txt +++ /dev/null @@ -1,9 +0,0 @@ -Note: - -The contents of package Ranged-sets-0.3.0 has been copied into this -package, in order to allow it to be part of the Haskell Platform, -without introducing additional dependencies. - -The original license agreement has been included in the src/Data -subdirectory, as required by the package source. - diff --git a/alex.cabal b/alex.cabal index f49fa58..7b2c3c3 100644 --- a/alex.cabal +++ b/alex.cabal @@ -111,6 +111,7 @@ executable alex , array , containers , directory + , Ranged-sets >= 0.5.0 && < 1 default-language: Haskell2010 @@ -142,10 +143,6 @@ executable alex Scan Util UTF8 - Data.Ranged - Data.Ranged.Boundaries - Data.Ranged.RangedSet - Data.Ranged.Ranges test-suite tests type: exitcode-stdio-1.0 diff --git a/src/Data/LICENSE.txt b/src/Data/LICENSE.txt deleted file mode 100644 index 79f9773..0000000 --- a/src/Data/LICENSE.txt +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2005, Paul Johnson -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * 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. - - * Neither the name of the Ranged Sets project 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 OWNER 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. diff --git a/src/Data/Ranged.hs b/src/Data/Ranged.hs deleted file mode 100644 index 2242485..0000000 --- a/src/Data/Ranged.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Data.Ranged ( - module Data.Ranged.Boundaries, - module Data.Ranged.Ranges, - module Data.Ranged.RangedSet -) where - -import Data.Ranged.Boundaries -import Data.Ranged.Ranges -import Data.Ranged.RangedSet diff --git a/src/Data/Ranged/Boundaries.hs b/src/Data/Ranged/Boundaries.hs deleted file mode 100644 index fb24eba..0000000 --- a/src/Data/Ranged/Boundaries.hs +++ /dev/null @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Ranged.Boundaries --- Copyright : (c) Paul Johnson 2006 --- License : BSD-style --- Maintainer : paul@cogito.org.uk --- Stability : experimental --- Portability : portable --- ------------------------------------------------------------------------------ - -module Data.Ranged.Boundaries ( - DiscreteOrdered (..), - enumAdjacent, - boundedAdjacent, - boundedBelow, - Boundary (..), - above, - (/>/) -) where - -import Data.Ratio -import Data.Word - -infix 4 />/ - -{- | -Distinguish between dense and sparse ordered types. A dense type is -one in which any two values @v1 < v2@ have a third value @v3@ such that -@v1 < v3 < v2@. - -In theory the floating types are dense, although in practice they can only have -finitely many values. This class treats them as dense. - -Tuples up to 4 members are declared as instances. Larger tuples may be added -if necessary. - -Most values of sparse types have an @adjacentBelow@, such that, for all x: - -> case adjacentBelow x of -> Just x1 -> adjacent x1 x -> Nothing -> True - -The exception is for bounded types when @x == lowerBound@. For dense types -@adjacentBelow@ always returns 'Nothing'. - -This approach was suggested by Ben Rudiak-Gould on comp.lang.functional. --} - -class Ord a => DiscreteOrdered a where - -- | Two values @x@ and @y@ are adjacent if @x < y@ and there does not - -- exist a third value between them. Always @False@ for dense types. - adjacent :: a -> a -> Bool - -- | The value immediately below the argument, if it can be determined. - adjacentBelow :: a -> Maybe a - - --- Implementation note: the precise rules about unbounded enumerated vs --- bounded enumerated types are difficult to express using Haskell 98, so --- the prelude types are listed individually here. - -instance DiscreteOrdered Bool where - adjacent = boundedAdjacent - adjacentBelow = boundedBelow - -instance DiscreteOrdered Ordering where - adjacent = boundedAdjacent - adjacentBelow = boundedBelow - -instance DiscreteOrdered Char where - adjacent = boundedAdjacent - adjacentBelow = boundedBelow - -instance DiscreteOrdered Int where - adjacent = boundedAdjacent - adjacentBelow = boundedBelow - -instance DiscreteOrdered Integer where - adjacent = enumAdjacent - adjacentBelow = Just . pred - -instance DiscreteOrdered Double where - adjacent _ _ = False - adjacentBelow = const Nothing - -instance DiscreteOrdered Float where - adjacent _ _ = False - adjacentBelow = const Nothing - -instance (Integral a) => DiscreteOrdered (Ratio a) where - adjacent _ _ = False - adjacentBelow = const Nothing - -instance Ord a => DiscreteOrdered [a] where - adjacent _ _ = False - adjacentBelow = const Nothing - -instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b) - where - adjacent (x1, x2) (y1, y2) = (x1 == y1) && adjacent x2 y2 - adjacentBelow (x1, x2) = do -- Maybe monad - x2' <- adjacentBelow x2 - return (x1, x2') - -instance (Ord a, Ord b, DiscreteOrdered c) => DiscreteOrdered (a, b, c) - where - adjacent (x1, x2, x3) (y1, y2, y3) = - (x1 == y1) && (x2 == y2) && adjacent x3 y3 - adjacentBelow (x1, x2, x3) = do -- Maybe monad - x3' <- adjacentBelow x3 - return (x1, x2, x3') - -instance (Ord a, Ord b, Ord c, DiscreteOrdered d) => - DiscreteOrdered (a, b, c, d) - where - adjacent (x1, x2, x3, x4) (y1, y2, y3, y4) = - (x1 == y1) && (x2 == y2) && (x3 == y3) && adjacent x4 y4 - adjacentBelow (x1, x2, x3, x4) = do -- Maybe monad - x4' <- adjacentBelow x4 - return (x1, x2, x3, x4') - -instance DiscreteOrdered Word8 where - adjacent x y = x + 1 == y - adjacentBelow 0 = Nothing - adjacentBelow x = Just (x-1) - - --- | Check adjacency for sparse enumerated types (i.e. where there --- is no value between @x@ and @succ x@). -enumAdjacent :: (Ord a, Enum a) => a -> a -> Bool -enumAdjacent x y = (succ x == y) - --- | Check adjacency, allowing for case where x = maxBound. Use as the --- definition of "adjacent" for bounded enumerated types such as Int and Char. -boundedAdjacent :: (Ord a, Enum a) => a -> a -> Bool -boundedAdjacent x y = if x < y then succ x == y else False - - --- | The usual implementation of 'adjacentBelow' for bounded enumerated types. -boundedBelow :: (Eq a, Enum a, Bounded a) => a -> Maybe a -boundedBelow x = if x == minBound then Nothing else Just $ pred x - -{- | -A Boundary is a division of an ordered type into values above -and below the boundary. No value can sit on a boundary. - -Known bug: for Bounded types - -* @BoundaryAbove maxBound < BoundaryAboveAll@ - -* @BoundaryBelow minBound > BoundaryBelowAll@ - -This is incorrect because there are no possible values in -between the left and right sides of these inequalities. --} - -data Boundary a = - -- | The argument is the highest value below the boundary. - BoundaryAbove a | - -- | The argument is the lowest value above the boundary. - BoundaryBelow a | - -- | The boundary above all values. - BoundaryAboveAll | - -- | The boundary below all values. - BoundaryBelowAll - deriving (Show) - --- | True if the value is above the boundary, false otherwise. -above :: Ord v => Boundary v -> v -> Bool -above (BoundaryAbove b) v = v > b -above (BoundaryBelow b) v = v >= b -above BoundaryAboveAll _ = False -above BoundaryBelowAll _ = True - --- | Same as 'above', but with the arguments reversed for more intuitive infix --- usage. -(/>/) :: Ord v => v -> Boundary v -> Bool -(/>/) = flip above - -instance (DiscreteOrdered a) => Eq (Boundary a) where - b1 == b2 = compare b1 b2 == EQ - -instance (DiscreteOrdered a) => Ord (Boundary a) where - -- Comparison alogrithm based on brute force and ignorance: - -- enumerate all combinations. - - compare boundary1 boundary2 = - case boundary1 of - BoundaryAbove b1 -> - case boundary2 of - BoundaryAbove b2 -> compare b1 b2 - BoundaryBelow b2 -> - if b1 < b2 - then - if adjacent b1 b2 then EQ else LT - else GT - BoundaryAboveAll -> LT - BoundaryBelowAll -> GT - BoundaryBelow b1 -> - case boundary2 of - BoundaryAbove b2 -> - if b1 > b2 - then - if adjacent b2 b1 then EQ else GT - else LT - BoundaryBelow b2 -> compare b1 b2 - BoundaryAboveAll -> LT - BoundaryBelowAll -> GT - BoundaryAboveAll -> - case boundary2 of - BoundaryAboveAll -> EQ - _ -> GT - BoundaryBelowAll -> - case boundary2 of - BoundaryBelowAll -> EQ - _ -> LT diff --git a/src/Data/Ranged/RangedSet.hs b/src/Data/Ranged/RangedSet.hs deleted file mode 100644 index 09d2e8d..0000000 --- a/src/Data/Ranged/RangedSet.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.Ranged.RangedSet ( - -- ** Ranged Set Type - RSet, - rSetRanges, - -- ** Ranged Set construction functions and their preconditions - makeRangedSet, - unsafeRangedSet, - validRangeList, - normaliseRangeList, - rSingleton, - rSetUnfold, - -- ** Predicates - rSetIsEmpty, - rSetIsFull, - (-?-), rSetHas, - (-<=-), rSetIsSubset, - (-<-), rSetIsSubsetStrict, - -- ** Set Operations - (-\/-), rSetUnion, - (-/\-), rSetIntersection, - (-!-), rSetDifference, - rSetNegation, - -- ** Useful Sets - rSetEmpty, - rSetFull, -) where - -import Data.Ranged.Boundaries -import Data.Ranged.Ranges -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - -import qualified Data.List as List - -infixl 7 -/\- -infixl 6 -\/-, -!- -infixl 5 -<=-, -<-, -?- - --- | An RSet (for Ranged Set) is a list of ranges. The ranges must be sorted --- and not overlap. -newtype DiscreteOrdered v => RSet v = RSet {rSetRanges :: [Range v]} - deriving (Eq, Show, Ord) - -instance DiscreteOrdered a => Semigroup (RSet a) where - (<>) = rSetUnion - -instance DiscreteOrdered a => Monoid (RSet a) where - mempty = rSetEmpty - mappend = (<>) - --- | Determine if the ranges in the list are both in order and non-overlapping. --- If so then they are suitable input for the unsafeRangedSet function. -validRangeList :: DiscreteOrdered v => [Range v] -> Bool -validRangeList rs = and $ - all (\ (Range lower upper) -> lower <= upper) rs : - zipWith (\ (Range _ upper1) (Range lower2 _) -> upper1 <= lower2) rs (drop 1 rs) - - --- | Rearrange and merge the ranges in the list so that they are in order and --- non-overlapping. -normaliseRangeList :: DiscreteOrdered v => [Range v] -> [Range v] -normaliseRangeList = normalise . List.sort . filter (not . rangeIsEmpty) - - --- Private routine: normalise a range list that is known to be already sorted. --- This precondition is not checked. -normalise :: DiscreteOrdered v => [Range v] -> [Range v] -normalise (r1:r2:rs) = - if overlap r1 r2 - then normalise $ - Range (rangeLower r1) - (max (rangeUpper r1) (rangeUpper r2)) - : rs - else r1 : (normalise $ r2 : rs) - where - overlap (Range _ upper1) (Range lower2 _) = upper1 >= lower2 - -normalise rs = rs - - --- | Create a new Ranged Set from a list of ranges. The list may contain --- ranges that overlap or are not in ascending order. -makeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v -makeRangedSet = RSet . normaliseRangeList - - --- | Create a new Ranged Set from a list of ranges. @validRangeList ranges@ --- must return @True@. This precondition is not checked. -unsafeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v -unsafeRangedSet = RSet - --- | Create a Ranged Set from a single element. -rSingleton :: DiscreteOrdered v => v -> RSet v -rSingleton v = unsafeRangedSet [singletonRange v] - --- | True if the set has no members. -rSetIsEmpty :: DiscreteOrdered v => RSet v -> Bool -rSetIsEmpty = null . rSetRanges - - --- | True if the negation of the set has no members. -rSetIsFull :: DiscreteOrdered v => RSet v -> Bool -rSetIsFull = rSetIsEmpty . rSetNegation - - --- | True if the value is within the ranged set. Infix precedence is left 5. -rSetHas, (-?-) :: DiscreteOrdered v => RSet v -> v -> Bool -rSetHas (RSet ls) value = rSetHas1 ls - where - rSetHas1 [] = False - rSetHas1 (r:rs) - | value />/ rangeLower r = rangeHas r value || rSetHas1 rs - | otherwise = False - -(-?-) = rSetHas - --- | True if the first argument is a subset of the second argument, or is --- equal. --- --- Infix precedence is left 5. -rSetIsSubset, (-<=-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool -rSetIsSubset rs1 rs2 = rSetIsEmpty (rs1 -!- rs2) -(-<=-) = rSetIsSubset - - --- | True if the first argument is a strict subset of the second argument. --- --- Infix precedence is left 5. -rSetIsSubsetStrict, (-<-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool -rSetIsSubsetStrict rs1 rs2 = - rSetIsEmpty (rs1 -!- rs2) - && not (rSetIsEmpty (rs2 -!- rs1)) - -(-<-) = rSetIsSubsetStrict - --- | Set union for ranged sets. Infix precedence is left 6. -rSetUnion, (-\/-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v --- Implementation note: rSetUnion merges the two lists into a single --- sorted list and then calls normalise to combine overlapping ranges. -rSetUnion (RSet ls1) (RSet ls2) = RSet $ normalise $ merge ls1 ls2 - where - merge ms1 [] = ms1 - merge [] ms2 = ms2 - merge ms1@(h1:t1) ms2@(h2:t2) = - if h1 < h2 - then h1 : merge t1 ms2 - else h2 : merge ms1 t2 - -(-\/-) = rSetUnion - --- | Set intersection for ranged sets. Infix precedence is left 7. -rSetIntersection, (-/\-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v -rSetIntersection (RSet ls1) (RSet ls2) = - RSet $ filter (not . rangeIsEmpty) $ merge ls1 ls2 - where - merge ms1@(h1:t1) ms2@(h2:t2) = - rangeIntersection h1 h2 - : if rangeUpper h1 < rangeUpper h2 - then merge t1 ms2 - else merge ms1 t2 - merge _ _ = [] - -(-/\-) = rSetIntersection - - --- | Set difference. Infix precedence is left 6. -rSetDifference, (-!-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v -rSetDifference rs1 rs2 = rs1 -/\- (rSetNegation rs2) -(-!-) = rSetDifference - - --- | Set negation. -rSetNegation :: DiscreteOrdered a => RSet a -> RSet a -rSetNegation set = RSet $ ranges1 $ setBounds1 - where - ranges1 (b1:b2:bs) = Range b1 b2 : ranges1 bs - ranges1 [BoundaryAboveAll] = [] - ranges1 [b] = [Range b BoundaryAboveAll] - ranges1 _ = [] - setBounds1 = case setBounds of - (BoundaryBelowAll : bs) -> bs - _ -> BoundaryBelowAll : setBounds - setBounds = bounds $ rSetRanges set - bounds (r:rs) = rangeLower r : rangeUpper r : bounds rs - bounds _ = [] - --- | The empty set. -rSetEmpty :: DiscreteOrdered a => RSet a -rSetEmpty = RSet [] - --- | The set that contains everything. -rSetFull :: DiscreteOrdered a => RSet a -rSetFull = RSet [Range BoundaryBelowAll BoundaryAboveAll] - --- | Construct a range set. -rSetUnfold :: DiscreteOrdered a => - Boundary a - -- ^ A first lower boundary. - -> (Boundary a -> Boundary a) - -- ^ A function from a lower boundary to an upper boundary, which must - -- return a result greater than the argument (not checked). - -> (Boundary a -> Maybe (Boundary a)) - -- ^ A function from a lower boundary to @Maybe@ the successor lower - -- boundary, which must return a result greater than the argument - -- (not checked). If ranges overlap then they will be merged. - -> RSet a -rSetUnfold bound upperFunc succFunc = RSet $ normalise $ ranges1 bound - where - ranges1 b = - Range b (upperFunc b) - : case succFunc b of - Just b2 -> ranges1 b2 - Nothing -> [] diff --git a/src/Data/Ranged/Ranges.hs b/src/Data/Ranged/Ranges.hs deleted file mode 100644 index fa2df31..0000000 --- a/src/Data/Ranged/Ranges.hs +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Data.Ranged.Ranges --- Copyright : (c) Paul Johnson 2006 --- License : BSD-style --- Maintainer : paul@cogito.org.uk --- Stability : experimental --- Portability : portable --- ------------------------------------------------------------------------------ - --- | A range has an upper and lower boundary. -module Data.Ranged.Ranges ( - -- ** Construction - Range (..), - emptyRange, - fullRange, - -- ** Predicates - rangeIsEmpty, - rangeIsFull, - rangeOverlap, - rangeEncloses, - rangeSingletonValue, - -- ** Membership - rangeHas, - rangeListHas, - -- ** Set Operations - singletonRange, - rangeIntersection, - rangeUnion, - rangeDifference, -) where - -import Data.Ranged.Boundaries - --- | A Range has upper and lower boundaries. -data Range v = Range {rangeLower, rangeUpper :: Boundary v} - -instance (DiscreteOrdered a) => Eq (Range a) where - r1 == r2 = (rangeIsEmpty r1 && rangeIsEmpty r2) || - (rangeLower r1 == rangeLower r2 && - rangeUpper r1 == rangeUpper r2) - - -instance (DiscreteOrdered a) => Ord (Range a) where - compare r1 r2 - | r1 == r2 = EQ - | rangeIsEmpty r1 = LT - | rangeIsEmpty r2 = GT - | otherwise = compare (rangeLower r1, rangeUpper r1) - (rangeLower r2, rangeUpper r2) - -instance (Show a, DiscreteOrdered a) => Show (Range a) where - show r - | rangeIsEmpty r = "Empty" - | rangeIsFull r = "All x" - | otherwise = - case rangeSingletonValue r of - Just v -> "x == " ++ show v - Nothing -> lowerBound ++ "x" ++ upperBound - where - lowerBound = case rangeLower r of - BoundaryBelowAll -> "" - BoundaryBelow v -> show v ++ " <= " - BoundaryAbove v -> show v ++ " < " - BoundaryAboveAll -> error "show Range: lower bound is BoundaryAboveAll" - upperBound = case rangeUpper r of - BoundaryBelowAll -> error "show Range: upper bound is BoundaryBelowAll" - BoundaryBelow v -> " < " ++ show v - BoundaryAbove v -> " <= " ++ show v - BoundaryAboveAll -> "" - - --- | True if the value is within the range. -rangeHas :: Ord v => Range v -> v -> Bool - -rangeHas (Range b1 b2) v = - (v />/ b1) && not (v />/ b2) - - --- | True if the value is within one of the ranges. -rangeListHas :: Ord v => - [Range v] -> v -> Bool -rangeListHas ls v = or $ map (\r -> rangeHas r v) ls - - --- | The empty range -emptyRange :: Range v -emptyRange = Range BoundaryAboveAll BoundaryBelowAll - - --- | The full range. All values are within it. -fullRange :: Range v -fullRange = Range BoundaryBelowAll BoundaryAboveAll - - --- | A range containing a single value -singletonRange :: v -> Range v -singletonRange v = Range (BoundaryBelow v) (BoundaryAbove v) - - --- | If the range is a singleton, returns @Just@ the value. Otherwise returns --- @Nothing@. --- --- Known bug: This always returns @Nothing@ for ranges including --- @BoundaryBelowAll@ or @BoundaryAboveAll@. For bounded types this can be --- incorrect. For instance, the following range only contains one value: --- --- > Range (BoundaryBelow maxBound) BoundaryAboveAll -rangeSingletonValue :: DiscreteOrdered v => Range v -> Maybe v -rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryBelow v2)) - | adjacent v1 v2 = Just v1 - | otherwise = Nothing -rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryAbove v2)) - | v1 == v2 = Just v1 - | otherwise = Nothing -rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryBelow v2)) = - do - v2' <- adjacentBelow v2 - v2'' <- adjacentBelow v2' - if v1 == v2'' then return v2' else Nothing -rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryAbove v2)) - | adjacent v1 v2 = Just v2 - | otherwise = Nothing -rangeSingletonValue (Range _ _) = Nothing - --- | A range is empty unless its upper boundary is greater than its lower --- boundary. -rangeIsEmpty :: DiscreteOrdered v => Range v -> Bool -rangeIsEmpty (Range lower upper) = upper <= lower - - --- | A range is full if it contains every possible value. -rangeIsFull :: DiscreteOrdered v => Range v -> Bool -rangeIsFull = (== fullRange) - --- | Two ranges overlap if their intersection is non-empty. -rangeOverlap :: DiscreteOrdered v => Range v -> Range v -> Bool -rangeOverlap r1 r2 = - not (rangeIsEmpty r1) - && not (rangeIsEmpty r2) - && not (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1) - - --- | The first range encloses the second if every value in the second range is --- also within the first range. If the second range is empty then this is --- always true. -rangeEncloses :: DiscreteOrdered v => Range v -> Range v -> Bool -rangeEncloses r1 r2 = - (rangeLower r1 <= rangeLower r2 && rangeUpper r2 <= rangeUpper r1) - || rangeIsEmpty r2 - - --- | Intersection of two ranges, if any. -rangeIntersection :: DiscreteOrdered v => Range v -> Range v -> Range v -rangeIntersection r1@(Range lower1 upper1) r2@(Range lower2 upper2) - | rangeIsEmpty r1 || rangeIsEmpty r2 = emptyRange - | otherwise = Range (max lower1 lower2) (min upper1 upper2) - - --- | Union of two ranges. Returns one or two results. --- --- If there are two results then they are guaranteed to have a non-empty --- gap in between, but may not be in ascending order. -rangeUnion :: DiscreteOrdered v => Range v -> Range v -> [Range v] -rangeUnion r1@(Range lower1 upper1) r2@(Range lower2 upper2) - | rangeIsEmpty r1 = [r2] - | rangeIsEmpty r2 = [r1] - | otherwise = - if touching then [Range lower upper] else [r1, r2] - where - touching = (max lower1 lower2) <= (min upper1 upper2) - lower = min lower1 lower2 - upper = max upper1 upper2 - - --- | @range1@ minus @range2@. Returns zero, one or two results. Multiple --- results are guaranteed to have non-empty gaps in between, but may not be in --- ascending order. -rangeDifference :: DiscreteOrdered v => Range v -> Range v -> [Range v] - -rangeDifference r1@(Range lower1 upper1) (Range lower2 upper2) = - -- There are six possibilities - -- 1: r2 completely less than r1 - -- 2: r2 overlaps bottom of r1 - -- 3: r2 encloses r1 - -- 4: r1 encloses r2 - -- 5: r2 overlaps top of r1 - -- 6: r2 completely greater than r1 - if intersects - then -- Cases 2,3,4,5 - filter (not . rangeIsEmpty) [Range lower1 lower2, Range upper2 upper1] - else -- Cases 1, 6 - [r1] - where - intersects = (max lower1 lower2) < (min upper1 upper2)