diff --git a/Data/Range/Data.hs b/Data/Range/Data.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Data.hs @@ -0,0 +1,27 @@ +-- | The Data module for common data types within the code. +module Data.Range.Data where + +-- | The Range Data structure; it is capable of representing any type of range. This is +-- the primary data structure in this library. Everything should be possible to convert +-- back into this datatype. All ranges in this structure are inclusively bound. +data Range a + = SingletonRange a -- ^ Represents a single element as a range. + | SpanRange a a -- ^ Represents a bounded and inclusive range of elements. + | LowerBoundRange a -- ^ Represents a range with only an inclusive lower bound. + | UpperBoundRange a -- ^ Represents a range with only an inclusive upper bound. + | InfiniteRange -- ^ Represents an infinite range over all values. + deriving(Eq, Show) + +-- | These are the operations that can join two disjunct lists of ranges together. +data RangeOperation + = RangeUnion -- ^ Represents the set union operation. + | RangeIntersection -- ^ Represents the set intersection operation. + +-- | A Range Tree is a construct that can be built and then efficiently evaluated so that +-- you can compress an entire tree of operations on ranges into a single range quickly. +-- The only purpose of this tree is to allow efficient construction of range operations +-- that can be evaluated as is required. +data RangeTree a + = RangeNode RangeOperation (RangeTree a) (RangeTree a) -- ^ Combine two range trees together with a single operation + | RangeNodeInvert (RangeTree a) -- ^ Invert a range tree, this is a 'not' operation. + | RangeLeaf [Range a] -- ^ A leaf with a set of ranges that are collected together. diff --git a/Data/Range/NestedRange.hs b/Data/Range/NestedRange.hs new file mode 100644 --- /dev/null +++ b/Data/Range/NestedRange.hs @@ -0,0 +1,27 @@ +-- | Nested Ranges are common in practical usage. They appear in such forms as library +-- version numbers ("Version 1.4.5.6" for example). And it is very useful to be able to +-- compare these ranges to one another. This module exists for the purpose of allowing +-- these comparisons between nested ranges. The module builds upon the basic range concept +-- from other parts of this library. +module Data.Range.NestedRange where + +import Data.Range.Range + +-- | The Nested Range is a structure that in a nested form of many ranges where there can +-- be multiple ranges at every level. +data NestedRange a = NestedRange [[Range a]] + + +-- I wanted to know if a nested number of elements are in a given range. That way I can +-- just immediately run a single function and tell things about ranges. + +-- | Given a list of nested values and a nested range tell us wether the nested value +-- exists inside the nested range. +inNestedRange :: Ord a => [a] -> NestedRange a -> Bool +inNestedRange values (NestedRange ranges) = go values ranges + where + go :: Ord a => [a] -> [[Range a]] -> Bool + go [] [] = True -- If there is nothing left then they are equal + go _ [] = True -- If you have already found the values you have to be in range then they are + go [] _ = False -- If you have not fully matched it yet then it is not in range. + go (value : vs) (range : rs) = inRanges range value && go vs rs diff --git a/Data/Range/Parser.hs b/Data/Range/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Parser.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | It should not be unexpected that you will be given a string representation of some +-- ranges and you will need to parse them so that you can then do some further processing. +-- This parser exists in order to make the most common forms of range strings easy to +-- parse. It does not cover all cases however but you should not be too worried about +-- that because you should be able to write your own parser using parsec or Alex/Happy and +-- then you can convert everything that you parse into a RangeTree object for easier +-- processing. +module Data.Range.Parser + ( parseRanges + , ranges + , RangeParserArgs(..) + , defaultArgs + ) where + +import Text.Parsec +import Text.Parsec.String + +import Data.Range.Range + +-- | The arguments that are used, and can be modified, while parsing a standard range +-- string. +data RangeParserArgs = Args + { unionSeparator :: String -- ^ A separator that represents a union. + , rangeSeparator :: String -- ^ A separator that separates the two halves of a range. + , wildcardSymbol :: String -- ^ A separator that implies an unbounded range. + } + deriving(Show) + +-- | These are the default arguments that are used by the parser. Please feel free to use +-- the default arguments for you own parser and modify it from the defaults at will. +defaultArgs :: RangeParserArgs +defaultArgs = Args + { unionSeparator = "," + , rangeSeparator = "-" + , wildcardSymbol = "*" + } + +-- | Given a string this function will either return a parse error back to the user or the +-- list of ranges that are represented by the parsed string. +parseRanges :: (Read a) => String -> Either ParseError [Range a] +parseRanges = parse (ranges defaultArgs) "(range parser)" + +string_ :: Stream s m Char => String -> ParsecT s u m () +string_ x = string x >> return () + +-- | Given the parser arguments this returns a parser that is capable of parsing a list of +-- ranges. +ranges :: (Read a) => RangeParserArgs -> Parser [Range a] +ranges args = range `sepBy` (string $ unionSeparator args) + where + range :: (Read a) => Parser (Range a) + range = choice + [ infiniteRange + , spanRange + , singletonRange + ] + + infiniteRange :: (Read a) => Parser (Range a) + infiniteRange = do + string_ $ wildcardSymbol args + return InfiniteRange + + spanRange :: (Read a) => Parser (Range a) + spanRange = try $ do + first <- readSection + string_ $ rangeSeparator args + second <- readSection + case (first, second) of + (Just x, Just y) -> return $ SpanRange x y + (Just x, _) -> return $ LowerBoundRange x + (_, Just y) -> return $ UpperBoundRange y + _ -> parserFail ("Range should have a number on one end: " ++ rangeSeparator args) + + singletonRange :: (Read a) => Parser (Range a) + singletonRange = fmap (SingletonRange . read) $ many1 digit + +readSection :: (Read a) => Parser (Maybe a) +readSection = fmap (fmap read) $ optionMaybe (many1 digit) diff --git a/Data/Range/Range.hs b/Data/Range/Range.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Range.hs @@ -0,0 +1,88 @@ +-- | This entire library is concerned with ranges and this module implements the absolute +-- basic range functions. +module Data.Range.Range ( + Range(..), + inRange, + inRanges, + rangesOverlap, + mergeRanges, + invert, + union, + intersection, + fromRanges + ) where + +import Data.Range.Data +import Data.Range.RangeInternal +import Data.Range.Util + +-- | Performs a set union between the two input ranges and returns the resultant set of +-- ranges. +union :: (Ord a, Enum a) => [Range a] -> [Range a] -> [Range a] +union a b = exportRangeMerge $ unionRangeMerges (loadRanges a) (loadRanges b) + +-- | Performs a set intersection between the two input ranges and returns the resultant set of +-- ranges. +intersection :: (Ord a, Enum a) => [Range a] -> [Range a] -> [Range a] +intersection a b = exportRangeMerge $ intersectionRangeMerges (loadRanges a) (loadRanges b) + +-- | An inversion function, given a set of ranges it returns the inverse set of ranges. +invert :: (Ord a, Enum a) => [Range a] -> [Range a] +invert = exportRangeMerge . invertRM . loadRanges + +-- | A check to see if two ranges overlap. If they do then true is returned; false +-- otherwise. +rangesOverlap :: (Ord a) => Range a -> Range a -> Bool +rangesOverlap (SingletonRange a) (SingletonRange b) = a == b +rangesOverlap (SingletonRange a) (SpanRange x y) = isBetween a (x, y) +rangesOverlap (SingletonRange a) (LowerBoundRange lower) = lower <= a +rangesOverlap (SingletonRange a) (UpperBoundRange upper) = a <= upper +rangesOverlap (SpanRange x y) (SpanRange a b) = isBetween x (a, b) || isBetween a (x, y) +rangesOverlap (SpanRange _ y) (LowerBoundRange lower) = lower <= y +rangesOverlap (SpanRange x _) (UpperBoundRange upper) = x <= upper +rangesOverlap (LowerBoundRange _) (LowerBoundRange _) = True +rangesOverlap (LowerBoundRange x) (UpperBoundRange y) = x <= y +rangesOverlap (UpperBoundRange _) (UpperBoundRange _) = True +rangesOverlap InfiniteRange _ = True +rangesOverlap a b = rangesOverlap b a + +-- | Given a range and a value it will tell you wether or not the value is in the range. +-- Remember that all ranges are inclusive. +inRange :: (Ord a) => Range a -> a -> Bool +inRange (SingletonRange a) value = value == a +inRange (SpanRange x y) value = isBetween value (x, y) +inRange (LowerBoundRange lower) value = lower <= value +inRange (UpperBoundRange upper) value = value <= upper +inRange InfiniteRange _ = True + +-- | Given a list of ranges this function tells you if a value is in any of those ranges. +-- This is especially useful for more complex ranges. +inRanges :: (Ord a) => [Range a] -> a -> Bool +inRanges ranges value = any (flip inRange value) ranges + +-- | When you create a range there may be overlaps in your ranges. However, for the sake +-- of efficiency you probably want the list of ranges with no overlaps. The mergeRanges +-- function takes a set of ranges and returns the same set specified by the minimum number +-- of Range objects. A useful function for cleaning up your ranges. Please note that, if +-- you use any of the other operations on sets of ranges like invert, union and +-- intersection then this is automatically done for you. Which means that a function like +-- this is redundant: mergeRanges . intersection +mergeRanges :: (Ord a, Enum a) => [Range a] -> [Range a] +mergeRanges = exportRangeMerge . loadRanges + +-- | A set of ranges represents a collection of real values without actually instantiating +-- those values. This allows you to have infinite ranges. However, sometimes you wish to +-- actually get the values that your range represents, or even get a sample set of the +-- values. This function generates as many of the values that belong to your range as you +-- like. +fromRanges :: (Ord a, Enum a) => [Range a] -> [a] +fromRanges = concatMap fromRange + where + fromRange range = case range of + SingletonRange x -> [x] + SpanRange a b -> [a..b] + LowerBoundRange x -> iterate succ x + UpperBoundRange x -> iterate pred x + InfiniteRange -> zero : takeEvenly (tail $ iterate succ zero) (tail $ iterate pred zero) + where + zero = toEnum 0 diff --git a/Data/Range/RangeInternal.hs b/Data/Range/RangeInternal.hs new file mode 100644 --- /dev/null +++ b/Data/Range/RangeInternal.hs @@ -0,0 +1,319 @@ +module Data.Range.RangeInternal where + +import Data.Maybe (catMaybes) +--import Data.Ord (comparing) + +import Data.Range.Data +import Data.Range.Spans +import Data.Range.Util + +{- + - The following assumptions must be maintained at the beginning of these internal + - functions so that we can reason about what we are given. + - + - RangeMerge assumptions: + - * The span ranges will never overlap the bounds. + - * The span ranges are always sorted in ascending order by the first element. + - * The lower and upper bounds never overlap in such a way to make it an infinite range. + -} +data RangeMerge a = RM + { largestLowerBound :: Maybe a + , largestUpperBound :: Maybe a + , spanRanges :: [(a, a)] + } + | IRM + deriving (Show, Eq) + +emptyRangeMerge :: RangeMerge a +emptyRangeMerge = RM Nothing Nothing [] + +storeRange :: (Ord a) => Range a -> RangeMerge a +storeRange InfiniteRange = IRM +storeRange (LowerBoundRange lower) = emptyRangeMerge { largestLowerBound = Just lower } +storeRange (UpperBoundRange upper) = emptyRangeMerge { largestUpperBound = Just upper } +storeRange (SpanRange x y) = emptyRangeMerge { spanRanges = [(min x y, max x y)] } +storeRange (SingletonRange x) = emptyRangeMerge { spanRanges = [(x, x)] } + +storeRanges :: (Ord a, Enum a) => RangeMerge a -> [Range a] -> RangeMerge a +storeRanges start ranges = foldr unionRangeMerges start (map storeRange ranges) + +loadRanges :: (Ord a, Enum a) => [Range a] -> RangeMerge a +loadRanges = storeRanges emptyRangeMerge + +exportRangeMerge :: (Ord a, Enum a) => RangeMerge a -> [Range a] +exportRangeMerge IRM = [InfiniteRange] +exportRangeMerge rm = putAll rm + where + putAll IRM = [InfiniteRange] + putAll (RM lb up spans) = + putLowerBound lb ++ putUpperBound up ++ putSpans spans + + putLowerBound = maybe [] (return . LowerBoundRange) + putUpperBound = maybe [] (return . UpperBoundRange) + putSpans = map simplifySpan + + simplifySpan (x, y) = if x == y + then SingletonRange x + else SpanRange x y + +intersectSpansRM :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a +intersectSpansRM one two = RM Nothing Nothing newSpans + where + newSpans = intersectSpans (spanRanges one) (spanRanges two) + +intersectWith :: (Ord a) => (a -> (a, a) -> Maybe (a, a)) -> Maybe a -> [(a, a)] -> [(a, a)] +intersectWith _ Nothing _ = [] +intersectWith fix (Just lower) xs = catMaybes $ fmap (fix lower) xs + +fixLower :: (Ord a) => a -> (a, a) -> Maybe (a, a) +fixLower lower (x, y) = if lower <= y + then Just (max lower x, y) + else Nothing + +fixUpper :: (Ord a) => a -> (a, a) -> Maybe (a, a) +fixUpper upper (x, y) = if x <= upper + then Just (x, min y upper) + else Nothing + +intersectionRangeMerges :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> RangeMerge a +intersectionRangeMerges IRM two = two +intersectionRangeMerges one IRM = one +intersectionRangeMerges one two = RM + { largestLowerBound = newLowerBound + , largestUpperBound = newUpperBound + , spanRanges = joinedSpans + } + where + lowerOneSpans = intersectWith fixLower (largestLowerBound one) (spanRanges two) + lowerTwoSpans = intersectWith fixLower (largestLowerBound two) (spanRanges one) + upperOneSpans = intersectWith fixUpper (largestUpperBound one) (spanRanges two) + upperTwoSpans = intersectWith fixUpper (largestUpperBound two) (spanRanges one) + intersectedSpans = intersectSpans (spanRanges one) (spanRanges two) + + sortedResults = foldr1 insertionSortSpans + [ lowerOneSpans + , lowerTwoSpans + , upperOneSpans + , upperTwoSpans + , intersectedSpans + , calculateBoundOverlap one two + ] + + joinedSpans = joinSpans . unionSpans $ sortedResults + + newLowerBound = calculateNewBound largestLowerBound max one two + newUpperBound = calculateNewBound largestUpperBound min one two + + calculateNewBound + :: (Ord a) + => (RangeMerge a -> Maybe a) + -> (a -> a -> a) + -> RangeMerge a -> RangeMerge a -> Maybe a + calculateNewBound ext comp one two = case (ext one, ext two) of + (Just x, Just y) -> Just $ comp x y + (_, Nothing) -> Nothing + (Nothing, _) -> Nothing + +calculateBoundOverlap :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> [(a, a)] +calculateBoundOverlap one two = catMaybes [oneWay, secondWay] + where + oneWay = case (largestLowerBound one, largestUpperBound two) of + (Just x, Just y) -> if y >= x + then Just (x, y) + else Nothing + _ -> Nothing + + secondWay = case (largestLowerBound two, largestUpperBound one) of + (Just x, Just y) -> if y >= x + then Just (x, y) + else Nothing + _ -> Nothing + +unionRangeMerges :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> RangeMerge a +unionRangeMerges IRM _ = IRM +unionRangeMerges _ IRM = IRM +unionRangeMerges one two = infiniteCheck filterTwo + where + filterOne = foldr filterLowerBound boundedRM joinedSpans + filterTwo = foldr filterUpperBound (filterOne { spanRanges = [] }) (spanRanges filterOne) + + infiniteCheck :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a + infiniteCheck IRM = IRM + infiniteCheck rm@(RM (Just x) (Just y) _) = if x <= succ y + then IRM + else rm + infiniteCheck rm = rm + + newLowerBound = calculateNewBound largestLowerBound min one two + newUpperBound = calculateNewBound largestUpperBound max one two + + sortedSpans = insertionSortSpans (spanRanges one) (spanRanges two) + joinedSpans = joinSpans . unionSpans $ sortedSpans + + boundedRM = RM + { largestLowerBound = newLowerBound + , largestUpperBound = newUpperBound + , spanRanges = [] + } + + calculateNewBound + :: (Ord a) + => (RangeMerge a -> Maybe a) + -> (a -> a -> a) + -> RangeMerge a -> RangeMerge a -> Maybe a + calculateNewBound ext comp one two = case (ext one, ext two) of + (Just x, Just y) -> Just $ comp x y + (z, Nothing) -> z + (Nothing, z) -> z + +filterLowerBound :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a +filterLowerBound _ IRM = IRM +filterLowerBound a rm@(RM Nothing _ _) = rm { spanRanges = a : spanRanges rm } +filterLowerBound s@(lower, _) rm@(RM (Just lowestBound) _ _) = + case boundCmp lowestBound s of + GT -> rm { spanRanges = s : spanRanges rm } + LT -> rm + EQ -> rm { largestLowerBound = Just $ min lowestBound lower } + +filterUpperBound :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a +filterUpperBound _ IRM = IRM +filterUpperBound a rm@(RM _ Nothing _) = rm { spanRanges = a : spanRanges rm } +filterUpperBound s@(_, upper) rm@(RM _ (Just upperBound) _) = + case boundCmp upperBound s of + LT -> rm { spanRanges = s : spanRanges rm } + GT -> rm + EQ -> rm { largestUpperBound = Just $ max upperBound upper } + +boundCmp :: (Ord a, Enum a) => a -> (a, a) -> Ordering +boundCmp x (a, b) = if isBetween x (pred a, succ b) + then EQ + else if x < pred a then LT else GT + +appendSpanRM :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a +appendSpanRM _ IRM = IRM +appendSpanRM sp@(lower, higher) rm = + if (newUpper, newLower) == (lub, llb) && isLower lower newLower && (Just higher) > newUpper + then newRangesRM + { spanRanges = sp : spanRanges rm + } + else newRangesRM + { spanRanges = spanRanges rm + } + where + newRangesRM = rm + { largestLowerBound = newLower + , largestUpperBound = newUpper + } + + isLower :: Ord a => a -> Maybe a -> Bool + isLower _ Nothing = True + isLower y (Just x) = y < x + + lub = largestUpperBound rm + llb = largestLowerBound rm + + newLower = do + bound <- llb + return $ if bound <= higher + then min bound lower + else bound + + newUpper = do + bound <- lub + return $ if lower <= bound + then max bound higher + else bound + +invertRM :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a +invertRM IRM = emptyRangeMerge +invertRM (RM Nothing Nothing []) = IRM +invertRM (RM (Just lower) Nothing []) = RM Nothing (Just . pred $ lower) [] +invertRM (RM Nothing (Just upper) []) = RM (Just . succ $ upper) Nothing [] +invertRM (RM (Just lower) (Just upper) []) = RM Nothing Nothing [(succ upper, pred lower)] +invertRM rm = RM + { largestUpperBound = newUpperBound + , largestLowerBound = newLowerBound + , spanRanges = upperSpan ++ betweenSpans ++ lowerSpan + } + where + newLowerValue = succ . snd . last . spanRanges $ rm + newUpperValue = pred . fst . head . spanRanges $ rm + + newUpperBound = case largestUpperBound rm of + Just _ -> Nothing + Nothing -> Just newUpperValue + + newLowerBound = case largestLowerBound rm of + Just _ -> Nothing + Nothing -> Just newLowerValue + + upperSpan = case largestUpperBound rm of + Nothing -> [] + Just upper -> [(succ upper, newUpperValue)] + lowerSpan = case largestLowerBound rm of + Nothing -> [] + Just lower -> [(newLowerValue, pred lower)] + + betweenSpans = invertSpans . spanRanges $ rm + +{- +unionRange :: (Ord a) => Range a -> RangeMerge a -> RangeMerge a +unionRange InfiniteRange rm = IRM +unionRange (LowerBoundRange lower) rm = case largestLowerBound rm of + Just currentLowest -> rm { largestLowerBound = Just $ min lower currentLowest } + Nothing -> rm { largestLowerBound = Just lower } +-} + +{- +intersectSpansRM :: (Ord a) => RangeMerge a -> (a, a) -> [(a, a)] +intersectSpansRM rm sp@(lower, upper) = intersectedSpans + where + spans = spanRanges rm + intersectedSpans = catMaybes $ map (intersectCompareSpan sp) spans + + largestSpan :: Ord a => [(a, a)] -> [(a, a)] + largestSpan [] = [] + largestSpan xs = (foldr1 (\(l, m) (x, y) -> (min l x, max m y)) xs) : [] + +intersectCompareSpan :: Ord a => (a, a) -> (a, a) -> Maybe (a, a) +intersectCompareSpan f@(l, m) s@(x, y) = if isBetween l s || isBetween m s + then Just (max l x, min m y) + else Nothing +-} + +-- If it was an infinite range then it should not be after an intersection unless it was +-- an intersection with another infinite range. +{- +intersectionRange :: (Ord a, Enum a) => Range a -> RangeMerge a -> RangeMerge a +intersectionRange InfiniteRange rm = rm -- Intersection with universe remains same +intersectionRange (LowerBoundRange lower) rm = rm + { largestLowerBound = largestLowerBound rm >>= return . max lower + , spanRanges = catMaybes . map (updateRange lower) . spanRanges $ rm + } + where + updateRange :: (Ord a) => a -> (a, a) -> Maybe (a, a) + updateRange lower (begin, end) = if lower <= end + then Just (max lower begin, end) + else Nothing +intersectionRange (UpperBoundRange upper) rm = rm + { largestUpperBound = largestUpperBound rm >>= return . min upper + , spanRanges = catMaybes . map (updateRange upper) . spanRanges $ rm + } + where + updateRange :: (Ord a) => a -> (a, a) -> Maybe (a, a) + updateRange upper (begin, end) = if begin <= upper + then Just (begin, min upper end) + else Nothing +intersectionRange (SpanRange lower upper) rm = rm + -- update the bounds first and then update the spans, if the spans were sorted then + { largestUpperBound = largestUpperBound rm >>= return . min upper + , largestLowerBound = largestLowerBound rm >>= return . max lower + -- they would be faster to update I suspect, lets start with not sorted + , spanRanges = joinUnionSortSpans . ((lower, upper) :) . spanRanges $ rm + } + where + joinUnionSortSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] + joinUnionSortSpans = joinSpans . unionSpans . sortSpans + +intersectionRange (SingletonRange value) rm = intersectionRange (SpanRange value value) rm +-} diff --git a/Data/Range/RangeTree.hs b/Data/Range/RangeTree.hs new file mode 100644 --- /dev/null +++ b/Data/Range/RangeTree.hs @@ -0,0 +1,21 @@ +-- | Internally the range library converts your ranges into an internal representation of +-- multiple ranges that I call a RangeMerge. When you do multiple unions and intersections +-- in a row converting to and from that data structure becomes extra work that is not +-- required. To amortize those costs away the RangeTree structure exists. You can specify +-- a tree of operations in advance and then evaluate them all at once. This is not only +-- useful for efficiency but for parsing too. Use RangeTree's whenever you wish to perform +-- multiple operations in a row and wish for it to be as efficient as possible. +module Data.Range.RangeTree + ( evaluate + , RangeTree(..) + , RangeOperation(..) + ) where + +import Data.Range.Data +import Data.Range.RangeInternal +import Data.Range.RangeTreeInternal + +-- | Evaluates a Range Tree into the final set of ranges that it compresses down to. Use +-- this whenever you want to finally evaluate your constructed Range Tree. +evaluate :: (Ord a, Enum a) => RangeTree a -> [Range a] +evaluate = exportRangeMerge . evaluateRangeTree diff --git a/Data/Range/RangeTreeInternal.hs b/Data/Range/RangeTreeInternal.hs new file mode 100644 --- /dev/null +++ b/Data/Range/RangeTreeInternal.hs @@ -0,0 +1,14 @@ +module Data.Range.RangeTreeInternal where + +import Data.Range.Data +import Data.Range.RangeInternal + +evaluateRangeTree :: (Ord a, Enum a) => RangeTree a -> RangeMerge a +evaluateRangeTree (RangeNode operation left right) = case operation of + RangeUnion -> leftEval `unionRangeMerges` rightEval + RangeIntersection -> leftEval `intersectionRangeMerges` rightEval + where + leftEval = evaluateRangeTree left + rightEval = evaluateRangeTree right +evaluateRangeTree (RangeNodeInvert node) = invertRM . evaluateRangeTree $ node +evaluateRangeTree (RangeLeaf ranges) = loadRanges ranges diff --git a/Data/Range/Spans.hs b/Data/Range/Spans.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Spans.hs @@ -0,0 +1,57 @@ +-- This module contains every function that purely performs operations on spans. +module Data.Range.Spans where + +import Data.List (sortBy, insertBy) +import Data.Ord (comparing) + +import Data.Range.Util + +-- Assume that both inputs are sorted spans +insertionSortSpans :: (Ord a) => [(a, a)] -> [(a, a)] -> [(a, a)] +insertionSortSpans = insertionSort (comparing fst) + +spanCmp :: Ord a => (a, a) -> (a, a) -> Ordering +spanCmp x@(xlow, xhigh) y@(ylow, _) = if isBetween xlow y || isBetween ylow x + then EQ + else if xhigh < ylow then LT else GT + +intersectSpans :: (Ord a) => [(a, a)] -> [(a, a)] -> [(a, a)] +intersectSpans (x@(xlow, xup) : xs) (y@(ylow, yup) : ys) = + case spanCmp x y of + EQ -> (max xlow ylow, min xup yup) : if xup < yup + then intersectSpans xs (y : ys) + else intersectSpans (x : xs) ys + LT -> intersectSpans xs (y : ys) + GT -> intersectSpans (x : xs) ys +intersectSpans _ _ = [] + +insertSpan :: Ord a => (a, b) -> [(a, b)] -> [(a, b)] +insertSpan = insertBy (comparing fst) + +sortSpans :: (Ord a) => [(a, a)] -> [(a, a)] +sortSpans = sortBy (comparing fst) + +-- Assume that you are given a sorted list of spans +joinSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] +joinSpans (f@(a, b) : s@(x, y) : xs) = + if succ b == x + then joinSpans $ (a, y) : xs + else f : joinSpans (s : xs) +joinSpans xs = xs + +-- Assume that you are given a sorted list of spans +unionSpans :: Ord a => [(a, a)] -> [(a, a)] +unionSpans (f@(a, b) : s@(x, y) : xs) = if isBetween x f + then unionSpans ((a, max b y) : xs) + else f : unionSpans (s : xs) +unionSpans xs = xs + +-- Assume that you are given a sorted and joined list of spans +invertSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] +invertSpans ((_, x) : s@(y, _) : xs) = (succ x, pred y) : invertSpans (s : xs) +invertSpans _ = [] + +hasOverlaps :: (Ord a, Enum a) => [(a, a)] -> Bool +hasOverlaps xs = any isOverlapping (pairs xs) + where + isOverlapping ((x, y), (a, b)) = isBetween x (pred a, succ b) || isBetween a (pred x, succ y) diff --git a/Data/Range/Util.hs b/Data/Range/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Util.hs @@ -0,0 +1,27 @@ +module Data.Range.Util where + +-- This module is supposed to contain all of the functions that are required by the rest +-- of the code but could be easily pulled into separate and completely non-related +-- codebases or libraries. + +insertionSort :: (Ord a) => (a -> a -> Ordering) -> [a] -> [a] -> [a] +insertionSort comp xs ys = go xs ys + where + go (f : fs) (s : ss) = case comp f s of + LT -> f : go fs (s : ss) + EQ -> f : s : go fs ss + GT -> s : go (f : fs) ss + go [] z = z + go z [] = z + +isBetween :: (Ord a) => a -> (a, a) -> Bool +isBetween a (x, y) = (x <= a) && (a <= y) + +takeEvenly :: [a] -> [a] -> [a] +takeEvenly (a : as) (b : bs) = a : b : takeEvenly as bs +takeEvenly xs [] = xs +takeEvenly [] xs = xs + +pairs :: [a] -> [(a, a)] +pairs [] = [] +pairs xs = zip xs (tail xs) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2013 Robert Massaioli + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/Range.hs b/Test/Range.hs new file mode 100644 --- /dev/null +++ b/Test/Range.hs @@ -0,0 +1,124 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- This is only okay in test classes + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 + +import Control.Monad (liftM) +import System.Random + +import Data.Range.Range + +import Test.RangeMerge + +data UnequalPair a = UnequalPair (a, a) + deriving (Show) + +instance (Num a, Eq a) => Arbitrary (UnequalPair a) where + arbitrary = do + first <- arbitrarySizedIntegral + second <- arbitrarySizedIntegral `suchThat` (/= first) + return $ UnequalPair (first, second) + +prop_singleton_in_range :: Integer -> Bool +prop_singleton_in_range a = inRange (SingletonRange a) a + +prop_singleton_not_in_range :: (Ord a) => UnequalPair a -> Bool +prop_singleton_not_in_range (UnequalPair (first, second)) = not $ inRange (SingletonRange first) second + +data SpanContains a = SpanContains (a, a) a + deriving (Show) + +instance (Num a, Ord a, Random a) => Arbitrary (SpanContains a) where + arbitrary = do + begin <- arbitrarySizedIntegral + end <- arbitrarySizedIntegral `suchThat` (>= begin) + middle <- choose (begin, end) + return $ SpanContains (begin, end) middle + +prop_span_contains :: SpanContains Integer -> Bool +prop_span_contains (SpanContains (begin, end) middle) = inRange (SpanRange begin end) middle + +prop_infinite_range_contains_everything :: Integer -> Bool +prop_infinite_range_contains_everything = inRange InfiniteRange + +tests_inRange = testGroup "inRange Function" + [ testProperty "equal singletons in range" prop_singleton_in_range + , testProperty "unequal singletons not in range" prop_singleton_not_in_range + , testProperty "spans contain values in their middles" prop_span_contains + , testProperty "infinite ranges contain everything" prop_infinite_range_contains_everything + ] + +instance (Num a, Ord a, Enum a) => Arbitrary (Range a) where + arbitrary = oneof + [ generateSingleton + , generateSpan + , generateLowerBound + , generateUpperBound + , generateInfiniteRange + ] + where + generateSingleton = liftM SingletonRange arbitrarySizedIntegral + generateSpan = do + first <- arbitrarySizedIntegral + second <- arbitrarySizedIntegral `suchThat` (> first) + return $ SpanRange first second + generateLowerBound = liftM LowerBoundRange arbitrarySizedIntegral + generateUpperBound = liftM UpperBoundRange arbitrarySizedIntegral + generateInfiniteRange :: Gen (Range a) + generateInfiniteRange = return InfiniteRange + +-- an intersection of a value followed by a union of that value should be the identity. +-- This is false. An intersection of a value followed by a union of that value should be +-- the value itself. +-- (1, 3) union (3, 4) => (1, 4) +-- (1, 3) intersection (3, 4) = (3, 3) +-- ((1, 3) intersection (3, 4)) union (3, 4) => (3, 4) + +prop_in_range_out_of_range_after_invert :: (Integer, [Range Integer]) -> Bool +prop_in_range_out_of_range_after_invert (point, ranges) = + (inRanges ranges point) /= (inRanges (invert ranges) point) + +test_ranges_invert = testGroup "invert function for ranges" + [ testProperty "element in range is now out of range after invert" prop_in_range_out_of_range_after_invert + ] + +prop_elements_before_union_or_true :: ([Integer], [Range Integer], [Range Integer]) -> Bool +prop_elements_before_union_or_true (points, a, b) = actual == expected + where + before_a = map (inRanges a) points + before_b = map (inRanges b) points + unionRanges = a `union` b + actual = map (inRanges unionRanges) points + expected = zipWith (||) before_a before_b + +prop_elements_before_intersection_and_true :: ([Integer], [Range Integer], [Range Integer]) -> Bool +prop_elements_before_intersection_and_true (points, a, b) = actual == expected + where + before_a = map (inRanges a) points + before_b = map (inRanges b) points + intersectedRanges = a `intersection` b + actual = map (inRanges intersectedRanges) points + expected = zipWith (&&) before_a before_b + +test_union = testGroup "union function properties" + [ testProperty "Unions from before OR together and continue to work" prop_elements_before_union_or_true + ] + +test_intersection = testGroup "intersection function properties" + [ testProperty "Intersection before AND's to after" prop_elements_before_intersection_and_true + ] + +--tests :: [Test] +tests = + [ tests_inRange + , test_ranges_invert + , test_union + , test_intersection + ] + ++ rangeMergeTestCases + +main = defaultMain tests diff --git a/range.cabal b/range.cabal new file mode 100644 --- /dev/null +++ b/range.cabal @@ -0,0 +1,81 @@ +-- Initial range.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: range + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: This has a bunch of code for specifying and managing ranges in your code. + +-- A longer description of the package. +description: range is built to allow you to use ranges in your code quickly and + efficiently. There are many occasions where you will want to check if + certain values are within a range and this library will make it + trivial for you to do so. It also attempts to do so in the most + efficient way possible. + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Robert Massaioli + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: robertmassaioli@gmail.com + +-- A copyright notice. +-- copyright: + +category: Data + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + + +library + -- Modules exported by the library. + exposed-modules: Data.Range.Range + , Data.Range.NestedRange + , Data.Range.RangeTree + , Data.Range.Parser + + -- Modules included in this library but not exported. + other-modules: Data.Range.Data + , Data.Range.RangeInternal + , Data.Range.RangeTreeInternal + , Data.Range.Spans + , Data.Range.Util + + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5 + , parsec >= 3 + + ghc-options: -Wall + + +Test-Suite test-range + type: exitcode-stdio-1.0 + main-is: Test/Range.hs + build-depends: + base ==4.5.* + , Cabal >= 1.14 + , QuickCheck >= 2.4.0.1 && < 2.6 + , test-framework-quickcheck2 >= 0.2 && < 0.4 + , test-framework >= 0.4 && < 0.9 + , random >= 1.0 + ghc-options: -rtsopts -Wall