1----------------------------------------------------------------------------- 2-- | 3-- Module : Data.Ranged.Boundaries 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 12module Data.Ranged.Boundaries ( 13 DiscreteOrdered (..), 14 enumAdjacent, 15 boundedAdjacent, 16 boundedBelow, 17 Boundary (..), 18 above, 19 (/>/) 20) where 21 22import Data.Ratio 23import Data.Word 24 25infix 4 />/ 26 27{- | 28Distinguish between dense and sparse ordered types. A dense type is 29one in which any two values @v1 < v2@ have a third value @v3@ such that 30@v1 < v3 < v2@. 31 32In theory the floating types are dense, although in practice they can only have 33finitely many values. This class treats them as dense. 34 35Tuples up to 4 members are declared as instances. Larger tuples may be added 36if necessary. 37 38Most values of sparse types have an @adjacentBelow@, such that, for all x: 39 40> case adjacentBelow x of 41> Just x1 -> adjacent x1 x 42> Nothing -> True 43 44The exception is for bounded types when @x == lowerBound@. For dense types 45@adjacentBelow@ always returns 'Nothing'. 46 47This approach was suggested by Ben Rudiak-Gould on comp.lang.functional. 48-} 49 50class Ord a => DiscreteOrdered a where 51 -- | Two values @x@ and @y@ are adjacent if @x < y@ and there does not 52 -- exist a third value between them. Always @False@ for dense types. 53 adjacent :: a -> a -> Bool 54 -- | The value immediately below the argument, if it can be determined. 55 adjacentBelow :: a -> Maybe a 56 57 58-- Implementation note: the precise rules about unbounded enumerated vs 59-- bounded enumerated types are difficult to express using Haskell 98, so 60-- the prelude types are listed individually here. 61 62instance DiscreteOrdered Bool where 63 adjacent = boundedAdjacent 64 adjacentBelow = boundedBelow 65 66instance DiscreteOrdered Ordering where 67 adjacent = boundedAdjacent 68 adjacentBelow = boundedBelow 69 70instance DiscreteOrdered Char where 71 adjacent = boundedAdjacent 72 adjacentBelow = boundedBelow 73 74instance DiscreteOrdered Int where 75 adjacent = boundedAdjacent 76 adjacentBelow = boundedBelow 77 78instance DiscreteOrdered Integer where 79 adjacent = enumAdjacent 80 adjacentBelow = Just . pred 81 82instance DiscreteOrdered Double where 83 adjacent _ _ = False 84 adjacentBelow = const Nothing 85 86instance DiscreteOrdered Float where 87 adjacent _ _ = False 88 adjacentBelow = const Nothing 89 90instance (Integral a) => DiscreteOrdered (Ratio a) where 91 adjacent _ _ = False 92 adjacentBelow = const Nothing 93 94instance Ord a => DiscreteOrdered [a] where 95 adjacent _ _ = False 96 adjacentBelow = const Nothing 97 98instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b) 99 where 100 adjacent (x1, x2) (y1, y2) = (x1 == y1) && adjacent x2 y2 101 adjacentBelow (x1, x2) = do -- Maybe monad 102 x2' <- adjacentBelow x2 103 return (x1, x2') 104 105instance (Ord a, Ord b, DiscreteOrdered c) => DiscreteOrdered (a, b, c) 106 where 107 adjacent (x1, x2, x3) (y1, y2, y3) = 108 (x1 == y1) && (x2 == y2) && adjacent x3 y3 109 adjacentBelow (x1, x2, x3) = do -- Maybe monad 110 x3' <- adjacentBelow x3 111 return (x1, x2, x3') 112 113instance (Ord a, Ord b, Ord c, DiscreteOrdered d) => 114 DiscreteOrdered (a, b, c, d) 115 where 116 adjacent (x1, x2, x3, x4) (y1, y2, y3, y4) = 117 (x1 == y1) && (x2 == y2) && (x3 == y3) && adjacent x4 y4 118 adjacentBelow (x1, x2, x3, x4) = do -- Maybe monad 119 x4' <- adjacentBelow x4 120 return (x1, x2, x3, x4') 121 122instance DiscreteOrdered Word8 where 123 adjacent x y = x + 1 == y 124 adjacentBelow 0 = Nothing 125 adjacentBelow x = Just (x-1) 126 127 128-- | Check adjacency for sparse enumerated types (i.e. where there 129-- is no value between @x@ and @succ x@). 130enumAdjacent :: (Ord a, Enum a) => a -> a -> Bool 131enumAdjacent x y = (succ x == y) 132 133-- | Check adjacency, allowing for case where x = maxBound. Use as the 134-- definition of "adjacent" for bounded enumerated types such as Int and Char. 135boundedAdjacent :: (Ord a, Enum a) => a -> a -> Bool 136boundedAdjacent x y = if x < y then succ x == y else False 137 138 139-- | The usual implementation of 'adjacentBelow' for bounded enumerated types. 140boundedBelow :: (Eq a, Enum a, Bounded a) => a -> Maybe a 141boundedBelow x = if x == minBound then Nothing else Just $ pred x 142 143{- | 144A Boundary is a division of an ordered type into values above 145and below the boundary. No value can sit on a boundary. 146 147Known bug: for Bounded types 148 149* @BoundaryAbove maxBound < BoundaryAboveAll@ 150 151* @BoundaryBelow minBound > BoundaryBelowAll@ 152 153This is incorrect because there are no possible values in 154between the left and right sides of these inequalities. 155-} 156 157data Boundary a = 158 -- | The argument is the highest value below the boundary. 159 BoundaryAbove a | 160 -- | The argument is the lowest value above the boundary. 161 BoundaryBelow a | 162 -- | The boundary above all values. 163 BoundaryAboveAll | 164 -- | The boundary below all values. 165 BoundaryBelowAll 166 deriving (Show) 167 168-- | True if the value is above the boundary, false otherwise. 169above :: Ord v => Boundary v -> v -> Bool 170above (BoundaryAbove b) v = v > b 171above (BoundaryBelow b) v = v >= b 172above BoundaryAboveAll _ = False 173above BoundaryBelowAll _ = True 174 175-- | Same as 'above', but with the arguments reversed for more intuitive infix 176-- usage. 177(/>/) :: Ord v => v -> Boundary v -> Bool 178(/>/) = flip above 179 180instance (DiscreteOrdered a) => Eq (Boundary a) where 181 b1 == b2 = compare b1 b2 == EQ 182 183instance (DiscreteOrdered a) => Ord (Boundary a) where 184 -- Comparison alogrithm based on brute force and ignorance: 185 -- enumerate all combinations. 186 187 compare boundary1 boundary2 = 188 case boundary1 of 189 BoundaryAbove b1 -> 190 case boundary2 of 191 BoundaryAbove b2 -> compare b1 b2 192 BoundaryBelow b2 -> 193 if b1 < b2 194 then 195 if adjacent b1 b2 then EQ else LT 196 else GT 197 BoundaryAboveAll -> LT 198 BoundaryBelowAll -> GT 199 BoundaryBelow b1 -> 200 case boundary2 of 201 BoundaryAbove b2 -> 202 if b1 > b2 203 then 204 if adjacent b2 b1 then EQ else GT 205 else LT 206 BoundaryBelow b2 -> compare b1 b2 207 BoundaryAboveAll -> LT 208 BoundaryBelowAll -> GT 209 BoundaryAboveAll -> 210 case boundary2 of 211 BoundaryAboveAll -> EQ 212 _ -> GT 213 BoundaryBelowAll -> 214 case boundary2 of 215 BoundaryBelowAll -> EQ 216 _ -> LT 217