1----------------------------------------------------------------------------- 2-- 3-- Module : Data.Ranged.Ranges 4-- Copyright : (c) Paul Johnson 2006 5-- License : BSD-style 6-- Maintainer : paul@cogito.org.uk 7-- Stability : experimental 8-- Portability : portable 9-- 10----------------------------------------------------------------------------- 11 12-- | A range has an upper and lower boundary. 13module Data.Ranged.Ranges ( 14 -- ** Construction 15 Range (..), 16 emptyRange, 17 fullRange, 18 -- ** Predicates 19 rangeIsEmpty, 20 rangeIsFull, 21 rangeOverlap, 22 rangeEncloses, 23 rangeSingletonValue, 24 -- ** Membership 25 rangeHas, 26 rangeListHas, 27 -- ** Set Operations 28 singletonRange, 29 rangeIntersection, 30 rangeUnion, 31 rangeDifference, 32) where 33 34import Data.Ranged.Boundaries 35 36-- | A Range has upper and lower boundaries. 37data Range v = Range {rangeLower, rangeUpper :: Boundary v} 38 39instance (DiscreteOrdered a) => Eq (Range a) where 40 r1 == r2 = (rangeIsEmpty r1 && rangeIsEmpty r2) || 41 (rangeLower r1 == rangeLower r2 && 42 rangeUpper r1 == rangeUpper r2) 43 44 45instance (DiscreteOrdered a) => Ord (Range a) where 46 compare r1 r2 47 | r1 == r2 = EQ 48 | rangeIsEmpty r1 = LT 49 | rangeIsEmpty r2 = GT 50 | otherwise = compare (rangeLower r1, rangeUpper r1) 51 (rangeLower r2, rangeUpper r2) 52 53instance (Show a, DiscreteOrdered a) => Show (Range a) where 54 show r 55 | rangeIsEmpty r = "Empty" 56 | rangeIsFull r = "All x" 57 | otherwise = 58 case rangeSingletonValue r of 59 Just v -> "x == " ++ show v 60 Nothing -> lowerBound ++ "x" ++ upperBound 61 where 62 lowerBound = case rangeLower r of 63 BoundaryBelowAll -> "" 64 BoundaryBelow v -> show v ++ " <= " 65 BoundaryAbove v -> show v ++ " < " 66 BoundaryAboveAll -> error "show Range: lower bound is BoundaryAboveAll" 67 upperBound = case rangeUpper r of 68 BoundaryBelowAll -> error "show Range: upper bound is BoundaryBelowAll" 69 BoundaryBelow v -> " < " ++ show v 70 BoundaryAbove v -> " <= " ++ show v 71 BoundaryAboveAll -> "" 72 73 74-- | True if the value is within the range. 75rangeHas :: Ord v => Range v -> v -> Bool 76 77rangeHas (Range b1 b2) v = 78 (v />/ b1) && not (v />/ b2) 79 80 81-- | True if the value is within one of the ranges. 82rangeListHas :: Ord v => 83 [Range v] -> v -> Bool 84rangeListHas ls v = or $ map (\r -> rangeHas r v) ls 85 86 87-- | The empty range 88emptyRange :: Range v 89emptyRange = Range BoundaryAboveAll BoundaryBelowAll 90 91 92-- | The full range. All values are within it. 93fullRange :: Range v 94fullRange = Range BoundaryBelowAll BoundaryAboveAll 95 96 97-- | A range containing a single value 98singletonRange :: v -> Range v 99singletonRange v = Range (BoundaryBelow v) (BoundaryAbove v) 100 101 102-- | If the range is a singleton, returns @Just@ the value. Otherwise returns 103-- @Nothing@. 104-- 105-- Known bug: This always returns @Nothing@ for ranges including 106-- @BoundaryBelowAll@ or @BoundaryAboveAll@. For bounded types this can be 107-- incorrect. For instance, the following range only contains one value: 108-- 109-- > Range (BoundaryBelow maxBound) BoundaryAboveAll 110rangeSingletonValue :: DiscreteOrdered v => Range v -> Maybe v 111rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryBelow v2)) 112 | adjacent v1 v2 = Just v1 113 | otherwise = Nothing 114rangeSingletonValue (Range (BoundaryBelow v1) (BoundaryAbove v2)) 115 | v1 == v2 = Just v1 116 | otherwise = Nothing 117rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryBelow v2)) = 118 do 119 v2' <- adjacentBelow v2 120 v2'' <- adjacentBelow v2' 121 if v1 == v2'' then return v2' else Nothing 122rangeSingletonValue (Range (BoundaryAbove v1) (BoundaryAbove v2)) 123 | adjacent v1 v2 = Just v2 124 | otherwise = Nothing 125rangeSingletonValue (Range _ _) = Nothing 126 127-- | A range is empty unless its upper boundary is greater than its lower 128-- boundary. 129rangeIsEmpty :: DiscreteOrdered v => Range v -> Bool 130rangeIsEmpty (Range lower upper) = upper <= lower 131 132 133-- | A range is full if it contains every possible value. 134rangeIsFull :: DiscreteOrdered v => Range v -> Bool 135rangeIsFull = (== fullRange) 136 137-- | Two ranges overlap if their intersection is non-empty. 138rangeOverlap :: DiscreteOrdered v => Range v -> Range v -> Bool 139rangeOverlap r1 r2 = 140 not (rangeIsEmpty r1) 141 && not (rangeIsEmpty r2) 142 && not (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1) 143 144 145-- | The first range encloses the second if every value in the second range is 146-- also within the first range. If the second range is empty then this is 147-- always true. 148rangeEncloses :: DiscreteOrdered v => Range v -> Range v -> Bool 149rangeEncloses r1 r2 = 150 (rangeLower r1 <= rangeLower r2 && rangeUpper r2 <= rangeUpper r1) 151 || rangeIsEmpty r2 152 153 154-- | Intersection of two ranges, if any. 155rangeIntersection :: DiscreteOrdered v => Range v -> Range v -> Range v 156rangeIntersection r1@(Range lower1 upper1) r2@(Range lower2 upper2) 157 | rangeIsEmpty r1 || rangeIsEmpty r2 = emptyRange 158 | otherwise = Range (max lower1 lower2) (min upper1 upper2) 159 160 161-- | Union of two ranges. Returns one or two results. 162-- 163-- If there are two results then they are guaranteed to have a non-empty 164-- gap in between, but may not be in ascending order. 165rangeUnion :: DiscreteOrdered v => Range v -> Range v -> [Range v] 166rangeUnion r1@(Range lower1 upper1) r2@(Range lower2 upper2) 167 | rangeIsEmpty r1 = [r2] 168 | rangeIsEmpty r2 = [r1] 169 | otherwise = 170 if touching then [Range lower upper] else [r1, r2] 171 where 172 touching = (max lower1 lower2) <= (min upper1 upper2) 173 lower = min lower1 lower2 174 upper = max upper1 upper2 175 176 177-- | @range1@ minus @range2@. Returns zero, one or two results. Multiple 178-- results are guaranteed to have non-empty gaps in between, but may not be in 179-- ascending order. 180rangeDifference :: DiscreteOrdered v => Range v -> Range v -> [Range v] 181 182rangeDifference r1@(Range lower1 upper1) (Range lower2 upper2) = 183 -- There are six possibilities 184 -- 1: r2 completely less than r1 185 -- 2: r2 overlaps bottom of r1 186 -- 3: r2 encloses r1 187 -- 4: r1 encloses r2 188 -- 5: r2 overlaps top of r1 189 -- 6: r2 completely greater than r1 190 if intersects 191 then -- Cases 2,3,4,5 192 filter (not . rangeIsEmpty) [Range lower1 lower2, Range upper2 upper1] 193 else -- Cases 1, 6 194 [r1] 195 where 196 intersects = (max lower1 lower2) < (min upper1 upper2) 197